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)
3584 C...Initial values for some counters.
3597 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3600 C...Zero counters for pT-ordered showers (failsafe)
3604 C...Let called routines know call is from PYEVNW (not PYEVNT).
3607 C...If variable energies: redo incoming kinematics and cross-section.
3609 IF(MSTP(171).EQ.1) THEN
3611 IF(MSTI(61).EQ.1) THEN
3615 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3619 C...Loop over number of pileup events; check space left.
3620 IF(MSTP(131).LE.0) THEN
3626 DO 300 IPILE=1,NPILE
3627 IF(MINT(84)+100.GE.MSTU(4)) THEN
3629 & '(PYEVNW:) no more space in PYJETS for pileup events')
3630 IF(MSTU(21).GE.1) GOTO 310
3634 C...Generate variables of hard scattering.
3640 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3641 IF(LOOPHS.GE.10) THEN
3642 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3643 & //'multiple interactions. Returning.')
3653 IF(MSTI(61).EQ.1) THEN
3657 IF(MINT(51).EQ.2) RETURN
3659 IF(MSTP(111).EQ.-1) GOTO 290
3661 C...Loopback point if PYPREP fails, especially for junction topologies.
3667 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3668 C...Hard scattering (including low-pT):
3669 C...reconstruct kinematics and colour flow of hard scattering.
3674 IF(MINT(51).EQ.1) GOTO 100
3678 C...Intertwined initial state showers and multiple interactions.
3679 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3680 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3682 IF (MINT(47).LT.2) MSTP(61)=0
3684 IF (MINT(50).EQ.0) MSTP(81)=0
3685 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3686 & MINT(111).NE.12) THEN
3687 C...Absolute max pT2 scale for evolution: phase space limit.
3688 PT2MXS=0.25D0*VINT(2)
3689 C...Check if more constrained by ISR and MI max scales:
3690 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3691 C...Loopback point in case of failure in evolution.
3695 IF(LOOP.GT.100) THEN
3696 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3697 & //'multiple interactions. Trying new point.')
3702 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3703 C...once per event. (E.g. compute constants and save variables to be
3704 C...restored later in case of failure.)
3705 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3707 C...Initialize interleaved MI/ISR/JI evolution.
3708 C...PT2MAX: absolute upper limit for evolution - Initialization may
3709 C... return a PT2MAX which is lower than this.
3710 C...PT2MIN: absolute lower limit for evolution - Initialization may
3711 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3714 CALL PYEVOL(0,PT2MAX,PT2MIN)
3715 C...If failed to initialize evolution, generate a new hard process
3716 IF (MINT(51).EQ.1) GOTO 100
3718 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3719 C...In principle factorized, so can be stopped and restarted.
3720 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3721 C PT2MED=MAX(10D0**2,PT2MIN)
3722 C CALL PYEVOL(1,PT2MAX,PT2MED)
3723 C IF (MINT(51).EQ.1) GOTO 160
3725 CALL PYEVOL(1,PT2MAX,PT2MIN)
3726 C...If fatal error (e.g., massive hard-process initiator, but no available
3727 C...phase space for creation), generate a new hard process
3728 IF (MINT(51).EQ.2) GOTO 100
3729 C...If smaller error, just try running evolution again
3730 IF (MINT(51).EQ.1) GOTO 130
3732 C...Finalize interleaved MI/ISR/JI evolution.
3733 CALL PYEVOL(2,PT2MAX,PT2MIN)
3734 IF (MINT(51).EQ.1) GOTO 130
3739 IF(MINT(51).EQ.1) GOTO 100
3740 C...(MINT(52) is actually obsolete in this routine. Set anyway
3741 C...to ensure PYDOCU stable.)
3745 C...Beam remnants - new scheme.
3746 140 IF(MINT(50).EQ.1) THEN
3747 IF (ISUB.EQ.95) MINT(31)=1
3749 C...Beam remnant flavour and colour assignments - new scheme.
3751 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3753 IF(MINT(51).EQ.1) GOTO 100
3755 C...Primordial kT and beam remnant momentum sharing - new scheme.
3757 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3759 IF(MINT(51).EQ.1) GOTO 100
3760 IF (ISUB.EQ.95) MINT(31)=0
3761 ELSEIF(MINT(111).NE.12) THEN
3762 C...Hadron remnants and primordial kT - old model.
3763 C...Happens e.g. for direct photon on one side.
3766 CALL PYREMN(IPU1,IPU2)
3767 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3769 IF(MINT(51).EQ.1) GOTO 100
3770 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3771 DO 160 I=MINT(53)+1,N
3773 IDA=MOD(K(I,KCS),MSTU(5))
3775 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3781 C...Instruct PYPREP to use colour tags
3785 DO 350 I=MINT(84)+1,N
3787 C...Look for coloured string endpoint, or (later) leftover gluon.
3788 IF (K(I,1).NE.3) GOTO 350
3790 IF(KC.EQ.0) GOTO 350
3792 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3794 C... Pick up loose string end with no previous tag.
3796 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3797 IF(MCT(I,KCS-3).NE.0) GOTO 350
3799 CALL PYCTTR(I,KCS,I)
3800 IF(MINT(51).NE.0) RETURN
3804 C...Now delete any colour processing information if set (since partons
3805 C...otherwise not FS showered!)
3806 DO 170 I=MINT(84)+1,N
3808 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3809 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3814 C...Showering of final state partons (optional).
3817 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3820 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3821 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3822 C...External processes: handle successive showers.
3823 ELSEIF(ISET(ISUB).EQ.11) THEN
3828 C...Allow possibility for user to abort event generation.
3830 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3832 C...........No reason to count this as an error
3838 C...Decay of final state resonances.
3840 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3842 IF(MINT(51).NE.0) GOTO 100
3845 IF(MINT(51).EQ.1) GOTO 100
3847 ELSEIF(ISUB.NE.99) THEN
3848 C...Diffractive and elastic scattering.
3852 C...DIS scattering (photon flux external).
3854 IF(MINT(51).EQ.1) GOTO 100
3857 C...Check that no odd resonance left undecayed.
3859 IF(MSTP(111).GE.1) THEN
3861 DO 180 I=MINT(84)+1,NFIX
3862 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3863 & K(I,2).NE.22) THEN
3865 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3867 IF(MINT(51).EQ.1) GOTO 100
3873 C...Boost hadronic subsystem to overall rest frame.
3874 C..(Only relevant when photon inside lepton beam.)
3875 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3877 C...Recalculate energies from momenta and masses (if desired).
3878 IF(MSTP(113).GE.1) THEN
3879 DO 190 I=MINT(83)+1,N
3880 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3881 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3886 C...Colour reconnection before string formation
3887 CALL PYFSCR(MINT(84)+1)
3889 C...Rearrange partons along strings, check invariant mass cuts.
3891 IF(MSTP(111).LE.0) MSTJ(14)=-1
3892 CALL PYPREP(MINT(84)+1)
3894 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3898 IF(MINT(51).EQ.1) GOTO 110
3899 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3900 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3901 DO 220 I=MINT(84)+1,N
3902 IF(K(I,2).EQ.94) THEN
3903 DO 210 I1=I+1,MIN(N,I+10)
3904 IF(K(I1,3).EQ.I) THEN
3905 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3906 IF(K(I1,3).EQ.0) THEN
3907 DO 200 II=MINT(84)+1,I-1
3908 IF(K(II,2).EQ.K(I1,2)) THEN
3909 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3910 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3913 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3917 CC...Also collapse particles decaying to themselves (if same KS)
3918 ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3919 & .AND.K(I,4).LT.N) THEN
3921 IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3928 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3929 IF(MSTP(125).EQ.0) MINT(4)=0
3930 DO 240 I=MINT(83)+1,N
3931 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3933 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3934 IF(K(I1,3).EQ.I) K(I,5)=I1
3940 C...Introduce separators between sections in PYLIST event listing.
3941 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3944 ELSEIF(IPILE.EQ.1) THEN
3951 C...Go back to lab frame (needed for vertices, also in fragmentation).
3954 C...Set nonvanishing production vertex (optional).
3955 IF(MSTP(151).EQ.1) THEN
3957 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3958 & SIN(PARU(2)*PYR(0))
3960 DO 270 I=MINT(83)+1,N
3962 V(I,J)=V(I,J)+VTX(J)
3967 C...Perform hadronization (if desired).
3968 IF(MSTP(111).GE.1) THEN
3970 IF(MSTU(24).NE.0) GOTO 100
3972 IF(MSTP(113).GE.1) THEN
3974 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3975 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3978 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3980 C...Store event information and calculate Monte Carlo estimates of
3981 C...subprocess cross-sections.
3982 290 IF(IPILE.EQ.1) CALL PYDOCU
3984 C...Set counters for current pileup event and loop to next one.
3986 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3987 IF(MSTU70.LT.10) THEN
3992 MINT(84)=N+MSTP(126)
3993 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3996 C...Generic information on pileup events. Reconstruct missing history.
3997 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
4001 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
4005 C...Transform to the desired coordinate frame.
4006 310 CALL PYFRAM(MSTP(124))
4011 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4012 &1X,'Execution stopped.')
4018 C***********************************************************************
4021 C...Prints out information about cross-sections, decay widths, branching
4022 C...ratios, kinematical limits, status codes and parameter values.
4024 SUBROUTINE PYSTAT(MSTAT)
4026 C...Double precision and integer declarations.
4027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4028 IMPLICIT INTEGER(I-N)
4029 INTEGER PYK,PYCHGE,PYCOMP
4030 C...Parameter statement to help give large particle numbers.
4031 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4032 &KEXCIT=4000000,KDIMEN=5000000)
4033 PARAMETER (EPS=1D-3)
4035 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4036 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4037 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4038 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4039 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4040 COMMON/PYINT1/MINT(400),VINT(400)
4041 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4042 COMMON/PYINT4/MWID(500),WIDS(500,5)
4043 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4044 COMMON/PYINT6/PROC(0:500)
4045 CHARACTER PROC*28, CHTMP*16
4046 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4047 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4048 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4049 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4050 C...Local arrays, character variables and data.
4051 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4052 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4053 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4054 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4055 CHARACTER*24 CHD0, CHDC(10)
4056 CHARACTER*6 DNAME(3)
4058 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4059 &'VMD/hadron * anomalous ','direct * direct ',
4060 &'direct * anomalous ','anomalous * anomalous '/
4061 DATA DISGA/'e * VMD','e * anomalous'/
4063 &'direct * direct ','direct * VMD ',
4064 &'direct * anomalous ','VMD * direct ',
4065 &'VMD * VMD ','VMD * anomalous ',
4066 &'anomalous * direct ','anomalous * VMD ',
4067 &'anomalous * anomalous ','DIS * VMD ',
4068 &'DIS * anomalous ','VMD * DIS ',
4069 &'anomalous * DIS '/
4071 &'direct * direct ','direct * resolved ',
4072 &'resolved * direct ','resolved * resolved '/
4074 &'direct * hadron ','resolved * hadron '/
4076 &'VMD * hadron ','direct * hadron ',
4077 &'anomalous * hadron ','DIS * hadron '/
4078 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4079 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4080 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4081 &' y*_small ',' eta*_large ',' eta*_small ',
4082 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4083 &' x_2 ',' x_F ',' cos(theta_hard) ',
4084 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4085 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4087 DATA DNAME /'q ','lepton','nu '/
4091 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4092 WRITE(MSTU(11),5000)
4093 WRITE(MSTU(11),5100)
4094 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4096 IF(MSUB(I).NE.1) GOTO 100
4097 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4099 IF(MINT(121).GT.1) THEN
4100 WRITE(MSTU(11),5300)
4101 DO 110 IGA=1,MINT(121)
4103 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4104 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4106 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4107 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4109 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4110 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4112 ELSEIF(MINT(121).EQ.4) THEN
4113 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4115 ELSEIF(MINT(121).EQ.2) THEN
4116 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4119 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4125 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4126 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4128 C...Decay widths and branching ratios.
4129 ELSEIF(MSTAT.EQ.2) THEN
4130 WRITE(MSTU(11),5500)
4131 WRITE(MSTU(11),5600)
4134 CALL PYNAME(KF,CHKF)
4137 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4138 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4139 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4140 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4141 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4143 IF(MWID(KC).LE.0) GOTO 140
4144 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4145 & KF/KSUSY1.EQ.2)) GOTO 140
4147 C...Off-shell branchings.
4150 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4151 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4152 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4153 DO 120 J=1,MDCY(KC,3)
4156 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4157 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4159 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4160 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4161 CALL PYNAME(KFDP(IDC,1),CHD1)
4162 CALL PYNAME(KFDP(IDC,2),CHD2)
4163 IF(KFDP(IDC,3).EQ.0) THEN
4164 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4165 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4166 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4168 CALL PYNAME(KFDP(IDC,3),CHD3)
4169 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4170 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4171 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4174 C...On-shell decays.
4176 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4178 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4179 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4180 & STATE(MDCY(KC,1)),BRFIN
4181 DO 130 J=1,MDCY(KC,3)
4184 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4185 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4187 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4188 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4190 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4192 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4193 CALL PYNAME(KFDP(IDC,1),CHD1)
4194 CALL PYNAME(KFDP(IDC,2),CHD2)
4195 IF(KFDP(IDC,3).EQ.0) THEN
4196 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4197 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4198 & CHD2(1:10),WDTP(J),BRPRI,
4199 & STATE(MDME(IDC,1)),BRFIN
4201 CALL PYNAME(KFDP(IDC,3),CHD3)
4202 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4203 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4204 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4205 & STATE(MDME(IDC,1)),BRFIN
4210 WRITE(MSTU(11),6000)
4212 C...Allowed incoming partons/particles at hard interaction.
4213 ELSEIF(MSTAT.EQ.3) THEN
4214 WRITE(MSTU(11),6100)
4215 CALL PYNAME(MINT(11),CHAU)
4217 CALL PYNAME(MINT(12),CHAU)
4219 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4223 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4224 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4226 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4229 WRITE(MSTU(11),6400)
4231 C...User-defined limits on kinematical variables.
4232 ELSEIF(MSTAT.EQ.4) THEN
4233 WRITE(MSTU(11),6500)
4234 WRITE(MSTU(11),6600)
4236 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4237 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4238 PTHMIN=MAX(CKIN(3),CKIN(5))
4240 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4241 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4242 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4244 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4247 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4248 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4249 WRITE(MSTU(11),7000)
4251 C...Status codes and parameter values.
4252 ELSEIF(MSTAT.EQ.5) THEN
4253 WRITE(MSTU(11),7100)
4254 WRITE(MSTU(11),7200)
4256 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4260 C...List of all processes implemented in the program.
4261 ELSEIF(MSTAT.EQ.6) THEN
4262 WRITE(MSTU(11),7400)
4263 WRITE(MSTU(11),7500)
4265 IF(ISET(I).LT.0) GOTO 180
4266 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4268 WRITE(MSTU(11),7700)
4270 ELSEIF(MSTAT.EQ.7) THEN
4271 WRITE (MSTU(11),8000)
4277 KFSUSY=ILR*KSUSY1+KFSM
4280 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4286 CALL PYNAME(KFSUSY,CHTMP)
4288 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4289 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4290 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4292 DO 200 J=1,MDCY(KC,3)
4294 ID1=IABS(KFDP(IDC,1))
4295 ID2=IABS(KFDP(IDC,2))
4296 IF (KFDP(IDC,3).EQ.0) THEN
4297 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4298 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4299 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4300 NMODES(1)=NMODES(1)+1
4301 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4302 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4303 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4304 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4305 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4306 NMODES(2)=NMODES(2)+1
4307 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4308 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4309 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4310 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4311 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4312 NMODES(3)=NMODES(3)+1
4313 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4314 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4320 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4326 CALL PYNAME(KFSUSY,CHTMP)
4328 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4329 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4331 DO 220 J=1,MDCY(KC,3)
4333 ID1=IABS(KFDP(IDC,1))
4334 ID2=IABS(KFDP(IDC,2))
4335 IF (KFDP(IDC,3).EQ.0) THEN
4336 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4337 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4338 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4339 NMODES(1)=NMODES(1)+1
4340 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4341 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4342 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4343 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4344 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4345 NMODES(2)=NMODES(2)+1
4346 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4347 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4353 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4359 CALL PYNAME(KFSUSY,CHTMP)
4361 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4362 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4364 DO 240 J=1,MDCY(KC,3)
4366 ID1=IABS(KFDP(IDC,1))
4367 ID2=IABS(KFDP(IDC,2))
4368 IF (KFDP(IDC,3).EQ.0) THEN
4369 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4370 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4371 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4372 NMODES(1)=NMODES(1)+1
4373 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4374 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4376 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4377 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4378 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4379 NMODES(2)=NMODES(2)+1
4380 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4381 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4386 C...SNEUTRINO DECAYS
4387 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4394 CALL PYNAME(KFSUSY,CHTMP)
4396 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4397 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4399 DO 260 J=1,MDCY(KC,3)
4401 ID1=IABS(KFDP(IDC,1))
4402 ID2=IABS(KFDP(IDC,2))
4403 IF (KFDP(IDC,3).EQ.0) THEN
4404 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4405 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4406 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4407 NMODES(1)=NMODES(1)+1
4408 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4409 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4411 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4412 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4413 NMODES(2)=NMODES(2)+1
4414 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4415 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4416 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4421 IF (NRVDC.NE.0) THEN
4423 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4424 NMODES(0)=NMODES(0)+NMODES(I)
4432 C...NEUTRALINO DECAYS
4433 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4439 CALL PYNAME(KFSUSY,CHTMP)
4441 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4442 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4443 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4444 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4446 DO 310 J=1,MDCY(KC,3)
4448 ID1=IABS(KFDP(IDC,1))
4449 ID2=IABS(KFDP(IDC,2))
4450 ID3=IABS(KFDP(IDC,3))
4451 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4452 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4453 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4454 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4455 NMODES(1)=NMODES(1)+1
4456 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4457 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4458 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4459 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4460 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4461 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4462 NMODES(2)=NMODES(2)+1
4463 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4464 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4465 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4466 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4467 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4468 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4469 NMODES(3)=NMODES(3)+1
4470 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4471 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4472 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4473 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4474 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4475 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4476 NMODES(4)=NMODES(4)+1
4477 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4478 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4483 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4489 CALL PYNAME(KFSUSY,CHTMP)
4491 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4492 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4493 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4494 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4495 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4497 DO 330 J=1,MDCY(KC,3)
4499 ID1=IABS(KFDP(IDC,1))
4500 ID2=IABS(KFDP(IDC,2))
4501 ID3=IABS(KFDP(IDC,3))
4502 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4503 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4504 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4505 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4506 NMODES(1)=NMODES(1)+1
4507 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4508 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4509 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4510 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4511 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4512 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4513 NMODES(1)=NMODES(1)+1
4514 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4515 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4516 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4517 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4518 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4519 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4520 NMODES(2)=NMODES(2)+1
4521 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4522 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4523 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4524 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4525 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4526 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4527 NMODES(3)=NMODES(3)+1
4528 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4529 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4530 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4531 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4532 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4533 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4534 NMODES(3)=NMODES(3)+1
4535 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4536 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4537 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4538 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4539 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4540 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4541 NMODES(4)=NMODES(4)+1
4542 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4543 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4544 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4545 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4546 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4547 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4548 NMODES(4)=NMODES(4)+1
4549 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4550 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4551 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4552 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4553 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4554 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4555 NMODES(5)=NMODES(5)+1
4556 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4557 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4558 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4559 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4560 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4561 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4562 NMODES(5)=NMODES(5)+1
4563 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4564 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4569 IF (KFSM.EQ.21) THEN
4575 CALL PYNAME(KFSUSY,CHTMP)
4577 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4578 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4579 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4581 DO 350 J=1,MDCY(KC,3)
4583 ID1=IABS(KFDP(IDC,1))
4584 ID2=IABS(KFDP(IDC,2))
4585 ID3=IABS(KFDP(IDC,3))
4586 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4587 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4588 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4589 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4590 NMODES(1)=NMODES(1)+1
4591 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4592 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4593 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4594 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4595 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4596 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4597 NMODES(2)=NMODES(2)+1
4598 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4599 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4600 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4601 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4602 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4603 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4604 NMODES(3)=NMODES(3)+1
4605 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4606 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4611 IF (NRVDC.NE.0) THEN
4613 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4614 NMODES(0)=NMODES(0)+NMODES(I)
4618 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4620 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4621 WRITE (MSTU(11),8500)
4625 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4626 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4630 WRITE (MSTU(11),8600)
4634 C...Formats for printouts.
4635 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4636 &'Events and Cross-sections',1X,9('*'))
4637 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4638 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4639 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4640 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4641 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4642 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4644 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4646 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4647 &1X,'I',34X,'I',28X,'I',12X,'I')
4648 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4649 &1X,'********* Total number of errors, excluding junctions =',
4650 &1X,I8,' *************'/
4651 &1X,'********* Total number of errors, including junctions =',
4652 &1X,I8,' *************'/
4653 &1X,'********* Total number of warnings = ',
4654 &1X,I8,' *************'/
4655 &1X,'********* Fraction of events that fail fragmentation ',
4656 &'cuts =',1X,F8.5,' *********'/)
4657 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4658 &'Ratios',1X,27('*'))
4659 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4660 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4661 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4662 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4664 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4665 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4666 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4667 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4668 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4669 &1P,D10.3,0P,1X,'I')
4670 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4671 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4672 &1P,D10.3,0P,1X,'I')
4673 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4674 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4675 &'Particles at Hard Interaction',1X,7('*'))
4676 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4677 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4678 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4679 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4680 &78('=')/1X,'I',38X,'I',37X,'I')
4681 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4682 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4683 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4684 &'Kinematical Variables',1X,12('*'))
4685 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4686 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4688 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4689 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4690 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4691 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4692 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4693 &'Parameter Values',1X,12('*'))
4694 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4696 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4697 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4699 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4700 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4701 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4702 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4703 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4705 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4706 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4707 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4708 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4709 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4710 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4711 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4712 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4713 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4715 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4716 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4717 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4719 & 1X,'R-Violating couplings',1X/ 1X /
4721 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4722 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4723 & ,'I',15X,'I',15X,'I',15X,'I')
4724 8600 FORMAT(1X,55('='))
4725 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4726 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4731 C*********************************************************************
4734 C...Administers the hard-process generation required for output to the
4735 C...Les Houches event record.
4739 C...Double precision and integer declarations.
4740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4741 IMPLICIT INTEGER(I-N)
4742 INTEGER PYK,PYCHGE,PYCOMP
4745 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4746 COMMON/PYCTAG/NCT,MCT(4000,2)
4747 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4748 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4749 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4750 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4751 COMMON/PYINT1/MINT(400),VINT(400)
4752 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4753 COMMON/PYINT4/MWID(500),WIDS(500,5)
4754 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4755 &/PYINT1/,/PYINT2/,/PYINT4/
4757 C...HEPEUP for output.
4759 PARAMETER (MAXNUP=500)
4760 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4761 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4762 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4763 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4764 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4767 C...Stop if no subprocesses on.
4768 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4769 WRITE(MSTU(11),5100)
4773 C...Special flags for hard-process generation only.
4779 C...Initial values for some counters.
4790 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4793 C...If variable energies: redo incoming kinematics and cross-section.
4795 IF(MSTP(171).EQ.1) THEN
4797 IF(MSTI(61).EQ.1) THEN
4801 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4805 C...Do not allow pileup events.
4808 C...Generate variables of hard scattering.
4812 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4817 IF(MSTI(61).EQ.1) THEN
4821 IF(MINT(51).EQ.2) RETURN
4824 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4825 C...Hard scattering (including low-pT):
4826 C...reconstruct kinematics and colour flow of hard scattering.
4831 IF(MINT(51).EQ.1) GOTO 100
4835 C...Decay of final state resonances.
4837 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4839 IF(MINT(51).EQ.1) GOTO 100
4842 C...Longitudinal boost of hard scattering.
4843 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4844 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4846 ELSEIF(ISUB.NE.99) THEN
4847 C...Diffractive and elastic scattering.
4851 C...DIS scattering (photon flux external).
4853 IF(MINT(51).EQ.1) GOTO 100
4856 C...Check that no odd resonance left undecayed.
4859 DO 120 I=MINT(84)+1,NFIX
4860 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4861 & K(I,2).NE.22) THEN
4863 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4865 IF(MINT(51).EQ.1) GOTO 100
4870 C...Boost hadronic subsystem to overall rest frame.
4871 C..(Only relevant when photon inside lepton beam.)
4872 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4874 C...Store event information and calculate Monte Carlo estimates of
4875 C...subprocess cross-sections.
4878 C...Transform to the desired coordinate frame.
4879 140 CALL PYFRAM(MSTP(124))
4883 C...Restore special flags for hard-process generation only.
4887 C...Trace colour tags; convert to LHA style labels.
4889 DO 150 I=MINT(84)+1,N
4893 DO 160 I=MINT(84)+1,N
4894 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4895 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4896 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4898 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4899 IDA=MOD(K(I,4),MSTU(5))
4900 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4901 & MCT(IMO,2).NE.0) THEN
4903 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4904 & MCT(IMO,1).NE.0) THEN
4906 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4907 & MCT(IDA,2).NE.0) THEN
4914 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4916 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4917 IDA=MOD(K(I,5),MSTU(5))
4918 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4919 & MCT(IMO,1).NE.0) THEN
4921 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4922 & MCT(IMO,2).NE.0) THEN
4924 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4925 & MCT(IDA,1).NE.0) THEN
4935 C...Put event in HEPEUP commonblock.
4943 IDUP(I)=K(I+MINT(84),2)
4948 ELSEIF(K(I+4,3).EQ.0) THEN
4954 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4957 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4958 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4959 ICOLUP(1,I)=MCT(I+MINT(84),1)
4960 ICOLUP(2,I)=MCT(I+MINT(84),2)
4962 PUP(J,I)=P(I+MINT(84),J)
4968 C...Optionally write out event to disk. Minimal size for time/spin fields.
4969 IF(MSTP(162).GT.0) THEN
4970 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4972 IF(VTIMUP(I).EQ.0D0) THEN
4973 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4974 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4977 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4978 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4983 C...Optional extra line with parton-density information.
4984 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4985 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4988 C...Error messages and other print formats.
4989 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4990 &1X,'Execution stopped.')
4991 5200 FORMAT(1P,2I6,4E14.6)
4992 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4993 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4994 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4999 C*********************************************************************
5002 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
5003 C...processes, and optionally stores that information on file.
5007 C...Double precision and integer declarations.
5008 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5009 IMPLICIT INTEGER(I-N)
5012 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5013 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5014 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5015 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5016 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5018 C...User process initialization commonblock.
5020 PARAMETER (MAXPUP=100)
5021 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5022 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5023 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5024 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5028 C...Store info on incoming beams.
5038 C...Event weighting strategy.
5041 C...Info on individual processes.
5044 IF(MSUB(ISUB).EQ.1) THEN
5046 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5047 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5053 C...Write info to file.
5054 IF(MSTP(161).GT.0) THEN
5055 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5056 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5058 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5063 C...Formats for printout.
5064 5100 FORMAT(1P,2I8,2E14.6,6I6)
5065 5200 FORMAT(1P,3E14.6,I6)
5071 C*********************************************************************
5073 C...Combine the two old-style Pythia initialization and event files
5074 C...into a single Les Houches Event File.
5078 C...Double precision and integer declarations.
5079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5080 IMPLICIT INTEGER(I-N)
5082 C...PYTHIA commonblock: only used to provide read/write units and version.
5083 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5086 C...User process initialization commonblock.
5088 PARAMETER (MAXPUP=100)
5089 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5090 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5091 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5092 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5096 C...User process event common block.
5098 PARAMETER (MAXNUP=500)
5099 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5100 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5101 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5102 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5103 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5106 C...Lines to read in assumed never longer than 200 characters.
5107 PARAMETER (MAXLEN=200)
5108 CHARACTER*(MAXLEN) STRING
5110 C...Format for reading lines.
5113 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5115 C...Rewind initialization and event files.
5119 C...Write header info.
5120 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5121 WRITE(MSTP(163),'(A)') '<!--'
5122 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5123 &MSTP(181),'.',MSTP(182)
5124 WRITE(MSTP(163),'(A)') '-->'
5126 C...Read first line of initialization info and get number of processes.
5127 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5128 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5129 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5131 C...Copy initialization lines, omitting trailing blanks.
5132 C...Embed in <init> ... </init> block.
5133 WRITE(MSTP(163),'(A)') '<init>'
5135 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5138 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5139 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5141 WRITE(MSTP(163),'(A)') '</init>'
5143 C...Begin event loop. Read first line of event info or already done.
5144 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5147 C...Look at first line to know number of particles in event.
5148 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5150 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5151 WRITE(MSTP(163),'(A)') '<event>'
5153 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5156 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5157 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5160 C...Copy trailing comment lines - with a # in the first column - as is.
5161 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5162 IF(STRING(1:1).EQ.'#') THEN
5165 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5166 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5170 C..End the <event> block. Loop back to look for next event.
5171 WRITE(MSTP(163),'(A)') '</event>'
5174 C...Successfully reached end of event loop: write closing tag
5175 C...and remove temporary intermediate files (unless asked not to).
5176 300 WRITE(MSTP(163),'(A)') '</event>'
5177 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5178 IF(MSTP(164).EQ.1) RETURN
5179 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5180 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5184 400 WRITE(*,*) ' PYLHEF file joining failed!'
5189 C*********************************************************************
5192 C...Calculates full and effective widths of gauge bosons, stores
5193 C...masses and widths, rescales coefficients to be used for
5194 C...resonance production generation.
5198 C...Double precision and integer declarations.
5199 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5200 IMPLICIT INTEGER(I-N)
5201 INTEGER PYK,PYCHGE,PYCOMP
5202 C...Parameter statement to help give large particle numbers.
5203 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5204 &KEXCIT=4000000,KDIMEN=5000000)
5206 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5207 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5208 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5209 COMMON/PYDAT4/CHAF(500,2)
5211 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5212 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5213 COMMON/PYINT1/MINT(400),VINT(400)
5214 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5215 COMMON/PYINT4/MWID(500),WIDS(500,5)
5216 COMMON/PYINT6/PROC(0:500)
5218 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5219 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5220 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5221 C...Local arrays and data.
5222 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5223 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5225 C...Born level couplings in MSSM Higgs doublet sector.
5228 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5230 IF(MSTP(4).EQ.2) THEN
5232 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5236 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5237 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5239 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5240 WRITE(MSTU(11),5000)
5243 PMAS(35,1)=SQRT(SQMHP)
5244 PMAS(36,1)=SQRT(SQMA)
5245 PMAS(37,1)=SQRT(SQMHC)
5246 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5251 PARU(161)=-SIN(ALSU)/COS(BESU)
5252 PARU(162)=COS(ALSU)/SIN(BESU)
5254 PARU(164)=SIN(BESU-ALSU)
5256 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5257 PARU(171)=COS(ALSU)/COS(BESU)
5258 PARU(172)=SIN(ALSU)/SIN(BESU)
5260 PARU(174)=COS(BESU-ALSU)
5262 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5264 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5265 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5271 PARU(186)=COS(BESU-ALSU)
5272 PARU(187)=SIN(BESU-ALSU)
5276 PARU(195)=COS(BESU-ALSU)
5279 C...Reset effective widths of gauge bosons.
5286 C...Order resonances by increasing mass (except Z0 and W+/-).
5290 IF(KF.EQ.0) GOTO 140
5291 IF(MWID(KC).EQ.0) GOTO 140
5292 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5293 IF(MSTP(1).LE.3) GOTO 140
5295 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5296 IF(IMSS(1).LE.0) GOTO 140
5300 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5301 DO 120 I1=NRES-1,1,-1
5302 IF(PMRES.GE.PMORD(I1)) GOTO 130
5303 KCORD(I1+1)=KCORD(I1)
5304 PMORD(I1+1)=PMORD(I1)
5310 C...Loop over possible resonances.
5315 C...Check that no fourth generation channels on by mistake.
5316 IF(MSTP(1).LE.3) THEN
5317 DO 150 J=1,MDCY(KC,3)
5319 KFA1=IABS(KFDP(IDC,1))
5320 KFA2=IABS(KFDP(IDC,2))
5321 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5322 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5327 C...Check that no supersymmetric channels on by mistake.
5328 IF(IMSS(1).LE.0) THEN
5329 DO 160 J=1,MDCY(KC,3)
5331 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5332 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5333 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5338 C...Find mass and evaluate width.
5340 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5341 IF(MWID(KC).EQ.3) MINT(63)=1
5342 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5345 C...Evaluate suppression factors due to non-simulated channels.
5346 IF(KCHG(KC,3).EQ.0) THEN
5348 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5349 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5350 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5351 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5352 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5357 IF(MWID(KC).EQ.3) MINT(63)=1
5358 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5361 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5362 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5363 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5364 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5365 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5366 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5367 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5368 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5369 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5370 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5371 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5372 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5373 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5376 C...Set resonance widths and branching ratios;
5377 C...also on/off switch for decays.
5378 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5380 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5381 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5382 DO 170 J=1,MDCY(KC,3)
5385 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5390 C...Flavours of leptoquark: redefine charge and name.
5391 KFLQQ=KFDP(MDCY(42,2),1)
5392 KFLQL=KFDP(MDCY(42,2),2)
5393 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5394 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5396 IF(IABS(KFLQL).EQ.13) LL=2
5397 IF(IABS(KFLQL).EQ.15) LL=3
5398 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5399 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5400 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5402 C...Special cases in treatment of gamma*/Z0: redefine process name.
5403 IF(MSTP(43).EQ.1) THEN
5404 PROC(1)='f + fbar -> gamma*'
5405 PROC(15)='f + fbar -> g + gamma*'
5406 PROC(19)='f + fbar -> gamma + gamma*'
5407 PROC(30)='f + g -> f + gamma*'
5408 PROC(35)='f + gamma -> f + gamma*'
5409 ELSEIF(MSTP(43).EQ.2) THEN
5410 PROC(1)='f + fbar -> Z0'
5411 PROC(15)='f + fbar -> g + Z0'
5412 PROC(19)='f + fbar -> gamma + Z0'
5413 PROC(30)='f + g -> f + Z0'
5414 PROC(35)='f + gamma -> f + Z0'
5415 ELSEIF(MSTP(43).EQ.3) THEN
5416 PROC(1)='f + fbar -> gamma*/Z0'
5417 PROC(15)='f + fbar -> g + gamma*/Z0'
5418 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5419 PROC(30)='f + g -> f + gamma*/Z0'
5420 PROC(35)='f + gamma -> f + gamma*/Z0'
5423 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5424 IF(MSTP(44).EQ.1) THEN
5425 PROC(141)='f + fbar -> gamma*'
5426 ELSEIF(MSTP(44).EQ.2) THEN
5427 PROC(141)='f + fbar -> Z0'
5428 ELSEIF(MSTP(44).EQ.3) THEN
5429 PROC(141)='f + fbar -> Z''0'
5430 ELSEIF(MSTP(44).EQ.4) THEN
5431 PROC(141)='f + fbar -> gamma*/Z0'
5432 ELSEIF(MSTP(44).EQ.5) THEN
5433 PROC(141)='f + fbar -> gamma*/Z''0'
5434 ELSEIF(MSTP(44).EQ.6) THEN
5435 PROC(141)='f + fbar -> Z0/Z''0'
5436 ELSEIF(MSTP(44).EQ.7) THEN
5437 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5440 C...Special cases in treatment of WW -> WW: redefine process name.
5441 IF(MSTP(45).EQ.1) THEN
5442 PROC(77)='W+ + W+ -> W+ + W+'
5443 ELSEIF(MSTP(45).EQ.2) THEN
5444 PROC(77)='W+ + W- -> W+ + W-'
5445 ELSEIF(MSTP(45).EQ.3) THEN
5446 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5449 C...Format for error information.
5450 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5451 &'combination'/1X,'Execution stopped!')
5456 C*********************************************************************
5459 C...Identifies the two incoming particles and the choice of frame.
5461 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5463 C...Double precision and integer declarations.
5464 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5465 IMPLICIT INTEGER(I-N)
5466 INTEGER PYK,PYCHGE,PYCOMP
5468 C...User process initialization commonblock.
5470 PARAMETER (MAXPUP=100)
5471 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5472 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5473 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5474 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5479 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5480 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5481 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5482 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5483 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5484 COMMON/PYINT1/MINT(400),VINT(400)
5485 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5487 C...Local arrays, character variables and data.
5488 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5489 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5490 DIMENSION LEN(3),KCDE(39),PM(2)
5491 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5492 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5493 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5494 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5495 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5496 &'nu_taubar ','pi+ ','pi- ','n0 ',
5497 &'nbar0 ','p+ ','pbar- ','gamma ',
5498 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5499 &'xi- ','xi0 ','omega- ','pi0 ',
5500 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5501 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5502 &'k+ ','k- ','ks0 ','kl0 '/
5503 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5504 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5505 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5507 C...Store initial energy. Default frame.
5511 C...Special user process initialization; convert to normal input.
5512 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5514 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5515 CALL PYNAME(IDBMUP(1),CHNAME)
5517 CALL PYNAME(IDBMUP(2),CHNAME)
5521 C...Convert character variables to lowercase and find their length.
5528 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5530 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5536 C...Fix up bar, underscore and charge in particle name (if needed).
5538 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5540 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5543 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5545 CHIDNT(I)='nu_'//CHTEMP(3:7)
5546 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5547 CHIDNT(I)(1:3)='n0 '
5548 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5549 CHIDNT(I)(1:5)='nbar0'
5550 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5551 CHIDNT(I)(1:3)='p+ '
5552 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5553 & CHIDNT(I)(1:2).EQ.'p-') THEN
5554 CHIDNT(I)(1:5)='pbar-'
5555 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5557 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5558 CHIDNT(I)(1:7)='reggeon'
5559 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5560 CHIDNT(I)(1:7)='pomeron'
5564 C...Identify free initialization.
5565 IF(CHCOM(1)(1:2).EQ.'no') THEN
5570 C...Identify incoming beam and target particles.
5573 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5575 PM(I)=PYMASS(MINT(10+I))
5578 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5579 CHTEMP=CHIDNT(I+1)(7:12)//' '
5581 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5583 PM(I)=PYMASS(MINT(140+I))
5587 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5588 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5589 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5591 C...Identify choice of frame and input energies.
5594 C...Events defined in the CM frame.
5595 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5598 IF(MSTP(122).GE.1) THEN
5599 IF(CHCOM(2)(1:1).NE.'e') THEN
5600 LOFFS=(31-(LEN(2)+LEN(3)))/2
5601 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5602 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5605 LOFFS=(30-(LEN(2)+LEN(3)))/2
5606 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5607 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5610 WRITE(MSTU(11),5200) CHINIT
5611 WRITE(MSTU(11),5300) WIN
5614 C...Events defined in fixed target frame.
5615 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5617 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5618 IF(MSTP(122).GE.1) THEN
5619 LOFFS=(29-(LEN(2)+LEN(3)))/2
5620 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5621 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5622 & ' fixed target'//' '
5623 WRITE(MSTU(11),5200) CHINIT
5624 WRITE(MSTU(11),5400) WIN
5625 WRITE(MSTU(11),5500) SQRT(S)
5628 C...Frame defined by user three-vectors.
5629 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5633 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5634 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5635 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5636 & (P(1,3)+P(2,3))**2
5637 IF(MSTP(122).GE.1) THEN
5638 LOFFS=(22-(LEN(2)+LEN(3)))/2
5639 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5640 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5641 & ' user configuration'//' '
5642 WRITE(MSTU(11),5200) CHINIT
5643 WRITE(MSTU(11),5600)
5644 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5645 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5646 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5649 C...Frame defined by user four-vectors.
5650 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5652 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5653 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5654 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5655 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5656 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5657 & (P(1,3)+P(2,3))**2
5658 IF(MSTP(122).GE.1) THEN
5659 LOFFS=(22-(LEN(2)+LEN(3)))/2
5660 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5661 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5662 & ' user configuration'//' '
5663 WRITE(MSTU(11),5200) CHINIT
5664 WRITE(MSTU(11),5600)
5665 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5666 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5667 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5670 C...Frame defined by user five-vectors.
5671 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5673 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5674 & (P(1,3)+P(2,3))**2
5675 IF(MSTP(122).GE.1) THEN
5676 LOFFS=(22-(LEN(2)+LEN(3)))/2
5677 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5678 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5679 & ' user configuration'//' '
5680 WRITE(MSTU(11),5200) CHINIT
5681 WRITE(MSTU(11),5600)
5682 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5683 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5684 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5687 C...Frame defined by HEPRUP common block.
5688 ELSEIF(MINT(111).GE.11) THEN
5689 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5690 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5691 IF(MSTP(122).GE.1) THEN
5692 LOFFS=(22-(LEN(2)+LEN(3)))/2
5693 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5694 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5695 & ' user configuration'//' '
5696 WRITE(MSTU(11),5200) CHINIT
5697 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5698 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5701 C...Unknown frame. Error for too low CM energy.
5703 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5706 IF(S.LT.PARP(2)**2) THEN
5707 WRITE(MSTU(11),5900) SQRT(S)
5711 C...Formats for initialization and error information.
5712 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5713 &1X,'Execution stopped!')
5714 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5715 &1X,'Execution stopped!')
5716 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5717 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5718 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5719 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5720 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5721 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5722 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5723 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5724 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5725 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5726 &1X,'Execution stopped!')
5727 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5728 &'generation.'/1X,'Execution stopped!')
5729 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5730 &'GeV beam energies',13X,'I')
5735 C*********************************************************************
5738 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5740 SUBROUTINE PYINKI(MODKI)
5742 C...Double precision and integer declarations.
5743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5744 IMPLICIT INTEGER(I-N)
5745 INTEGER PYK,PYCHGE,PYCOMP
5747 C...User process initialization commonblock.
5749 PARAMETER (MAXPUP=100)
5750 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5751 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5752 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5753 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5758 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5760 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5761 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5762 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5763 COMMON/PYINT1/MINT(400),VINT(400)
5764 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5766 C...Set initial flavour state.
5771 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5774 C...Reset boost. Do kinematics for various cases.
5779 C...Set up kinematics for events defined in CM frame.
5780 IF(MINT(111).EQ.1) THEN
5782 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5786 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5787 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5792 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5795 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5796 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5798 C...Set up kinematics for fixed target events.
5799 ELSEIF(MINT(111).EQ.2) THEN
5801 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5804 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5805 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5811 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5814 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5815 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5816 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5818 C...Set up kinematics for events in user-defined frame.
5819 ELSEIF(MINT(111).EQ.3) THEN
5822 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5823 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5824 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5825 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5827 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5829 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5830 VINT(7)=PYANGL(P(1,1),P(1,2))
5831 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5832 VINT(6)=PYANGL(P(1,3),P(1,1))
5833 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5834 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5836 C...Set up kinematics for events with user-defined four-vectors.
5837 ELSEIF(MINT(111).EQ.4) THEN
5838 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5839 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5840 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5841 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5843 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5845 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5846 VINT(7)=PYANGL(P(1,1),P(1,2))
5847 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5848 VINT(6)=PYANGL(P(1,3),P(1,1))
5849 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5850 S=(P(1,4)+P(2,4))**2
5852 C...Set up kinematics for events with user-defined five-vectors.
5853 ELSEIF(MINT(111).EQ.5) THEN
5855 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5857 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5858 VINT(7)=PYANGL(P(1,1),P(1,2))
5859 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5860 VINT(6)=PYANGL(P(1,3),P(1,1))
5861 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5862 S=(P(1,4)+P(2,4))**2
5864 C...Set up kinematics for events with external user processes.
5865 ELSEIF(MINT(111).GE.11) THEN
5868 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5869 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5874 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5875 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5878 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5879 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5880 S=(P(1,4)+P(2,4))**2
5883 C...Return or error for too low CM energy.
5884 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5885 IF(MSTP(172).LE.1) THEN
5887 & '(PYINKI:) too low invariant mass in this event')
5894 C...Save information on incoming particles.
5897 IF(MINT(111).GE.4) THEN
5898 IF(MINT(141).EQ.0) THEN
5900 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5904 IF(MINT(142).EQ.0) THEN
5906 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5912 IF(MODKI.EQ.0) VINT(289)=S
5920 C...Store pT cut-off and related constants to be used in generation.
5921 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5922 IF(MSTP(82).LE.1) THEN
5923 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5925 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5927 VINT(149)=4D0*PTMN**2/S
5933 C*********************************************************************
5936 C...Selects partonic subprocesses to be included in the simulation.
5940 C...Double precision and integer declarations.
5941 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5942 IMPLICIT INTEGER(I-N)
5943 INTEGER PYK,PYCHGE,PYCOMP
5945 C...User process initialization commonblock.
5947 PARAMETER (MAXPUP=100)
5948 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5949 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5950 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5951 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5955 C...Commonblocks and character variables.
5956 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5957 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5958 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5959 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5960 COMMON/PYINT1/MINT(400),VINT(400)
5961 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5962 COMMON/PYINT6/PROC(0:500)
5964 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5968 C...Reset processes to be included.
5975 C...Set running pTmin scale.
5976 IF(MSTP(82).LE.1) THEN
5977 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5979 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5982 C...Begin by assuming incoming photon to enter subprocess.
5983 IF(MINT(11).EQ.22) MINT(15)=22
5984 IF(MINT(12).EQ.22) MINT(16)=22
5986 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5987 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5989 MINT(123)=MINT(122)+1
5991 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5993 C...Here also set a few parameters otherwise normally not touched.
5994 ELSEIF(MINT(121).GT.1) THEN
5996 C...Parton distributions dampened at small Q2; go to low energies,
5997 C...alpha_s <1; no minimum pT cut-off a priori.
5998 IF(MSTP(18).EQ.2) THEN
6006 C...Define pT cut-off parameters and whether run involves low-pT.
6010 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6012 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6013 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6015 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6016 IF(MSEL.EQ.2) IPTL=1
6018 C...Set up for p/gamma * gamma; real or virtual photons.
6019 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6020 & MSTP(14).EQ.30)) THEN
6022 C...Set up for p/VMD * VMD.
6023 IF(MINT(122).EQ.1) THEN
6031 IF(IPTL.EQ.1) MSUB(95)=1
6038 IF(IPTL.EQ.1) CKIN(3)=0D0
6040 C...Set up for p/VMD * direct gamma.
6041 ELSEIF(MINT(122).EQ.2) THEN
6043 IF(MINT(121).EQ.6) MINT(123)=5
6048 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6050 C...Set up for p/VMD * anomalous gamma.
6051 ELSEIF(MINT(122).EQ.3) THEN
6053 IF(MINT(121).EQ.6) MINT(123)=7
6060 IF(IPTL.EQ.1) MSUB(95)=1
6067 IF(IPTL.EQ.1) CKIN(3)=0D0
6069 C...Set up for DIS * p.
6070 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6071 & IABS(MINT(12)).GT.100)) THEN
6073 IF(IPTL.EQ.1) MSUB(99)=1
6075 C...Set up for direct * direct gamma (switch off leptons).
6076 ELSEIF(MINT(122).EQ.4) THEN
6082 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6083 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6085 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6087 C...Set up for direct * anomalous gamma.
6088 ELSEIF(MINT(122).EQ.5) THEN
6094 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6096 C...Set up for anomalous * anomalous gamma.
6097 ELSEIF(MINT(122).EQ.6) THEN
6105 IF(IPTL.EQ.1) MSUB(95)=1
6112 IF(IPTL.EQ.1) CKIN(3)=0D0
6115 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6116 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6118 C...Set up for direct * direct gamma (switch off leptons).
6119 IF(MINT(122).EQ.1) THEN
6125 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6126 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6128 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6130 C...Set up for direct * VMD and VMD * direct gamma.
6131 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6137 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6139 C...Set up for direct * anomalous and anomalous * direct gamma.
6140 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6146 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6148 C...Set up for VMD*VMD.
6149 ELSEIF(MINT(122).EQ.5) THEN
6157 IF(IPTL.EQ.1) MSUB(95)=1
6164 IF(IPTL.EQ.1) CKIN(3)=0D0
6166 C...Set up for VMD * anomalous and anomalous * VMD gamma.
6167 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6175 IF(IPTL.EQ.1) MSUB(95)=1
6182 IF(IPTL.EQ.1) CKIN(3)=0D0
6184 C...Set up for anomalous * anomalous gamma.
6185 ELSEIF(MINT(122).EQ.9) THEN
6193 IF(IPTL.EQ.1) MSUB(95)=1
6200 IF(IPTL.EQ.1) CKIN(3)=0D0
6202 C...Set up for DIS * VMD and VMD * DIS gamma.
6203 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6205 IF(IPTL.EQ.1) MSUB(99)=1
6207 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6208 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6210 IF(IPTL.EQ.1) MSUB(99)=1
6213 C...Set up for gamma* * p; virtual photons = dir, res.
6214 ELSEIF(MINT(121).EQ.2) THEN
6216 C...Set up for direct * p.
6217 IF(MINT(122).EQ.1) THEN
6223 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6225 C...Set up for resolved * p.
6226 ELSEIF(MINT(122).EQ.2) THEN
6234 IF(IPTL.EQ.1) MSUB(95)=1
6241 IF(IPTL.EQ.1) CKIN(3)=0D0
6244 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6245 ELSEIF(MINT(121).EQ.4) THEN
6247 C...Set up for direct * direct gamma (switch off leptons).
6248 IF(MINT(122).EQ.1) THEN
6254 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6255 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6257 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6259 C...Set up for direct * resolved and resolved * direct gamma.
6260 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6266 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6268 C...Set up for resolved * resolved gamma.
6269 ELSEIF(MINT(122).EQ.4) THEN
6277 IF(IPTL.EQ.1) MSUB(95)=1
6284 IF(IPTL.EQ.1) CKIN(3)=0D0
6287 C...End of special set up for gamma-p and gamma-gamma.
6292 C...Flavour information for individual beams.
6295 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6296 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6297 MINT(44+I)=MINT(40+I)
6298 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6299 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6302 C...If two real gammas, whereof one direct, pick the first.
6303 C...For two virtual photons, keep requested order.
6304 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6305 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6308 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6309 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6312 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6313 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6316 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6317 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6320 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6321 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6324 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6327 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6331 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6332 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6333 IF(MINT(11).EQ.22) THEN
6341 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6342 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6345 C...Flavour information on combination of incoming particles.
6346 MINT(43)=2*MINT(41)+MINT(42)-2
6348 IF(MINT(123).LE.0) THEN
6349 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6350 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6351 ELSEIF(MINT(123).LE.3) THEN
6352 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6353 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6354 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6358 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6359 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6360 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6361 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6363 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6366 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6367 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6369 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6371 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6372 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6373 & MINT(122).EQ.10) MINT(108)=2
6374 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6375 & MINT(122).EQ.11) MINT(108)=3
6376 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6377 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6378 IF(MINT(122).GE.3) MINT(107)=1
6379 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6380 ELSEIF(MINT(121).EQ.2) THEN
6381 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6382 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6384 IF(MINT(11).EQ.22) THEN
6386 IF(MINT(123).GE.4) MINT(107)=0
6387 IF(MINT(123).EQ.7) MINT(107)=2
6388 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6389 IF(MSTP(14).EQ.28) MINT(107)=2
6390 IF(MSTP(14).EQ.29) MINT(107)=3
6391 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6394 IF(MINT(12).EQ.22) THEN
6396 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6397 IF(MINT(123).EQ.7) MINT(108)=3
6398 IF(MSTP(14).EQ.26) MINT(108)=2
6399 IF(MSTP(14).EQ.27) MINT(108)=3
6400 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6401 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6404 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6405 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6411 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6412 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6414 C...Select default processes according to incoming beams
6415 C...(already done for gamma-p and gamma-gamma with
6416 C...MSTP(14) = 10, 20, 25 or 30).
6417 IF(MINT(121).GT.1) THEN
6418 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6420 IF(MINT(43).EQ.1) THEN
6421 C...Lepton + lepton -> gamma/Z0 or W.
6422 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6423 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6425 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6426 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6427 C...Unresolved photon + lepton: Compton scattering.
6431 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6432 & .OR.MINT(12).EQ.22)) THEN
6433 C...DIS as pure gamma* + f -> f process.
6436 ELSEIF(MINT(43).LE.3) THEN
6437 C...Lepton + hadron: deep inelastic scattering.
6440 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6441 & MINT(12).EQ.22) THEN
6442 C...Two unresolved photons: fermion pair production,
6443 C...exclude lepton pairs.
6447 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6448 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6451 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6452 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6453 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6455 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6456 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6457 & MINT(12).EQ.22)) THEN
6458 C...Unresolved photon + hadron: photon-parton scattering.
6463 ELSEIF(MSEL.EQ.1) THEN
6464 C...High-pT QCD processes:
6473 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6474 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6477 C...All QCD processes:
6491 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6492 C...Heavy quark production.
6496 DO 180 J=1,MIN(8,MDCY(21,3))
6497 MDME(MDCY(21,2)+J-1,1)=0
6499 MDME(MDCY(21,2)+MSEL-1,1)=1
6501 DO 190 J=1,MIN(12,MDCY(22,3))
6502 MDME(MDCY(22,2)+J-1,1)=0
6504 MDME(MDCY(22,2)+MSEL-1,1)=1
6506 ELSEIF(MSEL.EQ.10) THEN
6507 C...Prompt photon production:
6512 ELSEIF(MSEL.EQ.11) THEN
6513 C...Z0/gamma* production:
6516 ELSEIF(MSEL.EQ.12) THEN
6517 C...W+/- production:
6520 ELSEIF(MSEL.EQ.13) THEN
6525 ELSEIF(MSEL.EQ.14) THEN
6530 ELSEIF(MSEL.EQ.15) THEN
6531 C...Z0 & W+/- pair production:
6538 ELSEIF(MSEL.EQ.16) THEN
6546 ELSEIF(MSEL.EQ.17) THEN
6547 C...h0 & Z0 or W+/- pair production:
6551 ELSEIF(MSEL.EQ.18) THEN
6552 C...h0 production; interesting processes in e+e-.
6558 ELSEIF(MSEL.EQ.19) THEN
6559 C...h0, H0 and A0 production; interesting processes in e+e-.
6573 ELSEIF(MSEL.EQ.21) THEN
6577 ELSEIF(MSEL.EQ.22) THEN
6578 C...W'+/- production:
6581 ELSEIF(MSEL.EQ.23) THEN
6582 C...H+/- production:
6585 ELSEIF(MSEL.EQ.24) THEN
6589 ELSEIF(MSEL.EQ.25) THEN
6590 C...LQ (leptoquark) production.
6596 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6597 C...Production of one heavy quark (W exchange):
6599 DO 200 J=1,MIN(8,MDCY(21,3))
6600 MDME(MDCY(21,2)+J-1,1)=0
6602 MDME(MDCY(21,2)+MSEL-31,1)=1
6604 CMRENNA++Define SUSY alternatives.
6605 ELSEIF(MSEL.EQ.39) THEN
6606 C...Turn on all SUSY processes.
6607 IF(MINT(43).EQ.4) THEN
6608 C...Hadron-hadron processes.
6610 IF(ISET(I).GE.0) MSUB(I)=1
6612 ELSEIF(MINT(43).EQ.1) THEN
6613 C...Lepton-lepton processes: QED production of squarks.
6630 ELSEIF(MSEL.EQ.40) THEN
6631 C...Gluinos and squarks.
6632 IF(MINT(43).EQ.4) THEN
6644 ELSEIF(MINT(43).EQ.1) THEN
6649 ELSEIF(MSEL.EQ.41) THEN
6650 C...Stop production.
6654 IF(MINT(43).EQ.4) THEN
6659 ELSEIF(MSEL.EQ.42) THEN
6660 C...Slepton production.
6664 IF(MINT(43).NE.4) THEN
6670 ELSEIF(MSEL.EQ.43) THEN
6671 C...Neutralino/Chargino + Gluino/Squark.
6672 IF(MINT(43).EQ.4) THEN
6682 ELSEIF(MSEL.EQ.44) THEN
6683 C...Neutralino/Chargino pair production.
6684 IF(MINT(43).EQ.4) THEN
6688 ELSEIF(MINT(43).EQ.1) THEN
6694 ELSEIF(MSEL.EQ.45) THEN
6695 C...Sbottom production.
6698 IF(MINT(43).EQ.4) THEN
6704 ELSEIF(MSEL.EQ.50) THEN
6705 C...Pair production of technipions and gauge bosons.
6709 IF(MINT(43).EQ.4) THEN
6715 ELSEIF(MSEL.EQ.51) THEN
6716 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6721 ELSEIF(MSEL.EQ.61) THEN
6722 C...Charmonium production in colour octet model, with recoiling parton.
6727 ELSEIF(MSEL.EQ.62) THEN
6728 C...Bottomonium production in colour octet model, with recoiling parton.
6733 ELSEIF(MSEL.EQ.63) THEN
6734 C...Charmonium and bottomonium production in colour octet model.
6741 C...Find heaviest new quark flavour allowed in processes 81-84.
6743 DO 350 I=1,MIN(8,MDCY(21,3))
6745 IF(MDME(IDC,1).LE.0) GOTO 350
6748 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6759 C...Find heaviest new fermion flavour allowed in process 85.
6761 DO 360 I=1,MIN(12,MDCY(22,3))
6763 IF(MDME(IDC,1).LE.0) GOTO 360
6766 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6767 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6772 C...Import relevant information on external user processes.
6773 IF(MINT(111).GE.11) THEN
6776 C...Find next empty PYTHIA process number slot and enable it.
6778 IF(IPYPR.GT.500) CALL PYERRM(26,
6779 & '(PYINPR.) no more empty slots for user processes')
6780 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6781 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6783 C...Overwrite KFPR with references back to process number and ID.
6785 KFPR(IPYPR,2)=LPRUP(IUP)
6787 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6790 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6792 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6793 C...Switch on process.
6801 C*********************************************************************
6804 C...Parametrizes total, elastic and diffractive cross-sections
6805 C...for different energies and beams. Donnachie-Landshoff for
6806 C...total and Schuler-Sjostrand for elastic and diffractive.
6807 C...Process code IPROC:
6814 C...= 7 : J/psi + p;
6815 C...= 11 : rho + rho;
6816 C...= 12 : rho + phi;
6817 C...= 13 : rho + J/psi;
6818 C...= 14 : phi + phi;
6819 C...= 15 : phi + J/psi;
6820 C...= 16 : J/psi + J/psi;
6821 C...= 21 : gamma + p (DL);
6822 C...= 22 : gamma + p (VDM).
6823 C...= 23 : gamma + pi (DL);
6824 C...= 24 : gamma + pi (VDM);
6825 C...= 25 : gamma + gamma (DL);
6826 C...= 26 : gamma + gamma (VDM).
6830 C...Double precision and integer declarations.
6831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6832 IMPLICIT INTEGER(I-N)
6833 INTEGER PYK,PYCHGE,PYCOMP
6835 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6836 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6837 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6838 COMMON/PYINT1/MINT(400),VINT(400)
6839 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6840 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6841 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6843 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6844 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6845 &CEFFD(10,9),SIGTMP(6,0:5)
6847 C...Common constants.
6848 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6849 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6852 C...Number of multiple processes to be evaluated (= 0 : undefined).
6853 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6854 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6855 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6856 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6857 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6859 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6860 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6861 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6863 C...Beam and target hadron class:
6864 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6865 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6866 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6867 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6868 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6869 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6870 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6872 C...Fitting constants used in parametrizations of diffractive results.
6873 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6874 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6875 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6876 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6877 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6878 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6879 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6880 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6881 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6882 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6883 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6884 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6885 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6886 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6887 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6888 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6889 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6890 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6891 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6892 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6893 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6894 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6895 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6896 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6897 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6898 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6899 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6900 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6901 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6903 C...Parameters. Combinations of the energy.
6912 C...Ratio of gamma/pi (for rescaling in parton distributions).
6913 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6914 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6916 IF(MINT(50).NE.1) RETURN
6918 C...Order flavours of incoming particles: KF1 < KF2.
6919 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6928 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6930 C...Find process number (for lookup tables).
6931 IF(KF1.GT.1000) THEN
6933 IF(ISGN12.LT.0) IPROC=2
6934 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6936 IF(ISGN12.LT.0) IPROC=4
6937 IF(KF1.EQ.111) IPROC=5
6938 ELSEIF(KF1.GT.100) THEN
6940 ELSEIF(KF2.GT.1000) THEN
6942 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6943 ELSEIF(KF2.GT.100) THEN
6945 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6948 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6951 C... Number of multiple processes to be stored; beam/target side.
6957 ELSEIF(NPR.EQ.6) THEN
6962 IF(MINT(101).EQ.4) N1=4
6964 IF(MINT(102).EQ.4) N2=4
6966 C...Do not do any more for user-set or undefined cross-sections.
6967 IF(MSTP(31).LE.0) RETURN
6968 IF(NPR.EQ.0) CALL PYERRM(26,
6969 &'(PYXTOT:) cross section for this process not yet implemented')
6971 C...Parameters. Combinations of the energy.
6980 C...Loop over multiple processes (for VDM).
6984 ELSEIF(NPR.EQ.3) THEN
6986 IF(KF2.LT.1000) IPR=I+10
6987 ELSEIF(NPR.EQ.6) THEN
6991 C...Evaluate hadron species, mass, slope contribution and fit number.
7001 C...Skip if energy too low relative to masses.
7005 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7007 C...Total cross-section. Elastic slope parameter and cross-section.
7008 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7009 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7010 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7012 C...Diffractive scattering A + B -> X + B.
7015 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7016 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7017 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7018 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7019 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7020 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7021 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7023 C...Diffractive scattering A + B -> A + X.
7026 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7027 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7028 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7029 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7030 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7031 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7032 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7034 C...Order single diffractive correctly.
7037 SIGTMP(I,2)=SIGTMP(I,3)
7041 C...Double diffractive scattering A + B -> X1 + X2.
7042 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7043 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7044 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7045 IF(YEFF.LE.0) SUM1=0D0
7046 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7047 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7048 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7049 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7051 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7052 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7053 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7055 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7056 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7057 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7058 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7059 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7061 C...Non-diffractive by unitarity.
7062 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7066 C...Put temporary results in output array: only one process.
7067 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7069 SIGT(0,0,J)=SIGTMP(1,J)
7072 C...Beam multiple processes.
7073 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7074 IF(MINT(107).EQ.2) THEN
7075 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7077 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7078 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7080 IF(MSTP(20).GT.0) THEN
7081 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7084 IF(MINT(107).EQ.2) THEN
7085 CONV=(AEM/PARP(160+I))*VINT(317)
7086 ELSEIF(VINT(154).GT.PARP(15)) THEN
7087 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7088 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7094 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7098 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7101 C...Target multiple processes.
7102 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7103 IF(MINT(108).EQ.2) THEN
7104 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7106 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7107 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7109 IF(MSTP(20).GT.0) THEN
7110 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7113 IF(MINT(108).EQ.2) THEN
7114 CONV=(AEM/PARP(160+I))*VINT(317)
7115 ELSEIF(VINT(154).GT.PARP(15)) THEN
7116 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7117 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7123 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7127 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7130 C...Both beam and target multiple processes.
7132 IF(MINT(107).EQ.2) THEN
7133 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7135 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7136 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7138 IF(MINT(108).EQ.2) THEN
7139 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7141 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7142 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7144 IF(MSTP(20).GT.0) THEN
7145 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7146 & VINT(308)))**MSTP(20)
7150 IF(MINT(107).EQ.2) THEN
7151 CONV=(AEM/PARP(160+I1))*VINT(317)
7152 ELSEIF(VINT(154).GT.PARP(15)) THEN
7153 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7154 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7158 IF(MINT(108).EQ.2) THEN
7159 CONV=CONV*(AEM/PARP(160+I2))
7160 ELSEIF(VINT(154).GT.PARP(15)) THEN
7161 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7162 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7168 ELSEIF(I2.LE.2) THEN
7170 ELSEIF(I1.EQ.I2) THEN
7177 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7178 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7184 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7185 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7187 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7191 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7192 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7193 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7197 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7206 C*********************************************************************
7209 C...Finds optimal set of coefficients for kinematical variable selection
7210 C...and the maximum of the part of the differential cross-section used
7211 C...in the event weighting.
7215 C...Double precision and integer declarations.
7216 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7217 IMPLICIT INTEGER(I-N)
7218 INTEGER PYK,PYCHGE,PYCOMP
7219 C...Parameter statement to help give large particle numbers.
7220 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7221 &KEXCIT=4000000,KDIMEN=5000000)
7223 C...User process initialization commonblock.
7225 PARAMETER (MAXPUP=100)
7226 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7227 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7228 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7229 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7235 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7236 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7237 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7238 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7239 COMMON/PYINT1/MINT(400),VINT(400)
7240 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7241 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7242 COMMON/PYINT4/MWID(500),WIDS(500,5)
7243 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7244 COMMON/PYINT6/PROC(0:500)
7246 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7247 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7248 COMMON/PYTCCO/COEFX(194:380,2)
7249 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7250 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7251 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7253 C...Local arrays, character variables and data.
7256 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7257 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7258 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7260 DATA CVAR/'tau ','tau''','y* ','cth '/
7263 C...Initial values and loop over subprocesses.
7273 C...Find maximum weight factors for photon flux.
7274 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7275 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7278 C...Select subprocess to study: skip cases not applicable.
7279 IF(ISET(ISUB).EQ.11) THEN
7280 IF(MSUB(ISUB).NE.1) GOTO 460
7281 C...User process intialization: cross section model dependent.
7282 IF(IABS(IDWTUP).EQ.1) THEN
7283 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7284 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7285 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7287 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7288 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7289 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7290 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7291 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7292 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7294 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7295 & WTGAGA*XSEC(ISUB,1)
7298 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7299 CALL PYSIGH(NCHN,SIGS)
7301 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7302 & WTGAGA*XSEC(ISUB,1)
7303 IF(MSUB(ISUB).NE.1) GOTO 460
7306 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7307 CALL PYSIGH(NCHN,SIGS)
7309 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7310 & WTGAGA*XSEC(ISUB,1)
7311 IF(XSEC(ISUB,1).EQ.0D0) THEN
7317 ELSEIF(ISUB.EQ.96) THEN
7318 IF(MINT(50).EQ.0) GOTO 460
7319 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7321 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7322 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7323 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7324 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7325 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7326 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7328 IF(MSUB(ISUB).NE.1) GOTO 460
7331 IF(ISUB.EQ.96) ISTSB=2
7332 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7334 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7335 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7337 C...Find resonances (explicit or implicit in cross-section).
7340 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7342 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7343 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7345 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7346 & .OR.ISUB.EQ.177) THEN
7348 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7350 IF(MSTP(46).EQ.5) THEN
7353 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7357 IF(CKMX.LE.0D0) CKMX=VINT(1)
7360 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7361 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7364 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7365 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7373 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7374 $ (ISUB.GE.361.AND.ISUB.LE.380))
7377 IF(ISUB.EQ.141) THEN
7379 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7380 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7383 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7384 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7390 ELSEIF(ITECH.EQ.0) THEN
7391 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7400 C...Order the resonances
7401 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7406 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7411 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7418 SHN0=PMAS(KCR1,1)**2
7420 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7421 SHN0=PMAS(KCR2,1)**2
7423 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7424 SHN0=PMAS(KCR3,1)**2
7427 FAR=SQRT(AEM/ALPRHT)
7429 CALL PYTECM(SHN,S1,WIDO,1)
7434 CALL PYTECM(SHN,S1,WIDO,1)
7435 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7438 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7439 ELSEIF(IRES.EQ.0) THEN
7449 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7456 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7463 SHN0=PMAS(KCR1,1)**2
7465 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7466 SHN0=PMAS(KCR2,1)**2
7469 FAR=SQRT(AEM/ALPRHT)
7471 CALL PYTECM(SHN,S1,WIDO,2)
7476 CALL PYTECM(SHN,S1,WIDO,2)
7477 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7480 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7481 ELSEIF(JRES.EQ.0) THEN
7491 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7494 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7495 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7498 VINT(73)=XMAS(1)**2/VINT(2)
7499 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7507 VINT(75)=XMAS(2)**2/VINT(2)
7508 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7516 VINT(77)=XMAS(3)**2/VINT(2)
7517 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7524 C...Charged current: rho+- and a+-
7525 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7528 VINT(73)=YMAS(1)**2/VINT(2)
7529 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7537 VINT(75)=YMAS(2)**2/VINT(2)
7538 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7547 IF(ISUB.NE.141) THEN
7548 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7549 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7550 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7551 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7552 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7553 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7554 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7556 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7558 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7563 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7571 ELSEIF(KFR1.NE.0) THEN
7573 ELSEIF(KFR2.NE.0) THEN
7578 ELSEIF(KFR3.NE.0) THEN
7587 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7589 ELSEIF(KFR2.NE.0) THEN
7604 C...Find product masses and minimum pT of process.
7610 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7614 IF(KFPR(ISUB,I).EQ.0) THEN
7615 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7617 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7618 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7621 C...This prevents SUSY/t particles from becoming too light.
7623 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7626 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7627 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7628 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7629 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7630 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7631 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7632 PMMN(I)=MIN(PMMN(I),PMSUM)
7635 ELSEIF(KFLW.EQ.6) THEN
7636 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7643 CKIN(41)=MAX(PMMN(1),CKIN(41))
7644 CKIN(43)=MAX(PMMN(2),CKIN(43))
7645 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7648 IF(MINT(51).EQ.1) THEN
7649 WRITE(MSTU(11),5100) ISUB
7656 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7657 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7658 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7659 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7660 ELSEIF(ISUB.EQ.96) THEN
7661 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7667 C...Prepare for additional variable choices in 2 -> 3.
7670 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7672 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7673 VINT(204)=PMAS(23,1)
7674 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7675 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7676 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7677 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7678 & VINT(204)=VINT(201)
7680 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7683 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7685 NPTS(1)=2+2*MINT(72)
7686 IF(MINT(47).EQ.1) THEN
7687 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7688 ELSEIF(MINT(47).GE.5) THEN
7689 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7695 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7696 IF(MINT(47).GE.2) NPTS(2)=2
7697 IF(MINT(47).GE.5) NPTS(2)=3
7700 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7702 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7703 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7706 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7707 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7709 C...Reset coefficients of cross-section weighting.
7713 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7714 & .AND.ISUB.LE.380)) THEN
7731 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7732 C...in grid of phase space points.
7738 IF(METAU.EQ.1) GOTO 150
7739 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7740 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7741 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7743 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7747 C...Special case when both resonances have same mass,
7748 C...as is often the case in process 194.
7749 c IF(MINT(72).GE.2) THEN
7750 c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7751 c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7752 c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7754 c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7759 CALL PYKMAP(1,MTAU,RTAU)
7760 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7763 IF(METAUP.EQ.1) GOTO 150
7764 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7766 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7767 CALL PYKMAP(4,MTAUP,0.5D0)
7769 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7773 IF(MEYST.EQ.1) GOTO 150
7774 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7775 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7776 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7777 CALL PYKMAP(2,MYST,0.5D0)
7781 IF(MECTH.EQ.1) GOTO 150
7782 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7783 MCTH=1+MOD(ITRY-1,NPTS(4))
7784 CALL PYKMAP(3,MCTH,0.5D0)
7786 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7788 C...Store position and limits.
7791 IF(MINT(51).EQ.1) GOTO 150
7794 MVARPT(NACC,2)=MTAUP
7798 VINTPT(NACC,J)=VINT(10+J)
7801 C...Normal case: calculate cross-section.
7803 CALL PYSIGH(NCHN,SIGS)
7809 C..2 -> 3: find highest value out of a number of tries.
7812 DO 140 IKIN3=1,MSTP(129)
7813 CALL PYKMAP(5,0,0D0)
7814 IF(MINT(51).EQ.1) GOTO 140
7815 CALL PYSIGH(NCHN,SIGTMP)
7820 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7824 C...Store cross-section.
7826 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7827 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7828 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7831 WRITE(MSTU(11),5100) ISUB
7834 ELSEIF(SIGSAM.EQ.0D0) THEN
7835 WRITE(MSTU(11),5300) ISUB
7839 IF(ISUB.NE.96) NPOSI=NPOSI+1
7841 C...Calculate integrals in tau over maximal phase space limits.
7844 ATAU1=LOG(TAUMAX/TAUMIN)
7845 IF(NPTS(1).GE.2) THEN
7846 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7848 IF(NPTS(1).GE.4) THEN
7849 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7850 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7853 IF(NPTS(1).GE.6) THEN
7854 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7855 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7858 IF(NPTS(1).GE.8) THEN
7859 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7860 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7863 IF(IPEAK7.EQ.1) THEN
7864 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7867 C...Reset. Sum up cross-sections in points calculated.
7869 IF(NPTS(IVAR).EQ.1) GOTO 320
7870 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7881 IBIN=MVARPT(IACC,IVAR)
7883 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7885 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7889 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7890 NAREL(IBIN)=NAREL(IBIN)+1
7891 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7893 C...Sum up tau cross-section pieces in points used.
7896 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7897 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7899 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7900 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7901 & ((TAU-TAUR1)**2+GAMR1**2)
7904 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7905 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7906 & ((TAU-TAUR2)**2+GAMR2**2)
7908 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7909 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7910 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7911 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7912 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7913 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7915 IF(MINT(72).EQ.3) THEN
7916 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7917 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7918 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7919 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7921 C...Sum up tau' cross-section pieces in points used.
7922 ELSEIF(IVAR.EQ.2) THEN
7924 TAUP=VINTPT(IACC,16)
7925 TAUPMN=VINTPT(IACC,6)
7926 TAUPMX=VINTPT(IACC,26)
7927 ATAUP1=LOG(TAUPMX/TAUPMN)
7928 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7929 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7930 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7931 & (1D0-TAU/TAUP)**3/TAUP
7933 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7934 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7935 & TAUP/MAX(2D-10,1D0-TAUP)
7938 C...Sum up y* cross-section pieces in points used.
7939 ELSEIF(IVAR.EQ.3) THEN
7941 YSTMIN=VINTPT(IACC,2)
7942 YSTMAX=VINTPT(IACC,22)
7944 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7946 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7947 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7948 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7949 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7950 IF(MINT(45).EQ.3) THEN
7951 TAUE=VINTPT(IACC,11)
7952 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7953 YST0=-0.5D0*LOG(TAUE)
7954 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7955 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7956 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7957 & MAX(1D-10,1D0-EXP(YST-YST0))
7959 IF(MINT(46).EQ.3) THEN
7960 TAUE=VINTPT(IACC,11)
7961 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7962 YST0=-0.5D0*LOG(TAUE)
7963 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7964 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7965 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7966 & MAX(1D-10,1D0-EXP(-YST-YST0))
7969 C...Sum up cos(theta-hat) cross-section pieces in points used.
7971 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7973 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7975 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7978 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7979 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7980 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7981 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7983 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7984 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7985 & MAX(RM34,RSQM-CTH)
7986 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7987 & MAX(RM34,RSQM+CTH)
7988 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7989 & MAX(RM34,RSQM-CTH)**2
7990 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7991 & MAX(RM34,RSQM+CTH)**2
7995 C...Check that equation system solvable.
7996 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
8000 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
8001 & IRED=1,NBIN),WTREL(IBIN)
8002 IF(NAREL(IBIN).EQ.0) MSOLV=0
8003 WTRELS=WTRELS+WTREL(IBIN)
8005 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8007 C...Solve to find relative importance of cross-section pieces.
8010 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8011 WTRSAV(IBIN)=WTREL(IBIN)
8013 C...Auxiliary vectors to record order of permutations
8018 DO 230 IRED=1,NBIN-1
8020 RESMAX=ABS(WTREL(MROW))
8021 C...Find row with largest residual
8023 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8025 RESMAX=ABS(WTREL(MROW))
8028 IF(RESMAX.LT.1D-20) THEN
8033 AMAX = ABS(WTMAT(MROW,MCOL))
8034 C...Find column with largest entry
8036 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8038 AMAX = ABS(WTMAT(MROW,MCOL))
8041 C...Swap rows if necessary
8042 IF(MROW.NE.IRED) THEN
8044 TMPE=WTMAT(IRED,JBIN)
8045 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8046 WTMAT(MROW,JBIN)=TMPE
8049 WTREL(IRED)=WTREL(MROW)
8055 C...Swap columns if necessary
8056 IF(MCOL.NE.IRED) THEN
8058 TMPE=WTMAT(JBIN,IRED)
8059 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8060 WTMAT(JBIN,MCOL)=TMPE
8066 C...Begin eliminating equations
8067 DO 220 IBIN=IRED+1,NBIN
8068 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8072 C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8073 RQTU=WTMAT(IBIN,IRED)
8074 RQTL=WTMAT(IRED,IRED)
8075 C...Switch order of operations
8076 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8077 $ (WTREL(IRED)/RQTL)
8078 DO 210 ICOE=IRED,NBIN
8079 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8080 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8084 DO 250 IRED=NBIN,1,-1
8085 DO 240 ICOE=IRED+1,NBIN
8086 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8088 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8092 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8093 TEMPC(IRED)=COEFU(IRED)
8095 C...Return to original order
8098 COEFU(MTMP)=TEMPC(IBIN)
8102 C...Share evenly if failure.
8103 260 IF(MSOLV.EQ.0) THEN
8107 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8108 & WTRSAV(IBIN)/WTRELS)
8112 C...Normalize coefficients, with piece shared democratically.
8116 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8117 COEFSU=COEFSU+COEFU(IBIN)
8118 WTRELS=WTRELS+WTRELN(IBIN)
8120 IF(COEFSU.GT.0D0) THEN
8122 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8123 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8127 COEFO(IBIN)=1D0/NBIN
8130 IF(IVAR.EQ.1) IOFF=0
8131 IF(IVAR.EQ.2) IOFF=17
8132 IF(IVAR.EQ.3) IOFF=7
8133 IF(IVAR.EQ.4) IOFF=12
8137 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8141 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8142 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8143 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8145 COEF(ISUB,ICOF)=COEFO(IBIN)
8149 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8150 & (COEFO(IBIN),IBIN=1,NBIN)
8154 C...Find two most promising maxima among points previously determined.
8162 VINT(10+J)=VINTPT(IACC,J)
8165 CALL PYSIGH(NCHN,SIGS)
8172 DO 350 IKIN3=1,MSTP(129)
8173 CALL PYKMAP(5,0,0D0)
8174 IF(MINT(51).EQ.1) GOTO 350
8175 CALL PYSIGH(NCHN,SIGTMP)
8180 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8185 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8188 DO 370 IMV=NMAX,1,-1
8190 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8191 IACCMX(IMV+1)=IACCMX(IMV)
8192 SIGSMX(IMV+1)=SIGSMX(IMV)
8195 380 IACCMX(IIN)=IACC
8197 IF(NMAX.LE.1) NMAX=NMAX+1
8201 C...Read out starting position for search.
8202 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8207 MTAUP=MVARPT(IACC,2)
8215 C...Starting point and step size in parameter space.
8218 IF(NPTS(IVAR).EQ.1) GOTO 420
8219 IF(IVAR.EQ.1) VVAR=VTAU
8220 IF(IVAR.EQ.2) VVAR=VTAUP
8221 IF(IVAR.EQ.3) VVAR=VYST
8222 IF(IVAR.EQ.4) VVAR=VCTH
8223 IF(IVAR.EQ.1) MVAR=MTAU
8224 IF(IVAR.EQ.2) MVAR=MTAUP
8225 IF(IVAR.EQ.3) MVAR=MYST
8226 IF(IVAR.EQ.4) MVAR=MCTH
8227 IF(IRPT.EQ.1) VDEL=0.1D0
8228 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8230 IF(IRPT.EQ.1) VMAR=0.02D0
8231 IF(IRPT.EQ.2) VMAR=0.002D0
8233 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8236 C...Define new point in parameter space.
8240 ELSEIF(IMOV.EQ.1) THEN
8243 ELSEIF(IMOV.EQ.2) THEN
8246 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8247 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8253 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8254 & VVAR-2D0*VDEL.GT.VMAR) THEN
8260 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8274 C...Convert to relevant variables and find derived new limits.
8278 CALL PYKMAP(1,MTAU,VTAU)
8279 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8281 IF(MINT(51).EQ.1) ILERR=1
8284 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8286 IF(IVAR.EQ.2) VTAUP=VNEW
8287 CALL PYKMAP(4,MTAUP,VTAUP)
8289 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8291 IF(MINT(51).EQ.1) ILERR=1
8293 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8294 IF(IVAR.EQ.3) VYST=VNEW
8295 CALL PYKMAP(2,MYST,VYST)
8297 IF(MINT(51).EQ.1) ILERR=1
8299 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8301 IF(IVAR.EQ.4) VCTH=VNEW
8302 CALL PYKMAP(3,MCTH,VCTH)
8304 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8306 C...Evaluate cross-section. Save new maximum. Final maximum.
8309 ELSEIF(ISTSB.NE.5) THEN
8310 CALL PYSIGH(NCHN,SIGS)
8317 DO 400 IKIN3=1,MSTP(129)
8318 CALL PYKMAP(5,0,0D0)
8319 IF(MINT(51).EQ.1) GOTO 400
8320 CALL PYSIGH(NCHN,SIGTMP)
8325 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8329 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8330 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8331 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8336 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8337 XSEC(ISUB,1)=1.05D0*SIGSAM
8338 C...Add extra headroom for UED
8339 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8340 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8341 & WTGAGA*XSEC(ISUB,1)
8343 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8344 & PARP(174)*XSEC(ISUB,1)
8345 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8349 C...Print summary table.
8350 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8351 IF(MSTP(127).NE.1) THEN
8352 WRITE(MSTU(11),5900)
8355 WRITE(MSTU(11),6400)
8359 IF(MSTP(122).GE.1) THEN
8360 WRITE(MSTU(11),6000)
8361 WRITE(MSTU(11),6100)
8363 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8364 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8365 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8367 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8368 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8369 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8370 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8371 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8373 WRITE(MSTU(11),6300)
8376 C...Format statements for maximization results.
8377 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8378 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8379 &'cth',9X,'tau''',7X,'sigma')
8380 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8381 &'phase space.'/1X,'Process switched off!')
8382 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8383 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8384 &'cross-section.'/1X,'Process switched off!')
8385 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8386 5500 FORMAT(1X,1P,10D11.3)
8387 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8388 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8389 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8390 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8391 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8392 &'cross-section.'/1X,'Execution stopped!')
8393 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8394 &'cross-section maximum search',1X,8('*'))
8395 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8396 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8397 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8398 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8399 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8400 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8402 &1X,'Execution will stop if you try to generate events.')
8407 C*********************************************************************
8410 C...Initializes multiplicity distribution and selects mutliplicity
8411 C...of pileup events, i.e. several events occuring at the same
8414 SUBROUTINE PYPILE(MPILE)
8416 C...Double precision and integer declarations.
8417 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8418 IMPLICIT INTEGER(I-N)
8419 INTEGER PYK,PYCHGE,PYCOMP
8421 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8422 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8423 COMMON/PYINT1/MINT(400),VINT(400)
8424 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8425 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8426 C...Local arrays and saved variables.
8427 DIMENSION WTI(0:200)
8428 SAVE IMIN,IMAX,WTI,WTS
8430 C...Sum of allowed cross-sections for pileup events.
8432 VINT(131)=SIGT(0,0,5)
8433 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8434 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8435 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8436 IF(MSTP(133).LE.0) RETURN
8438 C...Initialize multiplicity distribution at maximum.
8439 XNAVE=VINT(131)*PARP(131)
8440 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8441 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8444 WTN=WTI(INAVE)*INAVE
8446 C...Find shape of multiplicity distribution below maximum.
8448 DO 100 I=INAVE-1,1,-1
8449 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8450 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8451 IF(WTI(I).LT.1D-6) GOTO 110
8457 C...Find shape of multiplicity distribution above maximum.
8459 DO 120 I=INAVE+1,200
8460 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8461 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8462 IF(WTI(I).LT.1D-6) GOTO 130
8469 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8470 & WTS/(WTS+WTI(1)/XNAVE)
8471 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8472 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8474 C...Pick multiplicity of pileup events.
8476 IF(MSTP(133).LE.0) THEN
8477 MINT(81)=MAX(1,MSTP(134))
8483 IF(WTR.LE.0D0) GOTO 150
8489 C...Format statement for error message.
8490 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8491 &'crossing too large, ',1P,D12.4)
8496 C*********************************************************************
8499 C...Saves and restores parameter and cross section values for the
8500 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8501 C...Also makes random choice between alternatives.
8503 SUBROUTINE PYSAVE(ISAVE,IGA)
8505 C...Double precision and integer declarations.
8506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8507 IMPLICIT INTEGER(I-N)
8508 INTEGER PYK,PYCHGE,PYCOMP
8510 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8512 COMMON/PYINT1/MINT(400),VINT(400)
8513 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8514 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8515 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8516 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8517 C...Local arrays and saved variables.
8518 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8519 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8520 &INTCP(15,20),RECP(15,20)
8521 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8523 C...Save list of subprocesses and cross-section information.
8527 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8530 MSUBCP(IGA,ICP)=MSUB(I)
8532 COEFCP(IGA,ICP,J)=COEF(I,J)
8535 NGENCP(IGA,ICP,J)=NGEN(I,J)
8536 XSECCP(IGA,ICP,J)=XSEC(I,J)
8541 NGENCP(IGA,0,J)=NGEN(0,J)
8542 XSECCP(IGA,0,J)=XSEC(0,J)
8547 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8552 C...Save various common process variables.
8554 INTCP(IGA,J)=MINT(40+J)
8556 INTCP(IGA,11)=MINT(101)
8557 INTCP(IGA,12)=MINT(102)
8558 INTCP(IGA,13)=MINT(107)
8559 INTCP(IGA,14)=MINT(108)
8560 INTCP(IGA,15)=MINT(123)
8562 RECP(IGA,2)=VINT(318)
8564 C...Save cross-section information only.
8565 ELSEIF(ISAVE.EQ.2) THEN
8566 DO 190 ICP=1,NCP(IGA)
8569 NGENCP(IGA,ICP,J)=NGEN(I,J)
8570 XSECCP(IGA,ICP,J)=XSEC(I,J)
8574 NGENCP(IGA,0,J)=NGEN(0,J)
8575 XSECCP(IGA,0,J)=XSEC(0,J)
8578 C...Choose between allowed alternatives.
8579 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8582 DO 210 IG=1,MINT(121)
8583 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8585 XSUMCP=XSUMCP*PYR(0)
8586 DO 220 IG=1,MINT(121)
8588 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8589 IF(XSUMCP.LE.0D0) GOTO 230
8594 C...Restore cross-section information.
8598 DO 270 ICP=1,NCP(IGA)
8600 MSUB(I)=MSUBCP(IGA,ICP)
8602 COEF(I,J)=COEFCP(IGA,ICP,J)
8605 NGEN(I,J)=NGENCP(IGA,ICP,J)
8606 XSEC(I,J)=XSECCP(IGA,ICP,J)
8610 NGEN(0,J)=NGENCP(IGA,0,J)
8611 XSEC(0,J)=XSECCP(IGA,0,J)
8616 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8621 C...Restore various common process variables.
8623 MINT(40+J)=INTCP(IGA,J)
8625 MINT(101)=INTCP(IGA,11)
8626 MINT(102)=INTCP(IGA,12)
8627 MINT(107)=INTCP(IGA,13)
8628 MINT(108)=INTCP(IGA,14)
8629 MINT(123)=INTCP(IGA,15)
8632 VINT(318)=RECP(IGA,2)
8634 C...Sum up cross-section info (for PYSTAT).
8635 ELSEIF(ISAVE.EQ.5) THEN
8646 DO 350 IG=1,MINT(121)
8647 DO 340 ICP=1,NCP(IG)
8649 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8650 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8651 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8652 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8654 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8655 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8656 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8657 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8664 C*********************************************************************
8667 C...For lepton beams it gives photon-hadron or photon-photon systems
8668 C...to be treated with the ordinary machinery and combines this with a
8669 C...description of the lepton -> lepton + photon branching.
8671 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8673 C...Double precision and integer declarations.
8674 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8675 IMPLICIT INTEGER(I-N)
8676 INTEGER PYK,PYCHGE,PYCOMP
8678 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8679 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8680 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8681 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8682 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8683 COMMON/PYINT1/MINT(400),VINT(400)
8684 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8685 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8687 C...Local variables and data statement.
8688 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8689 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8690 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8693 C...Initialize generation of photons inside leptons.
8696 C...Save quantities on incoming lepton system.
8700 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8702 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8703 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8704 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8706 C...Calculate range of x and Q2 values allowed in generation.
8708 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8709 IF(MINT(140+I).NE.0) THEN
8710 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8711 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8713 YMIN=MAX(CKIN(71+2*I),EPS)
8714 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8715 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8716 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8717 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8718 THEMIN=MAX(CKIN(67+2*I),0D0)
8719 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8720 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8721 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8722 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8723 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8724 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8725 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8726 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8727 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8728 C...W limits when lepton on one side only.
8729 IF(MINT(143-I).EQ.0) THEN
8730 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8731 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8732 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8737 C...W limits when lepton on both sides.
8738 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8739 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8740 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8741 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8742 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8743 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8744 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8745 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8746 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8747 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8749 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8750 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8754 C...Q2 and W values and photon flux weight factors for initialization.
8755 ELSEIF(IGAGA.EQ.2) THEN
8760 C...W value for photon on one or both sides, and for processes
8761 C...with gamma-gamma cross section peaked at small shat.
8762 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8763 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8764 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8765 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8766 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8767 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8768 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8770 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8771 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8773 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8775 C...Upper estimate of photon flux weight factor.
8776 C...Initialization Q2 scale. Flag incoming unresolved photon.
8779 IF(MINT(140+I).NE.0) THEN
8780 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8781 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8782 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8784 Q2INIT=5D0+Q2MIN(3-I)
8785 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8786 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8787 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8788 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8789 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8790 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8792 ELSEIF(ISUB.EQ.140) THEN
8797 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8798 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8800 VINT(306+I)=VINT(2+I)**2
8805 C...Update pTmin and cross section information.
8806 IF(MSTP(82).LE.1) THEN
8807 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8809 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8811 VINT(149)=4D0*PTMN**2/VINT(2)
8816 C...Generate photons inside leptons and
8817 C...calculate photon flux weight factors.
8818 ELSEIF(IGAGA.EQ.3) THEN
8823 C...Generate phase space point and check against cuts.
8827 IF(MINT(140+I).NE.0) THEN
8829 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8830 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8831 C...Cuts on internal consistency in x and Q2.
8832 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8833 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8834 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8835 C...Cuts on y and theta.
8836 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8837 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8838 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8839 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8840 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8841 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8842 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8845 C...Phi angle isotropic. Reconstruct pT.
8846 PHI(I)=PARU(2)*PYR(0)
8847 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8848 & PMS(I))*SIN(THETA(I))
8850 C...Store info on variables selected, for documentation purposes.
8851 VINT(2+I)=-SQRT(Q2(I))
8855 VINT(310+I)=THETA(I)
8866 C...Cut on W combines info from two sides.
8867 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8868 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8869 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8870 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8871 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8872 IF(W2.LT.W2MIN) GOTO 120
8873 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8876 ELSEIF(MINT(141).NE.0) THEN
8877 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8880 ELSEIF(MINT(142).NE.0) THEN
8881 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8886 C...Store kinematics info for photon(s) in subsystem cm frame.
8891 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8892 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8893 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8896 VINT(298)=-VINT(293)
8897 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8898 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8900 C...Assign weight for photon flux; different for transverse and
8901 C...longitudinal photons. Flag incoming unresolved photon.
8904 IF(MINT(140+I).NE.0) THEN
8905 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8906 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8907 IF(MSTP(16).EQ.0) THEN
8910 WTGAGA=WTGAGA*X(I)/Y(I)
8913 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8914 WTGAGA=WTGAGA*(1D0-XY)
8915 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8916 WTGAGA=WTGAGA*(1D0-XY)
8917 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8918 WTGAGA=WTGAGA*(1D0-XY)
8920 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8921 & PMS(I)*XY**2/Q2(I))
8923 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8929 C...Update pTmin and cross section information.
8930 IF(MSTP(82).LE.1) THEN
8931 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8933 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8935 VINT(149)=4D0*PTMN**2/VINT(2)
8939 C...Reconstruct kinematics of photons inside leptons.
8940 ELSEIF(IGAGA.EQ.4) THEN
8942 C...Make place for incoming particles and scattered leptons.
8944 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8945 MINT(4)=MINT(4)+MOVE
8946 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8947 IF(K(I,1).EQ.21) THEN
8953 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8954 & K(I+MOVE,3)=K(I,3)+MOVE
8955 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8956 & K(I+MOVE,4)=K(I,4)+MOVE
8957 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8958 & K(I+MOVE,5)=K(I,5)+MOVE
8961 DO 170 I=MINT(84)+1,N
8962 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8963 & K(I,3)=K(I,3)+MOVE
8966 C...Fill in incoming particles.
8967 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8976 IF(MINT(140+I).NE.0) THEN
8977 K(MINT(83)+I,2)=MINT(140+I)
8978 P(MINT(83)+I,5)=VINT(302+I)
8980 K(MINT(83)+I,2)=MINT(10+I)
8981 P(MINT(83)+I,5)=VINT(2+I)
8983 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8984 & VINT(302))*(-1D0)**(I+1)
8985 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8988 C...New mother-daughter relations in documentation section.
8989 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8990 K(MINT(83)+1,4)=MINT(83)+3
8991 K(MINT(83)+1,5)=MINT(83)+5
8992 K(MINT(83)+2,4)=MINT(83)+4
8993 K(MINT(83)+2,5)=MINT(83)+6
8994 K(MINT(83)+3,3)=MINT(83)+1
8995 K(MINT(83)+5,3)=MINT(83)+1
8996 K(MINT(83)+4,3)=MINT(83)+2
8997 K(MINT(83)+6,3)=MINT(83)+2
8998 ELSEIF(MINT(141).NE.0) THEN
8999 K(MINT(83)+1,4)=MINT(83)+3
9000 K(MINT(83)+1,5)=MINT(83)+4
9001 K(MINT(83)+2,4)=MINT(83)+5
9002 K(MINT(83)+3,3)=MINT(83)+1
9003 K(MINT(83)+4,3)=MINT(83)+1
9004 K(MINT(83)+5,3)=MINT(83)+2
9005 ELSEIF(MINT(142).NE.0) THEN
9006 K(MINT(83)+1,4)=MINT(83)+4
9007 K(MINT(83)+2,4)=MINT(83)+3
9008 K(MINT(83)+2,5)=MINT(83)+5
9009 K(MINT(83)+3,3)=MINT(83)+2
9010 K(MINT(83)+4,3)=MINT(83)+1
9011 K(MINT(83)+5,3)=MINT(83)+2
9014 C...Fill scattered lepton(s).
9016 IF(MINT(140+I).NE.0) THEN
9017 LSC=MINT(83)+MIN(I+2,MOVE)
9019 K(LSC,2)=MINT(140+I)
9020 P(LSC,1)=PT(I)*COS(PHI(I))
9021 P(LSC,2)=PT(I)*SIN(PHI(I))
9022 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9023 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9025 P(LSC,5)=VINT(302+I)
9029 C...Find incoming four-vectors to subprocess.
9031 IF(MINT(141).NE.0) THEN
9033 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9037 P(N+1,J)=P(MINT(83)+1,J)
9041 IF(MINT(142).NE.0) THEN
9043 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9047 P(N+2,J)=P(MINT(83)+2,J)
9051 C...Define boost and rotation between hadronic subsystem and
9052 C...collision rest frame; boost hadronic subsystem to this frame.
9054 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9056 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9057 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9058 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9059 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9060 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9063 C...Add on scattered leptons to final state.
9065 IF(MINT(140+I).NE.0) THEN
9066 LSC=MINT(83)+MIN(I+2,MOVE)
9082 C*********************************************************************
9085 C...Generates quantities characterizing the high-pT scattering at the
9086 C...parton level according to the matrix elements. Chooses incoming,
9087 C...reacting partons, their momentum fractions and one of the possible
9092 C...Double precision and integer declarations.
9093 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9094 IMPLICIT INTEGER(I-N)
9095 INTEGER PYK,PYCHGE,PYCOMP
9096 C...Parameter statement to help give large particle numbers.
9097 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9098 &KEXCIT=4000000,KDIMEN=5000000)
9100 C...User process initialization and event commonblocks.
9102 PARAMETER (MAXPUP=100)
9103 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9104 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9105 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9106 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9109 PARAMETER (MAXNUP=500)
9110 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9111 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9112 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9113 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9114 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9115 SAVE /HEPRUP/,/HEPEUP/
9118 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9119 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9120 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9121 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9122 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9123 COMMON/PYINT1/MINT(400),VINT(400)
9124 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9125 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9126 COMMON/PYINT4/MWID(500),WIDS(500,5)
9127 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9128 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9129 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9130 COMMON/PYTCCO/COEFX(194:380,2)
9131 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9132 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9133 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9136 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9138 C...Parameters and data used in elastic/diffractive treatment.
9139 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9140 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9142 C...Initial values, specifically for (first) semihard interaction.
9151 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9160 C...Start by assuming incoming photon is entering subprocess.
9161 IF(MINT(11).EQ.22) THEN
9163 VINT(307)=VINT(3)**2
9165 IF(MINT(12).EQ.22) THEN
9167 VINT(308)=VINT(4)**2
9172 C...Choice of process type - first event of pileup.
9174 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9175 ELSEIF(MINT(82).EQ.1) THEN
9177 C...For gamma-p or gamma-gamma first pick between alternatives.
9179 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9182 C...For real gamma + gamma with different nature, flip at random.
9183 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9184 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9194 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9197 C...Pick process type, possibly by user process machinery.
9198 C...(If the latter, also event will be picked here.)
9199 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9202 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9207 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9208 & ISUB.LT.500) GOTO 110
9210 RSUB=XSEC(0,1)*PYR(0)
9212 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9215 IF(RSUB.LE.0D0) GOTO 130
9217 130 IF(ISUB.EQ.95) ISUB=96
9218 IF(ISUB.EQ.96) INMULT=1
9219 IF(ISET(ISUB).EQ.11) THEN
9226 C...Choice of inclusive process type - pileup events.
9227 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9228 RSUB=VINT(131)*PYR(0)
9230 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9231 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9232 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9233 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9235 IF(ISUB.EQ.96) INMULT=1
9238 C...Choice of photon energy and flux factor inside lepton.
9239 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9240 CALL PYGAGA(3,WTGAGA)
9241 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9242 CKIN(3)=MAX(VINT(285),VINT(154))
9245 C...When necessary set direct/resolved photon by hand.
9246 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9247 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9248 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9251 C...Restrict direct*resolved processes to pTmin >= Q,
9252 C...to avoid doublecounting with DIS.
9253 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9254 IF(MINT(15).EQ.22) THEN
9255 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9257 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9262 C...Set up for multiple interactions (may include impact parameter).
9263 IF(INMULT.EQ.1) THEN
9264 IF(MINT(35).LE.1) CALL PYMULT(2)
9265 IF(MINT(35).GE.2) CALL PYMIGN(2)
9268 C...Loopback point for minimum bias in photon physics.
9271 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9272 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9273 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9274 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9278 C...Random choice of flavour for some SUSY processes.
9279 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9280 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9281 IF(ISUB.EQ.210) THEN
9282 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9283 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9284 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9285 ELSEIF(ISUB.EQ.213) THEN
9286 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9287 KFPR(ISUB,2)=KFPR(ISUB,1)
9288 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9289 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9291 IF(ISUB.GE.258) THEN
9296 IF(MOD(ISUB,2).EQ.0) THEN
9297 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9299 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9301 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9302 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9303 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9306 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9309 ELSEIF(PYR(0).LT.0.5D0) THEN
9316 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9317 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9318 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9319 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9320 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9321 KFPR(ISUB,2)=KFPR(ISUB,1)
9322 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9323 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9324 KFPR(ISUB,2)=KFPR(ISUB,1)
9325 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9326 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9327 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9330 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9333 ELSEIF(PYR(0).LT.0.5D0) THEN
9340 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9345 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9349 C...Random choice of flavours for some UED processes
9350 c...The production processes can generate a doublet pair,
9351 c...a singlet pair, or a doublet + singlet.
9353 C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9354 IF(PYR(0).LE.0.1)THEN
9355 KFPR(ISUB,1)=5100001
9357 KFPR(ISUB,1)=5100002
9359 KFPR(ISUB,2)=KFPR(ISUB,1)
9360 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9361 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9362 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9363 IF(PYR(0).LE.0.1)THEN
9364 KFPR(ISUB,1)=5100001
9366 KFPR(ISUB,1)=5100002
9368 KFPR(ISUB,2)=-KFPR(ISUB,1)
9369 ELSEIF(ISUB.EQ.316)THEN
9370 C...qi + qbarj -> q*_Di + q*_Sbarj
9371 IF(PYR(0).LE.0.5)THEN
9372 KFPR(ISUB,1)=5100001
9373 c Changed from private pythia6410_ued code
9374 c KFPR(ISUB,2)=-5010001
9375 KFPR(ISUB,2)=-6100002
9377 KFPR(ISUB,1)=5100002
9378 c Changed from private pythia6410_ued code
9379 c KFPR(ISUB,2)=-5010002
9380 KFPR(ISUB,2)=-6100001
9382 ELSEIF(ISUB.EQ.317)THEN
9383 C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9384 IF(PYR(0).LE.0.5)THEN
9385 KFPR(ISUB,1)=5100001
9386 KFPR(ISUB,2)=-5100002
9388 KFPR(ISUB,1)=5100002
9389 KFPR(ISUB,2)=-5100001
9391 ELSEIF(ISUB.EQ.318)THEN
9392 C...qi + qj -> q*_Di + q*_Sj
9393 IF(PYR(0).LE.0.5)THEN
9394 KFPR(ISUB,1)=5100001
9395 KFPR(ISUB,2)=6100002
9397 KFPR(ISUB,1)=5100002
9398 KFPR(ISUB,2)=6100001
9402 C...Find resonances (explicit or implicit in cross-section).
9405 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9407 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9408 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9410 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9413 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9415 IF(MSTP(46).EQ.5) THEN
9418 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9422 IF(CKMX.LE.0D0) CKMX=VINT(1)
9425 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9426 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9429 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9430 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9438 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9439 $(ISUB.GE.361.AND.ISUB.LE.380))
9442 IF(ISUB.EQ.141) THEN
9444 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9445 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9448 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9449 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9455 C...3 resonances at work: rho, omega, a
9456 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9457 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9460 VINT(73)=XMAS(1)**2/VINT(2)
9461 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9467 VINT(75)=XMAS(2)**2/VINT(2)
9468 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9474 VINT(77)=XMAS(3)**2/VINT(2)
9475 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9480 C...Charged current: rho+- and a+-
9481 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9484 VINT(73)=YMAS(1)**2/VINT(2)
9485 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9491 VINT(75)=YMAS(2)**2/VINT(2)
9492 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9499 IF(ISUB.NE.141) THEN
9500 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9502 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9504 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9509 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9517 ELSEIF(KFR1.NE.0) THEN
9519 ELSEIF(KFR2.NE.0) THEN
9524 ELSEIF(KFR3.NE.0) THEN
9533 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9535 ELSEIF(KFR2.NE.0) THEN
9550 C...Find product masses and minimum pT of process,
9551 C...optionally with broadening according to a truncated Breit-Wigner.
9556 IF(MINT(82).GE.2) VINT(71)=0D0
9558 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9562 IF(KFPR(ISUB,I).EQ.0) THEN
9563 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9565 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9568 C...This prevents SUSY/t particles from becoming too light.
9570 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9573 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9574 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9575 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9576 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9577 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9578 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9579 PMMN(I)=MIN(PMMN(I),PMSUM)
9582 ELSEIF(KFLW.EQ.6) THEN
9583 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9590 CKIN(41)=MAX(PMMN(1),CKIN(41))
9591 CKIN(43)=MAX(PMMN(2),CKIN(43))
9592 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9595 IF(MINT(51).EQ.1) THEN
9596 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9606 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9607 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9610 C...Prepare for additional variable choices in 2 -> 3.
9613 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9615 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9616 VINT(204)=PMAS(23,1)
9617 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9618 & VINT(204)=PMAS(24,1)
9619 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9620 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9621 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9622 & VINT(204)=VINT(201)
9624 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9627 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9628 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9629 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9630 VRN=PYR(0)*SIGT(0,0,5)
9631 IF(MINT(101).LE.1) THEN
9638 IF(MINT(102).LE.1) THEN
9649 VRN=VRN-SIGT(I1,I2,5)
9650 IF(VRN.LE.0D0) GOTO 190
9653 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9654 IF(MINT(102).GE.2) MINT(104)=KFV2
9658 C...Elastic scattering or single or double diffractive scattering.
9660 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9665 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9667 VRN=PYR(0)*SIGT(0,0,JJ)
9668 IF(MINT(101).LE.1) THEN
9675 IF(MINT(102).LE.1) THEN
9686 VRN=VRN-SIGT(I1,I2,JJ)
9687 IF(VRN.LE.0D0) GOTO 220
9690 220 IF(MINT(101).GE.2) THEN
9694 IF(MINT(102).GE.2) THEN
9702 C...Select mass for GVMD states (rejecting previous assignment).
9704 Q1S=4D0*VINT(154)**2
9708 IF(MINT(106+JT).EQ.3) THEN
9710 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9711 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9712 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9713 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9716 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9717 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9722 C...Side/sides of diffractive system.
9725 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9726 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9728 C...Find masses of particles and minimal masses of diffractive states.
9731 VINT(68+JT)=PDIF(JT)
9732 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9739 SMRES1=(PMM(1)+PMRC)**2
9740 SMRES2=(PMM(2)+PMRC)**2
9742 C...Find elastic slope and lower limit diffractive slope.
9743 IHA=MAX(2,IABS(MINT(103))/110)
9745 IHB=MAX(2,IABS(MINT(104))/110)
9748 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9749 ELSEIF(ISUB.EQ.92) THEN
9750 BMN=MAX(2D0,2D0*BHAD(IHB))
9751 ELSEIF(ISUB.EQ.93) THEN
9752 BMN=MAX(2D0,2D0*BHAD(IHA))
9753 ELSEIF(ISUB.EQ.94) THEN
9757 C...Determine maximum possible t range and coefficient of generation.
9758 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9759 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9760 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9761 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9762 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9763 & (SQM1*SQM4-SQM2*SQM3)/SH
9764 THL=-0.5D0*(THA+THB)
9766 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9768 C...Select diffractive mass/masses according to dm^2/m^2.
9772 IF(MINT(16+JT).EQ.0) THEN
9776 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9777 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9783 C..Additional mass factors, including resonance enhancement.
9784 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9785 IF(LOOP3.LT.100) GOTO 260
9789 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9790 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9791 ELSEIF(ISUB.EQ.93) THEN
9792 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9793 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9794 ELSEIF(ISUB.EQ.94) THEN
9795 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9796 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9797 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9798 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9801 C...Select t according to exp(Bmn*t) and correct to right slope.
9802 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9805 BADD=2D0*ALP*LOG(SH/SQM3)
9806 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9807 ELSEIF(ISUB.EQ.93) THEN
9808 BADD=2D0*ALP*LOG(SH/SQM4)
9809 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9810 ELSEIF(ISUB.EQ.94) THEN
9811 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9813 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9816 C...Check whether m^2 and t choices are consistent.
9817 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9818 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9819 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9820 IF(THB.LE.1D-8) GOTO 260
9821 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9822 & (SQM1*SQM4-SQM2*SQM3)/SH
9823 THLM=-0.5D0*(THA+THB)
9825 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9827 C...Information to output.
9830 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9832 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9835 VINT(283)=PMM(1)**2/4D0
9836 VINT(284)=PMM(2)**2/4D0
9838 C...Note: in the following, by In is meant the integral over the
9839 C...quantity multiplying coefficient cn.
9840 C...Choose tau according to h1(tau)/tau, where
9841 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9842 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9843 C...I1/I5*c5*1/(tau+tau_R') +
9844 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9845 C...I1/I7*c7*tau/(1.-tau), and
9846 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9847 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9849 IF(MINT(51).NE.0) THEN
9850 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9859 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9860 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9861 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9862 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9864 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9865 & COEF(ISUB,5)) MTAU=6
9866 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9867 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9868 C...Additional check to handle techni-processes with extra resonance
9869 C....Only modify tau treatment
9870 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9872 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9873 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9874 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9875 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9876 & +COEFX(ISUB,1)) MTAU=9
9878 CALL PYKMAP(1,MTAU,PYR(0))
9880 C...2 -> 3, 4 processes:
9881 C...Choose tau' according to h4(tau,tau')/tau', where
9882 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9883 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9884 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9886 IF(MINT(51).NE.0) THEN
9887 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9896 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9897 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9898 CALL PYKMAP(4,MTAUP,PYR(0))
9901 C...Choose y* according to h2(y*), where
9902 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9903 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9904 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9905 C...and c1 + c2 + c3 + c4 + c5 = 1.
9907 IF(MINT(51).NE.0) THEN
9908 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9917 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9918 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9919 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9920 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9921 & COEF(ISUB,11)) MYST=5
9922 CALL PYKMAP(2,MYST,PYR(0))
9924 C...2 -> 2 processes:
9925 C...Choose cos(theta-hat) (cth) according to h3(cth), where
9926 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9927 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9928 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9929 C...and c0 + c1 + c2 + c3 + c4 = 1.
9931 IF(MINT(51).NE.0) THEN
9932 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9939 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9942 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9943 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9944 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9945 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9946 & COEF(ISUB,16)) MCTH=5
9947 CALL PYKMAP(3,MCTH,PYR(0))
9950 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9952 CALL PYKMAP(5,0,0D0)
9953 IF(MINT(51).NE.0) THEN
9954 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9963 C...DIS as f + gamma* -> f process: set dummy values.
9964 ELSEIF(ISTSB.EQ.8) THEN
9971 C...Low-pT or multiple interactions (first semihard interaction).
9972 ELSEIF(ISTSB.EQ.9) THEN
9973 IF(MINT(35).LE.1) CALL PYMULT(3)
9974 IF(MINT(35).GE.2) CALL PYMIGN(3)
9977 C...Study user-defined process: kinematics plus weight.
9978 ELSEIF(ISTSB.EQ.11) THEN
9979 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9980 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9985 IF(MINT(82).EQ.1) THEN
9986 NGEN(0,1)=NGEN(0,1)-1
9987 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9989 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9993 C...Extract cross section event weight.
9994 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9997 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9999 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
10000 VINT(97)=SIGN(1D0,XWGTUP)
10002 VINT(97)=1D-9*XWGTUP
10005 C...Construct 'trivial' kinematical variables needed.
10008 VINT(41)=PUP(4,1)/EBMUP(1)
10009 VINT(42)=PUP(4,2)/EBMUP(2)
10010 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10011 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10012 & '(listing follows):')
10015 VINT(21)=VINT(41)*VINT(42)
10016 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10017 VINT(44)=VINT(21)*VINT(2)
10018 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10020 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10021 VINT(56)=VINT(55)**2
10025 C...Construct other kinematical variables needed (approximately).
10028 VINT(45)=-0.5D0*VINT(44)
10029 VINT(46)=-0.5D0*VINT(44)
10038 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10039 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10041 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10042 & '(PYRAND:) unacceptable ISTUP code for particles')
10043 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10044 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10045 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10048 VINT(47)=SQRT(VINT(48))
10051 C...Choose azimuthal angle.
10053 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10055 C...Check against user cuts on kinematics at parton level.
10057 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10058 IF(MINT(51).NE.0) THEN
10059 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10060 IF(MFAIL.EQ.1) THEN
10066 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10068 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10069 & CALL PYKCUT(MCUT)
10071 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10072 IF(MFAIL.EQ.1) THEN
10080 IF(ISTSB.LE.10) THEN
10081 C... If internal process, call PYSIGH
10082 CALL PYSIGH(NCHN,SIGS)
10084 C... If external process, still have to set MI starting scale
10085 IF (MSTP(86).EQ.1) THEN
10086 C... Limit phase space by xT2 of hard interaction
10087 C... (gives undercounting of MI when ext proc != dijets)
10090 C... All accessible phase space allowed
10091 C... (gives double counting of MI when ext proc = dijets)
10092 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10094 VINT(62)=0.25D0*XT2GMX*VINT(2)
10095 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10099 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10101 C...Multiply cross section by lepton -> photon flux factor.
10102 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10105 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10107 SIGLPT=WTGAGA*SIGLPT
10110 C...Multiply cross-section by user-defined weights.
10111 IF(MSTP(173).EQ.1) THEN
10112 SIGS=PARP(173)*SIGS
10114 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10116 SIGLPT=PARP(173)*SIGLPT
10122 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10123 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10124 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10127 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10130 C...Calculations for Monte Carlo estimate of all cross-sections.
10131 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10132 IF(MSTP(142).LE.1) THEN
10133 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10135 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10137 ELSEIF(MINT(82).EQ.1) THEN
10138 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10140 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10141 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10143 C...Multiple interactions: store results of cross-section calculation.
10144 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10146 IF(MINT(35).LE.1) CALL PYMULT(4)
10147 IF(MINT(35).GE.2) CALL PYMIGN(4)
10150 C...Ratio of actual to maximum cross section.
10151 IF(ISTSB.NE.11) THEN
10152 VIOL=SIGSWT/XSEC(ISUB,1)
10153 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10154 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10155 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10156 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10157 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10162 C...Check that weight not negative.
10163 IF(MSTP(123).LE.0) THEN
10164 IF(VIOL.LT.-1D-3) THEN
10165 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10166 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10167 & VINT(22),VINT(23),VINT(26)
10171 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10173 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10174 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10175 & VINT(22),VINT(23),VINT(26)
10179 C...Weighting using estimate of maximum of differential cross-section.
10181 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10182 IF(VIOL.LT.PYR(0)) THEN
10183 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10184 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10187 ELSEIF(MFAIL.EQ.0) THEN
10188 RATND=SIGLPT/XSEC(95,1)
10190 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10191 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10192 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10193 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10197 IF(VIOL.LT.PYR(0)) THEN
10200 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10201 IF(VIOL.LT.PYR(0)) THEN
10203 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10207 RATND=SIGLPT/XSEC(95,1)
10208 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10210 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10214 IF(VIOL.LT.PYR(0)) THEN
10215 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10220 C...Check for possible violation of estimated maximum of differential
10221 C...cross-section used in weighting.
10222 IF(MSTP(123).LE.0) THEN
10223 IF(VIOL.GT.1D0) THEN
10224 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10225 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10226 & VINT(22),VINT(23),VINT(26)
10229 ELSEIF(MSTP(123).EQ.1) THEN
10230 IF(VIOL.GT.VINT(108)) THEN
10232 IF(VIOL.GT.1.0001D0) THEN
10234 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10235 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10236 & VINT(22),VINT(23),VINT(26)
10239 ELSEIF(VIOL.GT.VINT(108)) THEN
10241 IF(VIOL.GT.1D0) THEN
10243 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10244 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10246 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10247 IF(KFPR(ISUB,1).LE.9) THEN
10248 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10249 & XMAXUP(KFPR(ISUB,1))
10250 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10251 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10252 & XMAXUP(KFPR(ISUB,1))
10254 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10255 & XMAXUP(KFPR(ISUB,1))
10258 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10259 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10260 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10261 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10262 & XSEC(0,1)=XSEC(0,1)+XDIF
10263 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10264 & VINT(22),VINT(23),VINT(26)
10266 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10267 ELSEIF(ISUB.LE.99) THEN
10268 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10270 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10277 C...Multiple interactions: choose impact parameter (if not already done).
10278 IF(MINT(39).EQ.0) VINT(148)=1D0
10279 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10280 &MSTP(82).GE.3) THEN
10281 IF(MINT(35).LE.1) CALL PYMULT(5)
10282 IF(MINT(35).GE.2) CALL PYMIGN(5)
10283 IF(VINT(150).LT.PYR(0)) THEN
10284 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10285 IF(MFAIL.EQ.1) THEN
10292 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10293 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10294 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10295 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10297 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10299 C...Choose flavour of reacting partons (and subprocess).
10300 IF(ISTSB.GE.11) GOTO 320
10303 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10304 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10305 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10306 &PYR(0).GT.RQQBAR)) THEN
10310 MINT(2)=ISIG(ICHN,3)
10311 RSIGS=RSIGS-SIGH(ICHN)
10312 IF(RSIGS.LE.0D0) GOTO 320
10315 C...Multiple interactions: choose qqbar preferentially at small pT.
10316 ELSEIF(ISUB.EQ.96) THEN
10317 MINT(105)=MINT(103)
10318 MINT(109)=MINT(107)
10319 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10320 MINT(105)=MINT(104)
10321 MINT(109)=MINT(108)
10322 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10325 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10327 C...Low-pT: choose string drawing configuration.
10333 IF(RSIGS.GT.1D0) MINT(2)=2
10334 IF(RSIGS.GT.2D0) MINT(2)=3
10337 C...Reassign QCD process. Partons before initial state radiation.
10338 320 IF(MINT(2).GT.10) THEN
10340 MINT(2)=MOD(MINT(2),10)
10342 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10353 C...Calculate x value of photon for parton inside photon inside e.
10358 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10359 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10360 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10361 IF(MSPLI.EQ.2) THEN
10365 MINT(105)=MINT(102+JT)
10366 MINT(109)=MINT(106+JT)
10367 VINT(120)=VINT(2+JT)
10369 C.... Store side in MINT(124)
10372 IF(MSTP(57).LE.1) THEN
10373 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10375 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10378 IF(MSTP(13).EQ.2) THEN
10379 Q2PMS=Q2HRD/PMAS(11,1)**2
10380 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10382 330 XE=XHRD**PYR(0)
10383 XG=MIN(1D0-1D-10,XHRD/XE)
10384 IF(MSTP(57).LE.1) THEN
10385 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10387 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10389 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10390 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10391 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10395 XSFX(JT,KFLS)=XPQ(KFLS)
10400 C...Pick scale where photon is resolved.
10404 IF(MINT(107).EQ.3) THEN
10405 IF(MSTP(66).EQ.1) THEN
10406 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10407 ELSEIF(MSTP(66).EQ.2) THEN
10409 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10410 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10411 Q2INT=SQRT(Q0S*Q2EFF)
10412 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10413 ELSEIF(MSTP(66).EQ.3) THEN
10414 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10415 ELSEIF(MSTP(66).GE.4) THEN
10416 PS=0.25D0*VINT(3)**2
10417 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10418 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10422 IF(MINT(108).EQ.3) THEN
10423 IF(MSTP(66).EQ.1) THEN
10424 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10425 ELSEIF(MSTP(66).EQ.2) THEN
10427 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10428 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10429 Q2INT=SQRT(Q0S*Q2EFF)
10430 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10431 ELSEIF(MSTP(66).EQ.3) THEN
10432 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10433 ELSEIF(MSTP(66).GE.4) THEN
10434 PS=0.25D0*VINT(4)**2
10435 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10436 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10439 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10441 C...Format statements for differential cross-section maximum violations.
10442 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10443 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10444 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10445 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10446 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10448 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10449 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10450 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10452 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10453 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10454 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10455 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10456 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10457 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10462 C*********************************************************************
10465 C...Finds outgoing flavours and event type; sets up the kinematics
10466 C...and colour flow of the hard scattering
10470 C...Double precision and integer declarations
10471 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10472 IMPLICIT INTEGER(I-N)
10473 INTEGER PYK,PYCHGE,PYCOMP
10474 C...Parameter statement to help give large particle numbers.
10475 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10476 &KEXCIT=4000000,KDIMEN=5000000)
10477 C...Parameter statement for maximum size of showers.
10478 PARAMETER (MAXNUR=1000)
10480 C...User process event common block.
10482 PARAMETER (MAXNUP=500)
10483 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10484 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10485 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10486 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10487 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10491 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10492 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10493 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10494 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10495 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10496 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10497 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10498 COMMON/PYINT1/MINT(400),VINT(400)
10499 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10500 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10501 COMMON/PYINT4/MWID(500),WIDS(500,5)
10502 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10503 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10504 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10505 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10506 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10507 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10508 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10510 C...Local arrays and saved variables
10511 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10512 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10513 INTEGER IOKFLA(6),IIFLAV
10514 C...UED related declarations:
10515 C...equivalences between ordered particles (451->475)
10516 C...and UED particle code (5 000 000 + id)
10517 DIMENSION IUEDEQ(475),MUED(2)
10518 DATA (IUEDEQ(I),I=451,475)/
10519 & 6100001,6100002,6100003,6100004,6100005,6100006,
10520 & 5100001,5100002,5100003,5100004,5100005,5100006,
10521 & 6100011,6100013,6100015,
10522 & 5100012,5100011,5100014,5100013,5100016,5100015,
10523 & 5100021,5100022,5100023,5100024/
10526 C...Read out process
10530 C...Restore information for low-pT processes
10531 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10533 100 VINT(J)=VINTSV(J)
10536 C...Convert H' or A process into equivalent H one
10539 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10540 &ISUB.LE.190)) THEN
10542 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10544 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10545 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10546 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10547 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10548 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10549 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10550 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10551 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10552 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10553 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10554 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10555 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10558 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10560 C...Convert bottomonium process into equivalent charmonium ones.
10561 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10563 C...Choice of subprocess, number of documentation lines
10565 IF(ISUB.EQ.95) IDOC=8
10566 IF(ISET(ISUB).EQ.5) IDOC=9
10567 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10569 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10578 C...Reset K, P and V vectors. Store incoming particles
10579 DO 120 JT=1,MSTP(126)+100
10581 IF(I.GT.MSTU(4)) GOTO 120
10593 P(I,J)=VINT(285+5*JT+J)
10599 C...Store incoming partons in their CM-frame. Save pdf value.
10602 SHP=VINT(26)*VINT(2)
10605 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10610 K(I,3)=MINT(83)+2+JT
10611 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10612 P(I,4)=0.5D0*SHUSER
10613 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10614 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10620 C...Copy incoming partons to documentation lines
10632 C...Choose new quark/lepton flavour for relevant annihilation graphs
10633 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10634 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10635 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10637 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10638 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10639 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10640 DO 190 I=1,MDCY(IGLGA,3)
10641 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10642 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10643 IF(RKFL.LE.0D0) GOTO 200
10646 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10647 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10648 IF(KFLF.GE.4) GOTO 180
10649 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10650 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10653 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10654 & OR.ISUB.EQ.316) THEN
10657 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10658 & .AND.IABS(KFLF).GE.3) THEN
10659 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10661 FACCIB=VINT(46)**2/RTCM(41)**4
10662 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10663 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10666 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10667 IF(KFLF.EQ.5) GOTO 180
10668 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10669 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10670 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10671 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10675 C...Final state flavours and colour flow: default values
10682 KCS=ISIGN(1,MINT(15))
10684 IF(ISET(ISUB).EQ.11) THEN
10685 C...User-defined processes: find products
10688 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10689 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10690 MINT(21+IUP)=IDUP(IUP)
10691 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10692 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10693 ELSEIF(IDUP(IUP).EQ.0) THEN
10696 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10700 ELSEIF(ISUB.LE.10) THEN
10702 C...f + fbar -> gamma*/Z0
10705 ELSEIF(ISUB.EQ.2) THEN
10706 C...f + fbar' -> W+/-
10707 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10708 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10709 KFRES=ISIGN(24,KCH1+KCH2)
10711 ELSEIF(ISUB.EQ.3) THEN
10712 C...f + fbar -> h0 (or H0, or A0)
10715 ELSEIF(ISUB.EQ.4) THEN
10716 C...gamma + W+/- -> W+/-
10718 ELSEIF(ISUB.EQ.5) THEN
10723 PMQ(1)=PYMASS(MINT(21))
10724 PMQ(2)=PYMASS(MINT(22))
10725 220 JT=INT(1.5D0+PYR(0))
10726 ZMIN=2D0*PMQ(JT)/SHPR
10727 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10728 & (SHPR*(SHPR-PMQ(3-JT)))
10729 ZMAX=MIN(1D0-XH,ZMAX)
10730 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10731 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10732 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10733 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10734 IF(SQC1.LT.1D-8) GOTO 220
10736 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10737 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10738 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10739 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10740 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10741 IF(SQC1.LT.1D-8) GOTO 220
10743 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10744 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10745 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10746 PHIR=PARU(2)*PYR(0)
10748 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10749 & SQRT(1D0-CTHE(2)**2)*CPHI
10751 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10752 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10753 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10754 & PMQ(3-JT)**2/SHP))
10755 ZMIN=2D0*PMQ(3-JT)/SHPR
10756 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10757 ZMAX=MIN(1D0-XH,ZMAX)
10758 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10762 ELSEIF(ISUB.EQ.6) THEN
10763 C...Z0 + W+/- -> W+/-
10765 ELSEIF(ISUB.EQ.7) THEN
10768 ELSEIF(ISUB.EQ.8) THEN
10775 RVCKM=VINT(180+I)*PYR(0)
10778 IPM=(5-ISIGN(1,I))/2
10780 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10781 MINT(20+JT)=ISIGN(IB,I)
10782 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10783 IF(RVCKM.LE.0D0) GOTO 250
10786 IB=2*((IA+1)/2)-1+MOD(IA,2)
10787 MINT(20+JT)=ISIGN(IB,I)
10789 250 PMQ(JT)=PYMASS(MINT(20+JT))
10791 JT=INT(1.5D0+PYR(0))
10792 ZMIN=2D0*PMQ(JT)/SHPR
10793 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10794 & (SHPR*(SHPR-PMQ(3-JT)))
10795 ZMAX=MIN(1D0-XH,ZMAX)
10796 IF(ZMIN.GE.ZMAX) GOTO 230
10797 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10798 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10799 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10800 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10801 IF(SQC1.LT.1D-8) GOTO 230
10803 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10804 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10805 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10806 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10807 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10808 IF(SQC1.LT.1D-8) GOTO 230
10810 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10811 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10812 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10813 PHIR=PARU(2)*PYR(0)
10815 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10816 & SQRT(1D0-CTHE(2)**2)*CPHI
10818 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10819 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10820 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10821 & PMQ(3-JT)**2/SHP))
10822 ZMIN=2D0*PMQ(3-JT)/SHPR
10823 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10824 ZMAX=MIN(1D0-XH,ZMAX)
10825 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10829 ELSEIF(ISUB.EQ.10) THEN
10830 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10831 IF(MINT(2).EQ.1) THEN
10834 C...W exchange: need to mix flavours according to CKM matrix
10839 RVCKM=VINT(180+I)*PYR(0)
10842 IPM=(5-ISIGN(1,I))/2
10844 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10845 MINT(20+JT)=ISIGN(IB,I)
10846 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10847 IF(RVCKM.LE.0D0) GOTO 280
10850 IB=2*((IA+1)/2)-1+MOD(IA,2)
10851 MINT(20+JT)=ISIGN(IB,I)
10858 ELSEIF(ISUB.LE.20) THEN
10859 IF(ISUB.EQ.11) THEN
10860 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10862 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10864 ELSEIF(ISUB.EQ.12) THEN
10865 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10866 MINT(21)=ISIGN(KFLF,MINT(15))
10870 ELSEIF(ISUB.EQ.13) THEN
10871 C...f + fbar -> g + g; th arbitrary
10876 ELSEIF(ISUB.EQ.14) THEN
10877 C...f + fbar -> g + gamma; th arbitrary
10878 IF(PYR(0).GT.0.5D0) JS=2
10883 ELSEIF(ISUB.EQ.15) THEN
10884 C...f + fbar -> g + Z0; th arbitrary
10885 IF(PYR(0).GT.0.5D0) JS=2
10890 ELSEIF(ISUB.EQ.16) THEN
10891 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10892 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10893 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10894 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10896 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10899 ELSEIF(ISUB.EQ.17) THEN
10900 C...f + fbar -> g + h0; th arbitrary
10901 IF(PYR(0).GT.0.5D0) JS=2
10906 ELSEIF(ISUB.EQ.18) THEN
10907 C...f + fbar -> gamma + gamma; th arbitrary
10911 ELSEIF(ISUB.EQ.19) THEN
10912 C...f + fbar -> gamma + Z0; th arbitrary
10913 IF(PYR(0).GT.0.5D0) JS=2
10917 ELSEIF(ISUB.EQ.20) THEN
10918 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10919 C...(p(fbar')-p(W+))**2
10920 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10921 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10922 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10924 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10927 ELSEIF(ISUB.LE.30) THEN
10928 IF(ISUB.EQ.21) THEN
10929 C...f + fbar -> gamma + h0; th arbitrary
10930 IF(PYR(0).GT.0.5D0) JS=2
10934 ELSEIF(ISUB.EQ.22) THEN
10935 C...f + fbar -> Z0 + Z0; th arbitrary
10939 ELSEIF(ISUB.EQ.23) THEN
10940 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10941 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10942 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10943 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10945 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10947 ELSEIF(ISUB.EQ.24) THEN
10948 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10949 IF(PYR(0).GT.0.5D0) JS=2
10953 ELSEIF(ISUB.EQ.25) THEN
10954 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10955 MINT(21)=-ISIGN(24,MINT(15))
10958 ELSEIF(ISUB.EQ.26) THEN
10959 C...f + fbar' -> W+/- + h0 (or H0, or A0);
10960 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10961 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10962 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10963 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10964 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10967 ELSEIF(ISUB.EQ.27) THEN
10968 C...f + fbar -> h0 + h0
10970 ELSEIF(ISUB.EQ.28) THEN
10971 C...f + g -> f + g; th = (p(f)-p(f))**2
10972 IF(MINT(15).EQ.21) JS=2
10974 IF(MINT(15).EQ.21) KCC=KCC+2
10975 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10976 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10978 ELSEIF(ISUB.EQ.29) THEN
10979 C...f + g -> f + gamma; th = (p(f)-p(f))**2
10980 IF(MINT(15).EQ.21) JS=2
10983 KCS=ISIGN(1,MINT(14+JS))
10985 ELSEIF(ISUB.EQ.30) THEN
10986 C...f + g -> f + Z0; th = (p(f)-p(f))**2
10987 IF(MINT(15).EQ.21) JS=2
10990 KCS=ISIGN(1,MINT(14+JS))
10993 ELSEIF(ISUB.LE.40) THEN
10994 IF(ISUB.EQ.31) THEN
10995 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10996 IF(MINT(15).EQ.21) JS=2
10999 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11000 RVCKM=VINT(180+I)*PYR(0)
11003 IPM=(5-ISIGN(1,I))/2
11005 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11006 MINT(20+JS)=ISIGN(IB,I)
11007 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11008 IF(RVCKM.LE.0D0) GOTO 300
11011 KCS=ISIGN(1,MINT(14+JS))
11013 ELSEIF(ISUB.EQ.32) THEN
11014 C...f + g -> f + h0; th = (p(f)-p(f))**2
11015 IF(MINT(15).EQ.21) JS=2
11018 KCS=ISIGN(1,MINT(14+JS))
11020 ELSEIF(ISUB.EQ.33) THEN
11021 C...f + gamma -> f + g; th=(p(f)-p(f))**2
11022 IF(MINT(15).EQ.22) JS=2
11025 KCS=ISIGN(1,MINT(14+JS))
11027 ELSEIF(ISUB.EQ.34) THEN
11028 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11029 IF(MINT(15).EQ.22) JS=2
11031 KCS=ISIGN(1,MINT(14+JS))
11033 ELSEIF(ISUB.EQ.35) THEN
11034 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11035 IF(MINT(15).EQ.22) JS=2
11039 ELSEIF(ISUB.EQ.36) THEN
11040 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11041 IF(MINT(15).EQ.22) JS=2
11044 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11046 RVCKM=VINT(180+I)*PYR(0)
11049 IPM=(5-ISIGN(1,I))/2
11051 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11052 MINT(20+JS)=ISIGN(IB,I)
11053 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11054 IF(RVCKM.LE.0D0) GOTO 320
11057 IB=2*((IA+1)/2)-1+MOD(IA,2)
11058 MINT(20+JS)=ISIGN(IB,I)
11062 ELSEIF(ISUB.EQ.37) THEN
11063 C...f + gamma -> f + h0
11065 ELSEIF(ISUB.EQ.38) THEN
11066 C...f + Z0 -> f + g
11068 ELSEIF(ISUB.EQ.39) THEN
11069 C...f + Z0 -> f + gamma
11071 ELSEIF(ISUB.EQ.40) THEN
11072 C...f + Z0 -> f + Z0
11075 ELSEIF(ISUB.LE.50) THEN
11076 IF(ISUB.EQ.41) THEN
11077 C...f + Z0 -> f' + W+/-
11079 ELSEIF(ISUB.EQ.42) THEN
11080 C...f + Z0 -> f + h0
11082 ELSEIF(ISUB.EQ.43) THEN
11083 C...f + W+/- -> f' + g
11085 ELSEIF(ISUB.EQ.44) THEN
11086 C...f + W+/- -> f' + gamma
11088 ELSEIF(ISUB.EQ.45) THEN
11089 C...f + W+/- -> f' + Z0
11091 ELSEIF(ISUB.EQ.46) THEN
11092 C...f + W+/- -> f' + W+/-
11094 ELSEIF(ISUB.EQ.47) THEN
11095 C...f + W+/- -> f' + h0
11097 ELSEIF(ISUB.EQ.48) THEN
11098 C...f + h0 -> f + g
11100 ELSEIF(ISUB.EQ.49) THEN
11101 C...f + h0 -> f + gamma
11103 ELSEIF(ISUB.EQ.50) THEN
11104 C...f + h0 -> f + Z0
11107 ELSEIF(ISUB.LE.60) THEN
11108 IF(ISUB.EQ.51) THEN
11109 C...f + h0 -> f' + W+/-
11111 ELSEIF(ISUB.EQ.52) THEN
11112 C...f + h0 -> f + h0
11114 ELSEIF(ISUB.EQ.53) THEN
11115 C...g + g -> f + fbar; th arbitrary
11116 KCS=(-1)**INT(1.5D0+PYR(0))
11117 MINT(21)=ISIGN(KFLF,KCS)
11121 ELSEIF(ISUB.EQ.54) THEN
11122 C...g + gamma -> f + fbar; th arbitrary
11123 KCS=(-1)**INT(1.5D0+PYR(0))
11124 MINT(21)=ISIGN(KFLF,KCS)
11127 IF(MINT(16).EQ.21) KCC=28
11129 ELSEIF(ISUB.EQ.55) THEN
11130 C...g + Z0 -> f + fbar
11132 ELSEIF(ISUB.EQ.56) THEN
11133 C...g + W+/- -> f + fbar'
11135 ELSEIF(ISUB.EQ.57) THEN
11136 C...g + h0 -> f + fbar
11138 ELSEIF(ISUB.EQ.58) THEN
11139 C...gamma + gamma -> f + fbar; th arbitrary
11140 KCS=(-1)**INT(1.5D0+PYR(0))
11141 MINT(21)=ISIGN(KFLF,KCS)
11145 ELSEIF(ISUB.EQ.59) THEN
11146 C...gamma + Z0 -> f + fbar
11148 ELSEIF(ISUB.EQ.60) THEN
11149 C...gamma + W+/- -> f + fbar'
11152 ELSEIF(ISUB.LE.70) THEN
11153 IF(ISUB.EQ.61) THEN
11154 C...gamma + h0 -> f + fbar
11156 ELSEIF(ISUB.EQ.62) THEN
11157 C...Z0 + Z0 -> f + fbar
11159 ELSEIF(ISUB.EQ.63) THEN
11160 C...Z0 + W+/- -> f + fbar'
11162 ELSEIF(ISUB.EQ.64) THEN
11163 C...Z0 + h0 -> f + fbar
11165 ELSEIF(ISUB.EQ.65) THEN
11166 C...W+ + W- -> f + fbar
11168 ELSEIF(ISUB.EQ.66) THEN
11169 C...W+/- + h0 -> f + fbar'
11171 ELSEIF(ISUB.EQ.67) THEN
11172 C...h0 + h0 -> f + fbar
11174 ELSEIF(ISUB.EQ.68) THEN
11175 C...g + g -> g + g; th arbitrary
11177 KCS=(-1)**INT(1.5D0+PYR(0))
11179 ELSEIF(ISUB.EQ.69) THEN
11180 C...gamma + gamma -> W+ + W-; th arbitrary
11185 ELSEIF(ISUB.EQ.70) THEN
11186 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11187 IF(MINT(15).EQ.22) MINT(21)=23
11188 IF(MINT(16).EQ.22) MINT(22)=23
11192 ELSEIF(ISUB.LE.80) THEN
11193 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11194 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11198 PMQ(1)=PYMASS(MINT(21))
11199 PMQ(2)=PYMASS(MINT(22))
11200 330 JT=INT(1.5D0+PYR(0))
11201 ZMIN=2D0*PMQ(JT)/SHPR
11202 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11203 & (SHPR*(SHPR-PMQ(3-JT)))
11204 ZMAX=MIN(1D0-XH,ZMAX)
11205 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11206 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11207 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11208 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11209 IF(SQC1.LT.1D-8) GOTO 330
11211 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11212 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11213 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11214 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11215 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11216 IF(SQC1.LT.1D-8) GOTO 330
11218 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11219 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11220 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11221 PHIR=PARU(2)*PYR(0)
11223 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11224 & SQRT(1D0-CTHE(2)**2)*CPHI
11226 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11227 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11228 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11229 & PMQ(3-JT)**2/SHP))
11230 ZMIN=2D0*PMQ(3-JT)/SHPR
11231 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11232 ZMAX=MIN(1D0-XH,ZMAX)
11233 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11236 ELSEIF(ISUB.EQ.73) THEN
11237 C...Z0 + W+/- -> Z0 + W+/-
11244 RVCKM=VINT(180+I)*PYR(0)
11247 IPM=(5-ISIGN(1,I))/2
11249 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11250 MINT(20+JT)=ISIGN(IB,I)
11251 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11252 IF(RVCKM.LE.0D0) GOTO 360
11255 IB=2*((IA+1)/2)-1+MOD(IA,2)
11256 MINT(20+JT)=ISIGN(IB,I)
11258 360 PMQ(JT)=PYMASS(MINT(20+JT))
11259 MINT(23-JT)=MINT(17-JT)
11260 PMQ(3-JT)=PYMASS(MINT(23-JT))
11261 JT=INT(1.5D0+PYR(0))
11262 ZMIN=2D0*PMQ(JT)/SHPR
11263 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11264 & (SHPR*(SHPR-PMQ(3-JT)))
11265 ZMAX=MIN(1D0-XH,ZMAX)
11266 IF(ZMIN.GE.ZMAX) GOTO 340
11267 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11268 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11269 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11270 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11271 IF(SQC1.LT.1D-8) GOTO 340
11273 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11274 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11275 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11276 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11277 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11278 IF(SQC1.LT.1D-8) GOTO 340
11280 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11281 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11282 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11283 PHIR=PARU(2)*PYR(0)
11285 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11286 & SQRT(1D0-CTHE(2)**2)*CPHI
11288 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11289 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11290 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11291 & PMQ(3-JT)**2/SHP))
11292 ZMIN=2D0*PMQ(3-JT)/SHPR
11293 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11294 ZMAX=MIN(1D0-XH,ZMAX)
11295 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11298 ELSEIF(ISUB.EQ.74) THEN
11299 C...Z0 + h0 -> Z0 + h0
11301 ELSEIF(ISUB.EQ.75) THEN
11302 C...W+ + W- -> gamma + gamma
11304 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11305 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11311 RVCKM=VINT(180+I)*PYR(0)
11314 IPM=(5-ISIGN(1,I))/2
11316 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11317 MINT(20+JT)=ISIGN(IB,I)
11318 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11319 IF(RVCKM.LE.0D0) GOTO 390
11322 IB=2*((IA+1)/2)-1+MOD(IA,2)
11323 MINT(20+JT)=ISIGN(IB,I)
11325 390 PMQ(JT)=PYMASS(MINT(20+JT))
11327 JT=INT(1.5D0+PYR(0))
11328 ZMIN=2D0*PMQ(JT)/SHPR
11329 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11330 & (SHPR*(SHPR-PMQ(3-JT)))
11331 ZMAX=MIN(1D0-XH,ZMAX)
11332 IF(ZMIN.GE.ZMAX) GOTO 370
11333 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11334 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11335 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11336 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11337 IF(SQC1.LT.1D-8) GOTO 370
11339 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11340 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11341 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11342 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11343 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11344 IF(SQC1.LT.1D-8) GOTO 370
11346 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11347 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11348 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11349 PHIR=PARU(2)*PYR(0)
11351 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11352 & SQRT(1D0-CTHE(2)**2)*CPHI
11354 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11355 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11356 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11357 & PMQ(3-JT)**2/SHP))
11358 ZMIN=2D0*PMQ(3-JT)/SHPR
11359 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11360 ZMAX=MIN(1D0-XH,ZMAX)
11361 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11364 ELSEIF(ISUB.EQ.78) THEN
11365 C...W+/- + h0 -> W+/- + h0
11367 ELSEIF(ISUB.EQ.79) THEN
11368 C...h0 + h0 -> h0 + h0
11370 ELSEIF(ISUB.EQ.80) THEN
11371 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11372 IF(MINT(15).EQ.22) JS=2
11375 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11377 MINT(20+JS)=ISIGN(IB,I)
11381 ELSEIF(ISUB.LE.90) THEN
11382 IF(ISUB.EQ.81) THEN
11383 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11384 MINT(21)=ISIGN(MINT(55),MINT(15))
11388 ELSEIF(ISUB.EQ.82) THEN
11389 C...g + g -> Q + Qbar; th arbitrary
11390 KCS=(-1)**INT(1.5D0+PYR(0))
11391 MINT(21)=ISIGN(MINT(55),KCS)
11395 ELSEIF(ISUB.EQ.83) THEN
11396 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11398 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11400 IF(KFAOLD.GT.10) THEN
11401 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11403 RCKM=VINT(180+KFOLD)*PYR(0)
11404 IPM=(5-ISIGN(1,KFOLD))/2
11405 KFANEW=-MOD(KFAOLD+1,2)
11406 410 KFANEW=KFANEW+2
11407 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11408 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11409 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11410 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11411 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11412 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11414 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11416 IF(MINT(2).EQ.1) THEN
11417 MINT(21)=ISIGN(MINT(55),MINT(15))
11418 MINT(22)=ISIGN(KFANEW,MINT(16))
11420 MINT(21)=ISIGN(KFANEW,MINT(15))
11421 MINT(22)=ISIGN(MINT(55),MINT(16))
11426 ELSEIF(ISUB.EQ.84) THEN
11427 C...g + gamma -> Q + Qbar; th arbitary
11428 KCS=(-1)**INT(1.5D0+PYR(0))
11429 MINT(21)=ISIGN(MINT(55),KCS)
11432 IF(MINT(16).EQ.21) KCC=28
11434 ELSEIF(ISUB.EQ.85) THEN
11435 C...gamma + gamma -> F + Fbar; th arbitary
11436 KCS=(-1)**INT(1.5D0+PYR(0))
11437 MINT(21)=ISIGN(MINT(56),KCS)
11441 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11442 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11443 MINT(21)=KFPR(ISUB,1)
11444 MINT(22)=KFPR(ISUB,2)
11446 KCS=(-1)**INT(1.5D0+PYR(0))
11449 ELSEIF(ISUB.LE.100) THEN
11450 IF(ISUB.EQ.95) THEN
11451 C...Low-pT ( = energyless g + g -> g + g)
11453 KCS=(-1)**INT(1.5D0+PYR(0))
11455 ELSEIF(ISUB.EQ.96) THEN
11456 C...Multiple interactions (should be reassigned to QCD process)
11459 ELSEIF(ISUB.LE.110) THEN
11460 IF(ISUB.EQ.101) THEN
11461 C...g + g -> gamma*/Z0
11465 ELSEIF(ISUB.EQ.102) THEN
11466 C...g + g -> h0 (or H0, or A0)
11470 ELSEIF(ISUB.EQ.103) THEN
11471 C...gamma + gamma -> h0 (or H0, or A0)
11475 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11476 C...g + g -> chi_0c or chi_2c.
11480 ELSEIF(ISUB.EQ.106) THEN
11481 C...g + g -> J/Psi + gamma
11482 MINT(21)=KFPR(ISUB,1)
11483 MINT(22)=KFPR(ISUB,2)
11486 ELSEIF(ISUB.EQ.107) THEN
11487 C...g + gamma -> J/Psi + g
11488 MINT(21)=KFPR(ISUB,1)
11489 MINT(22)=KFPR(ISUB,2)
11491 IF(MINT(16).EQ.22) KCC=33
11493 ELSEIF(ISUB.EQ.108) THEN
11494 C...gamma + gamma -> J/Psi + gamma
11495 MINT(21)=KFPR(ISUB,1)
11496 MINT(22)=KFPR(ISUB,2)
11498 ELSEIF(ISUB.EQ.110) THEN
11499 C...f + fbar -> gamma + h0; th arbitrary
11500 IF(PYR(0).GT.0.5D0) JS=2
11505 ELSEIF(ISUB.LE.120) THEN
11506 IF(ISUB.EQ.111) THEN
11507 C...f + fbar -> g + h0; th arbitrary
11508 IF(PYR(0).GT.0.5D0) JS=2
11513 ELSEIF(ISUB.EQ.112) THEN
11514 C...f + g -> f + h0; th = (p(f) - p(f))**2
11515 IF(MINT(15).EQ.21) JS=2
11518 KCS=ISIGN(1,MINT(14+JS))
11520 ELSEIF(ISUB.EQ.113) THEN
11521 C...g + g -> g + h0; th arbitrary
11522 IF(PYR(0).GT.0.5D0) JS=2
11525 KCS=(-1)**INT(1.5D0+PYR(0))
11527 ELSEIF(ISUB.EQ.114) THEN
11528 C...g + g -> gamma + gamma; th arbitrary
11529 IF(PYR(0).GT.0.5D0) JS=2
11534 ELSEIF(ISUB.EQ.115) THEN
11535 C...g + g -> g + gamma; th arbitrary
11536 IF(PYR(0).GT.0.5D0) JS=2
11539 KCS=(-1)**INT(1.5D0+PYR(0))
11541 ELSEIF(ISUB.EQ.116) THEN
11542 C...g + g -> gamma + Z0
11544 ELSEIF(ISUB.EQ.117) THEN
11545 C...g + g -> Z0 + Z0
11547 ELSEIF(ISUB.EQ.118) THEN
11548 C...g + g -> W+ + W-
11551 ELSEIF(ISUB.LE.140) THEN
11552 IF(ISUB.EQ.121) THEN
11553 C...g + g -> Q + Qbar + h0
11554 KCS=(-1)**INT(1.5D0+PYR(0))
11555 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11557 KCC=11+INT(0.5D0+PYR(0))
11560 ELSEIF(ISUB.EQ.122) THEN
11561 C...q + qbar -> Q + Qbar + h0
11562 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11567 ELSEIF(ISUB.EQ.123) THEN
11568 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11573 ELSEIF(ISUB.EQ.124) THEN
11574 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11580 RVCKM=VINT(180+I)*PYR(0)
11583 IPM=(5-ISIGN(1,I))/2
11585 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11586 MINT(20+JT)=ISIGN(IB,I)
11587 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11588 IF(RVCKM.LE.0D0) GOTO 430
11591 IB=2*((IA+1)/2)-1+MOD(IA,2)
11592 MINT(20+JT)=ISIGN(IB,I)
11598 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11599 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11600 IF(MINT(15).EQ.22) JS=2
11603 KCS=ISIGN(1,MINT(14+JS))
11605 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11606 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11607 IF(MINT(15).EQ.22) JS=2
11609 KCS=ISIGN(1,MINT(14+JS))
11611 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11612 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11613 KCS=(-1)**INT(1.5D0+PYR(0))
11614 MINT(21)=ISIGN(KFLF,KCS)
11617 IF(MINT(16).EQ.21) KCC=28
11619 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11620 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11621 KCS=(-1)**INT(1.5D0+PYR(0))
11622 MINT(21)=ISIGN(KFLF,KCS)
11628 ELSEIF(ISUB.LE.160) THEN
11629 IF(ISUB.EQ.141) THEN
11630 C...f + fbar -> gamma*/Z0/Z'0
11633 ELSEIF(ISUB.EQ.142) THEN
11634 C...f + fbar' -> W'+/-
11635 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11636 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11637 KFRES=ISIGN(34,KCH1+KCH2)
11639 ELSEIF(ISUB.EQ.143) THEN
11640 C...f + fbar' -> H+/-
11641 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11642 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11643 KFRES=ISIGN(37,KCH1+KCH2)
11645 ELSEIF(ISUB.EQ.144) THEN
11647 KFRES=ISIGN(41,MINT(15)+MINT(16))
11649 ELSEIF(ISUB.EQ.145) THEN
11650 C...q + l -> LQ (leptoquark)
11651 IF(IABS(MINT(16)).LE.8) JS=2
11652 KFRES=ISIGN(42,MINT(14+JS))
11654 KCS=ISIGN(1,MINT(14+JS))
11656 ELSEIF(ISUB.EQ.146) THEN
11657 C...e + gamma -> e* (excited lepton)
11658 IF(MINT(15).EQ.22) JS=2
11659 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11662 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11663 C...q + g -> q* (excited quark)
11664 IF(MINT(15).EQ.21) JS=2
11665 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11667 KCS=ISIGN(1,MINT(14+JS))
11669 ELSEIF(ISUB.EQ.149) THEN
11670 C...g + g -> eta_tc
11673 KCS=(-1)**INT(1.5D0+PYR(0))
11676 ELSEIF(ISUB.LE.200) THEN
11677 IF(ISUB.EQ.161) THEN
11678 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11679 IF(MINT(15).EQ.21) JS=2
11682 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11683 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11684 MINT(20+JS)=ISIGN(IB,I)
11686 KCS=ISIGN(1,MINT(14+JS))
11688 ELSEIF(ISUB.EQ.162) THEN
11689 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11690 IF(MINT(15).EQ.21) JS=2
11691 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11692 KFLQL=KFDP(MDCY(42,2),2)
11693 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11695 KCS=ISIGN(1,MINT(14+JS))
11697 ELSEIF(ISUB.EQ.163) THEN
11698 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11699 KCS=(-1)**INT(1.5D0+PYR(0))
11700 MINT(21)=ISIGN(42,KCS)
11704 ELSEIF(ISUB.EQ.164) THEN
11705 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11706 MINT(21)=ISIGN(42,MINT(15))
11710 ELSEIF(ISUB.EQ.165) THEN
11711 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11712 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11715 ELSEIF(ISUB.EQ.166) THEN
11716 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11717 IF(MOD(MINT(15),2).EQ.0) THEN
11718 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11719 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11721 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11722 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11725 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11726 C...q + q' -> q" + q* (excited quark)
11727 KFQSTR=KFPR(ISUB,2)
11728 KFQEXC=MOD(KFQSTR,KEXCIT)
11730 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11731 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11732 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11736 ELSEIF(ISUB.EQ.169) THEN
11737 C...q + qbar -> e + e* (excited lepton)
11738 KFQSTR=KFPR(ISUB,2)
11739 KFQEXC=MOD(KFQSTR,KEXCIT)
11741 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11742 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11745 ELSEIF(ISUB.EQ.191) THEN
11746 C...f + fbar -> rho_tc0.
11749 ELSEIF(ISUB.EQ.192) THEN
11750 C...f + fbar' -> rho_tc+/-
11751 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11752 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11753 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11755 ELSEIF(ISUB.EQ.193) THEN
11756 C...f + fbar -> omega_tc0.
11759 ELSEIF(ISUB.EQ.194) THEN
11760 C...f + fbar -> f' + fbar' via mixture of s-channel
11761 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11762 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11765 ELSEIF(ISUB.EQ.195) THEN
11766 C...f + fbar' -> f'' + fbar''' via s-channel
11767 C...rho_tc+ th=(p(f)-p(f'))**2
11768 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11769 IF(MOD(MINT(15),2).EQ.0) THEN
11770 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11771 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11773 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11774 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11779 ELSEIF(ISUB.LE.215) THEN
11780 IF(ISUB.EQ.201) THEN
11781 C...f + fbar -> ~e_L + ~e_Lbar
11782 MINT(21)=ISIGN(KSUSY1+11,KCS)
11785 ELSEIF(ISUB.EQ.202) THEN
11786 C...f + fbar -> ~e_R + ~e_Rbar
11787 MINT(21)=ISIGN(KSUSY2+11,KCS)
11790 ELSEIF(ISUB.EQ.203) THEN
11791 C...f + fbar -> ~e_L + ~e_Rbar
11792 IF(MINT(15).LT.0) JS=2
11793 IF(MINT(2).EQ.1) THEN
11794 MINT(20+JS)=KFPR(ISUB,1)
11795 MINT(23-JS)=-KFPR(ISUB,2)
11797 MINT(20+JS)=-KFPR(ISUB,1)
11798 MINT(23-JS)=KFPR(ISUB,2)
11801 ELSEIF(ISUB.EQ.204) THEN
11802 C...f + fbar -> ~mu_L + ~mu_Lbar
11803 MINT(21)=ISIGN(KSUSY1+13,KCS)
11806 ELSEIF(ISUB.EQ.205) THEN
11807 C...f + fbar -> ~mu_R + ~mu_Rbar
11808 MINT(21)=ISIGN(KSUSY2+13,KCS)
11811 ELSEIF(ISUB.EQ.206) THEN
11812 C...f + fbar -> ~mu_L + ~mu_Rbar
11813 IF(MINT(15).LT.0) JS=2
11814 IF(MINT(2).EQ.1) THEN
11815 MINT(20+JS)=KFPR(ISUB,1)
11816 MINT(23-JS)=-KFPR(ISUB,2)
11818 MINT(20+JS)=-KFPR(ISUB,1)
11819 MINT(23-JS)=KFPR(ISUB,2)
11822 ELSEIF(ISUB.EQ.207) THEN
11823 C...f + fbar -> ~tau_1 + ~tau_1bar
11824 MINT(21)=ISIGN(KSUSY1+15,KCS)
11827 ELSEIF(ISUB.EQ.208) THEN
11828 C...f + fbar -> ~tau_2 + ~tau_2bar
11829 MINT(21)=ISIGN(KSUSY2+15,KCS)
11832 ELSEIF(ISUB.EQ.209) THEN
11833 C...f + fbar -> ~tau_1 + ~tau_2bar
11834 IF(MINT(15).LT.0) JS=2
11835 IF(MINT(2).EQ.1) THEN
11836 MINT(20+JS)=KFPR(ISUB,1)
11837 MINT(23-JS)=-KFPR(ISUB,2)
11839 MINT(20+JS)=-KFPR(ISUB,1)
11840 MINT(23-JS)=KFPR(ISUB,2)
11843 ELSEIF(ISUB.EQ.210) THEN
11844 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11845 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11846 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11847 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11848 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11850 ELSEIF(ISUB.EQ.211) THEN
11851 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11852 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11853 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11854 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11855 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11857 ELSEIF(ISUB.EQ.212) THEN
11858 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11859 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11860 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11861 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11862 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11864 ELSEIF(ISUB.EQ.213) THEN
11865 C...f + fbar -> ~nul + ~nulbar
11866 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11869 ELSEIF(ISUB.EQ.214) THEN
11870 C...f + fbar -> ~nutau + ~nutaubar
11871 MINT(21)=ISIGN(KSUSY1+16,KCS)
11875 ELSEIF(ISUB.LE.225) THEN
11876 IF(ISUB.EQ.216) THEN
11877 C...f + fbar -> ~chi01 + ~chi01
11881 ELSEIF(ISUB.EQ.217) THEN
11882 C...f + fbar -> ~chi02 + ~chi02
11886 ELSEIF(ISUB.EQ.218 ) THEN
11887 C...f + fbar -> ~chi03 + ~chi03
11891 ELSEIF(ISUB.EQ.219 ) THEN
11892 C...f + fbar -> ~chi04 + ~chi04
11896 ELSEIF(ISUB.EQ.220 ) THEN
11897 C...f + fbar -> ~chi01 + ~chi02
11898 IF(MINT(15).LT.0) JS=2
11899 C IF(PYR(0).GT.0.5D0) JS=2
11900 MINT(20+JS)=KSUSY1+22
11901 MINT(23-JS)=KSUSY1+23
11903 ELSEIF(ISUB.EQ.221 ) THEN
11904 C...f + fbar -> ~chi01 + ~chi03
11905 IF(MINT(15).LT.0) JS=2
11906 C IF(PYR(0).GT.0.5D0) JS=2
11907 MINT(20+JS)=KSUSY1+22
11908 MINT(23-JS)=KSUSY1+25
11910 ELSEIF(ISUB.EQ.222) THEN
11911 C...f + fbar -> ~chi01 + ~chi04
11912 IF(MINT(15).LT.0) JS=2
11913 C IF(PYR(0).GT.0.5D0) JS=2
11914 MINT(20+JS)=KSUSY1+22
11915 MINT(23-JS)=KSUSY1+35
11917 ELSEIF(ISUB.EQ.223) THEN
11918 C...f + fbar -> ~chi02 + ~chi03
11919 IF(MINT(15).LT.0) JS=2
11920 C IF(PYR(0).GT.0.5D0) JS=2
11921 MINT(20+JS)=KSUSY1+23
11922 MINT(23-JS)=KSUSY1+25
11924 ELSEIF(ISUB.EQ.224) THEN
11925 C...f + fbar -> ~chi02 + ~chi04
11926 IF(MINT(15).LT.0) JS=2
11927 C IF(PYR(0).GT.0.5D0) JS=2
11928 MINT(20+JS)=KSUSY1+23
11929 MINT(23-JS)=KSUSY1+35
11931 ELSEIF(ISUB.EQ.225) THEN
11932 C...f + fbar -> ~chi03 + ~chi04
11933 IF(MINT(15).LT.0) JS=2
11934 C IF(PYR(0).GT.0.5D0) JS=2
11935 MINT(20+JS)=KSUSY1+25
11936 MINT(23-JS)=KSUSY1+35
11939 ELSEIF(ISUB.LE.236) THEN
11940 IF(ISUB.EQ.226) THEN
11941 C...f + fbar -> ~chi+-1 + ~chi-+1
11942 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11943 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11944 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11947 ELSEIF(ISUB.EQ.227) THEN
11948 C...f + fbar -> ~chi+-2 + ~chi-+2
11949 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11950 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11953 ELSEIF(ISUB.EQ.228) THEN
11954 C...f + fbar -> ~chi+-1 + ~chi-+2
11955 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11956 C...js=1 if pyr<.5, js=2 if pyr>.5
11957 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11958 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11959 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11960 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11961 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11963 IF(MINT(2).EQ.1) THEN
11964 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11965 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11966 c IF(KCH2.EQ.0) JS=2
11968 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11969 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11971 c IF(KCH2.EQ.1) JS=2
11974 ELSEIF(ISUB.EQ.229) THEN
11975 C...q + qbar' -> ~chi01 + ~chi+-1
11976 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11977 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11978 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11980 IF(MOD(MINT(15),2).EQ.0) JS=2
11981 MINT(20+JS)=KSUSY1+22
11982 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11984 ELSEIF(ISUB.EQ.230) THEN
11985 C...q + qbar' -> ~chi02 + ~chi+-1
11986 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11987 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11988 IF(MOD(MINT(15),2).EQ.0) JS=2
11989 MINT(20+JS)=KSUSY1+23
11990 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11992 ELSEIF(ISUB.EQ.231) THEN
11993 C...q + qbar' -> ~chi03 + ~chi+-1
11994 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11995 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11996 IF(MOD(MINT(15),2).EQ.0) JS=2
11997 MINT(20+JS)=KSUSY1+25
11998 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12000 ELSEIF(ISUB.EQ.232) THEN
12001 C...q + qbar' -> ~chi04 + ~chi+-1
12002 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12003 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12004 IF(MOD(MINT(15),2).EQ.0) JS=2
12005 MINT(20+JS)=KSUSY1+35
12006 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12008 ELSEIF(ISUB.EQ.233) THEN
12009 C...q + qbar' -> ~chi01 + ~chi+-2
12010 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12011 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12012 IF(MOD(MINT(15),2).EQ.0) JS=2
12013 MINT(20+JS)=KSUSY1+22
12014 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12016 ELSEIF(ISUB.EQ.234) THEN
12017 C...q + qbar' -> ~chi02 + ~chi+-2
12018 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12019 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12020 IF(MOD(MINT(15),2).EQ.0) JS=2
12021 MINT(20+JS)=KSUSY1+23
12022 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12024 ELSEIF(ISUB.EQ.235) THEN
12025 C...q + qbar' -> ~chi03 + ~chi+-2
12026 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12027 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12028 IF(MOD(MINT(15),2).EQ.0) JS=2
12029 MINT(20+JS)=KSUSY1+25
12030 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12032 ELSEIF(ISUB.EQ.236) THEN
12033 C...q + qbar' -> ~chi04 + ~chi+-2
12034 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12035 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12036 IF(MOD(MINT(15),2).EQ.0) JS=2
12037 MINT(20+JS)=KSUSY1+35
12038 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12041 ELSEIF(ISUB.LE.245) THEN
12042 IF(ISUB.EQ.237) THEN
12043 C...q + qbar -> ~chi01 + ~g
12045 IF(PYR(0).GT.0.5D0) JS=2
12046 MINT(20+JS)=KSUSY1+21
12047 MINT(23-JS)=KSUSY1+22
12050 ELSEIF(ISUB.EQ.238) THEN
12051 C...q + qbar -> ~chi02 + ~g
12053 IF(PYR(0).GT.0.5D0) JS=2
12054 MINT(20+JS)=KSUSY1+21
12055 MINT(23-JS)=KSUSY1+23
12058 ELSEIF(ISUB.EQ.239) THEN
12059 C...q + qbar -> ~chi03 + ~g
12061 IF(PYR(0).GT.0.5D0) JS=2
12062 MINT(20+JS)=KSUSY1+21
12063 MINT(23-JS)=KSUSY1+25
12066 ELSEIF(ISUB.EQ.240) THEN
12067 C...q + qbar -> ~chi04 + ~g
12069 IF(PYR(0).GT.0.5D0) JS=2
12070 MINT(20+JS)=KSUSY1+21
12071 MINT(23-JS)=KSUSY1+35
12074 ELSEIF(ISUB.EQ.241) THEN
12075 C...q + qbar' -> ~chi+-1 + ~g
12076 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12077 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12078 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12079 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12080 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12081 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12082 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12084 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12085 MINT(20+JS)=KSUSY1+21
12086 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12089 ELSEIF(ISUB.EQ.242) THEN
12090 C...q + qbar' -> ~chi+-2 + ~g
12091 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12092 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12093 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12094 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12095 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12096 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12097 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12099 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12100 MINT(20+JS)=KSUSY1+21
12101 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12104 ELSEIF(ISUB.EQ.243) THEN
12105 C...q + qbar -> ~g + ~g ; th arbitrary
12110 ELSEIF(ISUB.EQ.244) THEN
12111 C...g + g -> ~g + ~g ; th arbitrary
12113 KCS=(-1)**INT(1.5D0+PYR(0))
12118 ELSEIF(ISUB.LE.260) THEN
12119 IF(ISUB.EQ.246) THEN
12120 C...qj + g -> ~qj_L + ~chi01
12121 IF(MINT(15).EQ.21) JS=2
12124 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12125 MINT(23-JS)=KSUSY1+22
12127 KCS=ISIGN(1,MINT(14+JS))
12129 ELSEIF(ISUB.EQ.247) THEN
12130 C...qj + g -> ~qj_R + ~chi01
12131 IF(MINT(15).EQ.21) JS=2
12134 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12135 MINT(23-JS)=KSUSY1+22
12137 KCS=ISIGN(1,MINT(14+JS))
12139 ELSEIF(ISUB.EQ.248) THEN
12140 C...qj + g -> ~qj_L + ~chi02
12141 IF(MINT(15).EQ.21) JS=2
12144 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12145 MINT(23-JS)=KSUSY1+23
12147 KCS=ISIGN(1,MINT(14+JS))
12149 ELSEIF(ISUB.EQ.249) THEN
12150 C...qj + g -> ~qj_R + ~chi02
12151 IF(MINT(15).EQ.21) JS=2
12154 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12155 MINT(23-JS)=KSUSY1+23
12157 KCS=ISIGN(1,MINT(14+JS))
12159 ELSEIF(ISUB.EQ.250) THEN
12160 C...qj + g -> ~qj_L + ~chi03
12161 IF(MINT(15).EQ.21) JS=2
12164 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12165 MINT(23-JS)=KSUSY1+25
12167 KCS=ISIGN(1,MINT(14+JS))
12169 ELSEIF(ISUB.EQ.251) THEN
12170 C...qj + g -> ~qj_R + ~chi03
12171 IF(MINT(15).EQ.21) JS=2
12174 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12175 MINT(23-JS)=KSUSY1+25
12177 KCS=ISIGN(1,MINT(14+JS))
12179 ELSEIF(ISUB.EQ.252) THEN
12180 C...qj + g -> ~qj_L + ~chi04
12181 IF(MINT(15).EQ.21) JS=2
12184 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12185 MINT(23-JS)=KSUSY1+35
12187 KCS=ISIGN(1,MINT(14+JS))
12189 ELSEIF(ISUB.EQ.253) THEN
12190 C...qj + g -> ~qj_R + ~chi04
12191 IF(MINT(15).EQ.21) JS=2
12194 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12195 MINT(23-JS)=KSUSY1+35
12197 KCS=ISIGN(1,MINT(14+JS))
12199 ELSEIF(ISUB.EQ.254) THEN
12200 C...qj + g -> ~qk_L + ~chi+-1
12201 IF(MINT(15).EQ.21) JS=2
12204 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12205 IB=-IA+INT((IA+1)/2)*4-1
12206 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12208 KCS=ISIGN(1,MINT(14+JS))
12210 ELSEIF(ISUB.EQ.255) THEN
12211 C...qj + g -> ~qk_L + ~chi+-1
12212 IF(MINT(15).EQ.21) JS=2
12215 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12216 IB=-IA+INT((IA+1)/2)*4-1
12217 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12219 KCS=ISIGN(1,MINT(14+JS))
12221 ELSEIF(ISUB.EQ.256) THEN
12222 C...qj + g -> ~qk_L + ~chi+-2
12223 IF(MINT(15).EQ.21) JS=2
12226 IB=-IA+INT((IA+1)/2)*4-1
12227 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12228 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12230 KCS=ISIGN(1,MINT(14+JS))
12232 ELSEIF(ISUB.EQ.257) THEN
12233 C...qj + g -> ~qk_R + ~chi+-2
12234 IF(MINT(15).EQ.21) JS=2
12237 IB=-IA+INT((IA+1)/2)*4-1
12238 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12239 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12241 KCS=ISIGN(1,MINT(14+JS))
12243 ELSEIF(ISUB.EQ.258) THEN
12244 C...qj + g -> ~qj_L + ~g
12245 IF(MINT(15).EQ.21) JS=2
12248 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12249 MINT(23-JS)=KSUSY1+21
12251 IF(JS.EQ.2) KCC=KCC+2
12254 ELSEIF(ISUB.EQ.259) THEN
12255 C...qj + g -> ~qj_R + ~g
12256 IF(MINT(15).EQ.21) JS=2
12259 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12260 MINT(23-JS)=KSUSY1+21
12262 IF(JS.EQ.2) KCC=KCC+2
12266 ELSEIF(ISUB.LE.270) THEN
12267 IF(ISUB.EQ.261) THEN
12268 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12270 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12271 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12273 C...Correct color combination
12274 IF(MINT(43).EQ.4) KCC=4
12276 ELSEIF(ISUB.EQ.262) THEN
12277 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12279 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12280 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12282 C...Correct color combination
12283 IF(MINT(43).EQ.4) KCC=4
12285 ELSEIF(ISUB.EQ.263) THEN
12286 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12287 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12288 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12289 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12290 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12293 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12294 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12296 C...Correct color combination
12297 IF(MINT(43).EQ.4) KCC=4
12299 ELSEIF(ISUB.EQ.264) THEN
12300 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12301 KCS=(-1)**INT(1.5D0+PYR(0))
12302 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12306 ELSEIF(ISUB.EQ.265) THEN
12307 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12308 KCS=(-1)**INT(1.5D0+PYR(0))
12309 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12314 ELSEIF(ISUB.LE.296) THEN
12315 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12316 C...qi + qj -> ~qi_L + ~qj_L
12318 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12319 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12320 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12322 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12323 C...qi + qj -> ~qi_R + ~qj_R
12325 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12326 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12327 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12329 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12330 C...qi + qj -> ~qi_L + ~qj_R
12331 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12332 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12334 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12336 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12337 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12338 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12339 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12341 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12343 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12344 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12345 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12346 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12348 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12350 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12351 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12352 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12353 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12355 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12357 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12358 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12360 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12361 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12363 IF(MINT(43).EQ.4) KCC=4
12365 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12366 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12368 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12369 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12371 IF(MINT(43).EQ.4) KCC=4
12373 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12374 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12376 KCS=(-1)**INT(1.5D0+PYR(0))
12377 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12381 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12382 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12383 KCS=(-1)**INT(1.5D0+PYR(0))
12384 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12388 ELSEIF(ISUB.EQ.294) THEN
12389 C...qj + g -> ~qj_L + ~g
12390 IF(MINT(15).EQ.21) JS=2
12393 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12394 MINT(23-JS)=KSUSY1+21
12396 IF(JS.EQ.2) KCC=KCC+2
12399 ELSEIF(ISUB.EQ.295) THEN
12400 C...qj + g -> ~qj_R + ~g
12401 IF(MINT(15).EQ.21) JS=2
12404 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12405 MINT(23-JS)=KSUSY1+21
12407 IF(JS.EQ.2) KCC=KCC+2
12411 ELSEIF(ISUB.LE.330) THEN
12412 IF(ISUB.EQ.311)THEN
12413 C...g + g -> g* + g* (UED)
12415 KCS=(-1)**INT(1.5D0+PYR(0))
12418 MINT(21)=IUEDEQ(472)
12419 MINT(22)=IUEDEQ(472)
12420 ELSEIF(ISUB.EQ.312)THEN
12421 C...q + g -> q*_D + g*, q*_S + g*
12422 C...The two channels have the same cross section
12424 IF(PYR(0).GT.0.5)KKFLMI=456
12425 IF(MINT(15).EQ.21) JS=2
12427 IF(MINT(15).EQ.21)KCC=KCC+2
12428 IF(MINT(15).NE.21)THEN
12429 KCS=ISIGN(1,MINT(15))
12431 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12432 MINT(22)=IUEDEQ(472)
12433 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12435 IF(MINT(16).NE.21)THEN
12436 KCS=ISIGN(1,MINT(16))
12437 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12439 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12440 MINT(21)=IUEDEQ(472)
12442 ELSEIF(ISUB.EQ.313)THEN
12443 C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12444 C...The two channels have the same cross section
12446 IF(PYR(0).GT.0.5)KKFLMI=456
12448 IF(MINT(15).EQ.MINT(16))THEN
12449 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12451 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12454 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12455 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12456 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12457 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12459 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12460 ELSEIF(ISUB.EQ.314)THEN
12461 C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12462 C...The two channels have the same cross section
12464 IF(PYR(0).GT.0.5)KKFLMI=456
12465 KCS=(-1)**INT(1.5D0+PYR(0))
12467 IF(XFLAOUT.LE.0.2)THEN
12468 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12469 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12470 ELSEIF(XFLAOUT.LE.0.4)THEN
12471 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12472 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12473 ELSEIF(XFLAOUT.LE.0.6)THEN
12474 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12475 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12476 ELSEIF(XFLAOUT.LE.0.8)THEN
12477 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12478 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12480 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12481 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12486 ELSEIF(ISUB.EQ.315)THEN
12487 C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12488 C...The two channels have the same cross section
12490 IF(PYR(0).GT.0.5)KKFLMI=456
12491 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12493 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12496 ELSEIF(ISUB.EQ.316)THEN
12497 C...q + qbar' -> q*_D + q*_S_bar'
12498 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12499 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12500 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12501 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12503 ELSEIF(ISUB.EQ.317)THEN
12504 C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12505 C...The two channels have the same cross section
12507 IF(PYR(0).GT.0.5)KKFLMI=456
12508 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12509 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12510 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12511 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12513 ELSEIF(ISUB.EQ.318)THEN
12514 C...q + q' -> q*_D + q*_S'
12516 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12517 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12518 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12519 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12520 ELSEIF(ISUB.EQ.319)THEN
12521 C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12522 C...The two channels have the same cross section
12524 IF(PYR(0).GT.0.5)KKFLMI=456
12527 C...N.B. NFLAVOURS=IUED(3)
12530 IF(I.NE.IABS(MINT(15)))THEN
12535 FLASTEP=1./(IUED(3)-1)
12538 IF(XFLAOUT.LE.FLAVV)THEN
12539 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12540 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12545 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12546 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12547 CALL PYSTOP(5000000)
12553 ELSEIF(ISUB.LE.340) THEN
12555 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12556 C...q + qbar' -> H+ + H0
12557 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12558 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12559 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12560 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12561 MINT(23-JS)=KFPR(ISUB,2)
12562 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12563 C...f + fbar -> A0 + H0; th arbitrary
12564 IF(PYR(0).GT.0.5D0) JS=2
12565 MINT(20+JS)=KFPR(ISUB,1)
12566 MINT(23-JS)=KFPR(ISUB,2)
12567 ELSEIF(ISUB.EQ.301) THEN
12568 C...f + fbar -> H+ H-
12569 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12574 ELSEIF(ISUB.LE.360) THEN
12576 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12577 C...l + l -> H_L++/--, H_R++/--
12578 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12579 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12580 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12582 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12583 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12584 IF(MINT(15).EQ.22) JS=2
12585 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12586 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12589 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12590 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12591 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12594 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12595 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12596 C...as inner process).
12601 RVCKM=VINT(180+I)*PYR(0)
12604 IPM=(5-ISIGN(1,I))/2
12606 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12607 MINT(20+JT)=ISIGN(IB,I)
12608 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12609 IF(RVCKM.LE.0D0) GOTO 450
12612 IB=2*((IA+1)/2)-1+MOD(IA,2)
12613 MINT(20+JT)=ISIGN(IB,I)
12617 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12618 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12620 ELSEIF(ISUB.EQ.353) THEN
12621 C...f + fbar -> Z_R0
12624 ELSEIF(ISUB.EQ.354) THEN
12625 C...f + fbar' -> W+/-
12626 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12627 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12628 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12632 ELSEIF(ISUB.LE.380) THEN
12634 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12635 C...f + fbar -> charged+ charged- technicolor
12636 KSW=(-1)**INT(1.5D0+PYR(0))
12637 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12638 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12640 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12641 C...f + fbar -> neutral neutral technicolor
12642 MINT(21)=KFPR(ISUB,1)
12643 MINT(22)=KFPR(ISUB,2)
12645 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12646 C...f + fbar' -> neutral charged technicolor
12649 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12650 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12651 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12652 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12653 MINT(20+JS)=KFPR(ISUB,IN)
12655 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12656 C...f + fbar' -> charged neutral technicolor
12659 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12660 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12661 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12662 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12663 MINT(23-JS)=KFPR(ISUB,IN)
12666 ELSEIF(ISUB.LE.400) THEN
12667 IF(ISUB.EQ.381) THEN
12668 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12670 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12672 ELSEIF(ISUB.EQ.382) THEN
12673 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12674 MINT(21)=ISIGN(KFLF,MINT(15))
12678 ELSEIF(ISUB.EQ.383) THEN
12679 C...f + fbar -> g + g; th arbitrary, TC extensions
12684 ELSEIF(ISUB.EQ.384) THEN
12685 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12686 IF(MINT(15).EQ.21) JS=2
12688 IF(MINT(15).EQ.21) KCC=KCC+2
12689 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12690 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12692 ELSEIF(ISUB.EQ.385) THEN
12693 C...g + g -> f + fbar; th arbitrary, TC extensions
12694 KCS=(-1)**INT(1.5D0+PYR(0))
12695 MINT(21)=ISIGN(KFLF,KCS)
12699 ELSEIF(ISUB.EQ.386) THEN
12700 C...g + g -> g + g; th arbitrary, TC extensions
12702 KCS=(-1)**INT(1.5D0+PYR(0))
12704 ELSEIF(ISUB.EQ.387) THEN
12705 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12706 MINT(21)=ISIGN(MINT(55),MINT(15))
12710 ELSEIF(ISUB.EQ.388) THEN
12711 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12712 KCS=(-1)**INT(1.5D0+PYR(0))
12713 MINT(21)=ISIGN(MINT(55),KCS)
12717 ELSEIF(ISUB.EQ.391) THEN
12718 C...f + fbar -> G*.
12721 ELSEIF(ISUB.EQ.392) THEN
12726 ELSEIF(ISUB.EQ.393) THEN
12727 C...q + qbar -> g + G*; th arbitrary.
12728 IF(PYR(0).GT.0.5D0) JS=2
12729 MINT(20+JS)=KFPR(ISUB,1)
12730 MINT(23-JS)=KFPR(ISUB,2)
12733 ELSEIF(ISUB.EQ.394) THEN
12734 C...q + g -> q + G*; th = (p(f) - p(f))**2
12735 IF(MINT(15).EQ.21) JS=2
12736 MINT(23-JS)=KFPR(ISUB,2)
12738 KCS=ISIGN(1,MINT(14+JS))
12740 ELSEIF(ISUB.EQ.395) THEN
12741 C...g + g -> G* + g; th arbitrary.
12742 IF(PYR(0).GT.0.5D0) JS=2
12743 MINT(23-JS)=KFPR(ISUB,2)
12747 ELSEIF(ISUB.LE.420) THEN
12748 IF(ISUB.EQ.401) THEN
12749 C...g + g -> t + b + H+/-
12750 KCS=(-1)**INT(1.5D0+PYR(0))
12751 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12752 MINT(22)=ISIGN(5,-KCS)
12753 KCC=11+INT(0.5D0+PYR(0))
12754 KFRES=ISIGN(KFHIGG,-KCS)
12756 ELSEIF(ISUB.EQ.402) THEN
12757 C...q + qbar -> t + b + H+/-
12758 KFL=(-1)**INT(1.5D0+PYR(0))
12759 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12760 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12762 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12766 C...Additional code by Stefan Wolf
12767 ELSEIF(ISUB.LE.430) THEN
12768 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12769 C...g + g -> QQ~[n] + g
12770 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12771 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12772 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12773 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12774 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12775 C...[g + g -> g + g; th arbitrary]
12776 MINT(21)=KFPR(ISUBSV,1)
12777 MINT(22)=KFPR(ISUBSV,2)
12778 IF(ISUB.EQ.421) THEN
12780 KCS=(-1)**INT(1.5D0+PYR(0))
12783 KCS=(-1)**INT(1.5D0+PYR(0))
12786 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12787 C...q + g -> q + QQ~[n]
12788 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12789 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12790 C...KCC copied from ISUB.EQ.28
12791 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12792 IF(MINT(15).EQ.21) JS=2
12793 MINT(23-JS)=KFPR(ISUBSV,2)
12795 IF(MINT(15).EQ.21) KCC=KCC+2
12796 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12797 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12799 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12800 C...q + q~ -> g + QQ~[n]
12801 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12802 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12803 C...KCC copied from ISUB.EQ.13
12804 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12805 IF(PYR(0).GT.0.5) JS=2
12807 MINT(23-JS)=KFPR(ISUBSV,2)
12811 ELSEIF(ISUB.LE.440) THEN
12812 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12813 C...g + g -> QQ~[n] + g
12814 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12815 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12816 C...KCC and KCS copied from ISUB.EQ.86-89
12817 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12818 MINT(21)=KFPR(ISUBSV,1)
12819 MINT(22)=KFPR(ISUBSV,2)
12821 KCS=(-1)**INT(1.5D0+PYR(0))
12823 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12824 C...q + g -> q + QQ~[n]
12825 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12826 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12827 C...KCC and KCS copied from ISUB.EQ.112
12828 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12829 IF(MINT(15).EQ.21) JS=2
12830 MINT(23-JS)=KFPR(ISUBSV,2)
12832 KCS=ISIGN(1,MINT(14+JS))
12834 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12835 C...q + q~ -> g + QQ~[n]
12836 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12837 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12838 C...KCC copied from ISUB.EQ.111
12839 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12840 IF(PYR(0).GT.0.5) JS=2
12842 MINT(23-JS)=KFPR(ISUBSV,2)
12849 IF(ISET(ISUB).EQ.11) THEN
12850 C...Store documentation for user-defined processes
12851 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12852 KUPPO(1)=MINT(83)+5
12853 KUPPO(2)=MINT(83)+6
12857 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12866 IF(IDUP(IUP).EQ.0) K(I,2)=90
12868 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12876 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12879 C...Store final state partons for user-defined processes
12884 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12886 IF(IDUP(IUP).EQ.0) K(N,2)=90
12887 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12890 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12894 C...Search for daughters of intermediate colourless particles.
12895 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12896 DO 475 IUPDAU=IUP+1,NUP
12897 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12899 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12907 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12909 C...Arrange colour flow for user-defined processes
12913 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12914 IF(K(I1,1).EQ.1) K(I1,1)=3
12915 IF(K(I1,1).EQ.11) K(I1,1)=14
12916 C...Find a not yet considered colour/anticolour line.
12918 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12921 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12925 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12926 C...Find all others belonging to same line.
12929 DO 520 IUP2=IUP1+1,NUP
12932 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12933 IF(ISDE2.EQ.ISDE1) THEN
12934 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12935 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12937 ELSEIF(I4.NE.0) THEN
12938 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12939 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12941 ELSEIF(IUP2.LE.2) THEN
12942 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12943 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12946 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12947 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12957 ELSEIF(IDOC.EQ.7) THEN
12958 C...Resonance not decaying; store kinematics
12973 C...Special cases: colour flow in coloured resonances
12974 KCRES=PYCOMP(KFRES)
12975 IF(KCHG(KCRES,2).NE.0) THEN
12979 IF(KCS.EQ.-1) JC=3-J
12980 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12981 & MINT(84)+ICOL(KCC,1,JC)
12982 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12983 & MINT(84)+ICOL(KCC,2,JC)
12984 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12985 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12994 ELSEIF(IDOC.EQ.8) THEN
12995 C...2 -> 2 processes: store outgoing partons in their CM-frame
12998 KCA=PYCOMP(MINT(20+JT))
13000 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13002 K(I,3)=MINT(83)+IDOC+JT-2
13004 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13005 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13007 P(I,5)=PYMASS(K(I,2))
13009 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13010 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13012 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13013 KFA1=IABS(MINT(21))
13014 KFA2=IABS(MINT(22))
13015 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13023 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13024 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13025 P(IPU4,4)=SHR-P(IPU3,4)
13026 P(IPU4,3)=-P(IPU3,3)
13031 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13032 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13034 ELSEIF(IDOC.EQ.9) THEN
13035 C...2 -> 3 processes: store outgoing partons in their CM frame
13038 KCA=PYCOMP(MINT(20+JT))
13040 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13042 K(I,3)=MINT(83)+IDOC+JT-3
13044 C...t and b in opposide order in event list as compared to
13045 C...matrix element?
13046 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13047 IF(IABS(K(I,2)).LE.22) THEN
13048 P(I,5)=PYMASS(K(I,2))
13050 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13052 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13053 P(I,1)=PT*COS(VINT(198+5*JTA))
13054 P(I,2)=PT*SIN(VINT(198+5*JTA))
13058 K(IPU5,3)=MINT(83)+IDOC
13060 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13061 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13062 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13063 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13064 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13066 P(IPU5,3)=PMT3*SINH(VINT(211))
13067 P(IPU5,4)=PMT3*COSH(VINT(211))
13068 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13069 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13070 IF(SQL12.LE.0D0) THEN
13074 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13075 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13076 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13077 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13078 C...t and b in opposide order in event list as compared to
13080 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13081 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13082 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13084 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13085 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13091 ELSEIF(IDOC.EQ.11) THEN
13092 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13093 PHI(1)=PARU(2)*PYR(0)
13098 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13100 K(I,3)=MINT(83)+IDOC+JT-2
13101 P(I,5)=PYMASS(K(I,2))
13102 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13106 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13107 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13108 P(I,1)=PTABS*COS(PHI(JT))
13109 P(I,2)=PTABS*SIN(PHI(JT))
13110 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13111 P(I,4)=0.5D0*SHPR*Z(JT)
13115 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13119 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13120 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13121 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13128 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13129 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13130 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13131 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13140 ELSEIF(IDOC.EQ.12) THEN
13141 C...Z0 and W+/- scattering: store bosons and outgoing partons
13142 PHI(1)=PARU(2)*PYR(0)
13144 JTRAN=INT(1.5D0+PYR(0))
13148 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13150 K(I,3)=MINT(83)+IDOC+JT-2
13151 P(I,5)=PYMASS(K(I,2))
13152 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13153 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13154 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13155 P(I,1)=PTABS*COS(PHI(JT))
13156 P(I,2)=PTABS*SIN(PHI(JT))
13157 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13158 P(I,4)=0.5D0*SHPR*Z(JT)
13161 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13164 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13169 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13170 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13171 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13174 K(IPU,2)=KFPR(ISUB,JT)
13175 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13176 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13177 K(IPU,3)=MINT(83)+8+JT
13178 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13179 P(IPU,5)=PYMASS(K(IPU,2))
13181 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13183 MINT(22+JT)=K(IPU,2)
13185 C...Find rotation and boost for hard scattering subsystem
13188 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13189 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13190 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13191 GAMCM=(P(I1,4)+P(I2,4))/SHR
13192 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13193 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13194 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13195 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13196 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13197 PHICM=PYANGL(PX,PY)
13198 C...Store hard scattering subsystem. Rotate and boost it
13199 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13201 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13203 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13204 PHIWZ=VINT(24)-PHICM
13205 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13206 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13207 P(IPU5,3)=PABS*CTHWZ
13208 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13209 P(IPU6,1)=-P(IPU5,1)
13210 P(IPU6,2)=-P(IPU5,2)
13211 P(IPU6,3)=-P(IPU5,3)
13212 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13213 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13225 MINT(8)=MINT(83)+10
13228 IF(ISET(ISUB).EQ.11) THEN
13229 ELSEIF(IDOC.GE.8) THEN
13230 C...Store colour connection indices
13233 IF(KCS.EQ.-1) JC=3-J
13234 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13235 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13236 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13237 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13238 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13239 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13240 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13241 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13244 C...Copy outgoing partons to documentation lines
13246 IF(IDOC.EQ.9) IMAX=3
13248 I1=MINT(83)+IDOC-IMAX+I
13252 IF(IDOC.LE.9) K(I1,3)=0
13253 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13259 ELSEIF(IDOC.EQ.9) THEN
13260 C...Store colour connection indices
13263 IF(KCS.EQ.-1) JC=3-J
13264 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13265 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13266 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13267 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13268 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13269 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13270 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13271 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13272 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13273 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13276 C...Copy outgoing partons to documentation lines
13278 I1=MINT(83)+IDOC-3+I
13289 C...Copy outgoing partons to list of allowed radiators.
13291 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13292 DO 690 I=MINT(84)+3,N
13295 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13299 C...Low-pT events: remove gluons used for string drawing purposes
13300 IF(ISUB.EQ.95) THEN
13301 IF(MINT(35).LE.1) THEN
13302 K(IPU3,1)=K(IPU3,1)+10
13303 K(IPU4,1)=K(IPU4,1)+10
13309 DO 720 I=MINT(83)+5,MINT(83)+8
13319 C***********************************************************************
13322 C...Handles intertwined pT-ordered spacelike initial-state parton
13323 C...and multiple interactions.
13325 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13326 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13327 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13328 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13330 C...Double precision and integer declarations.
13331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13332 IMPLICIT INTEGER(I-N)
13333 INTEGER PYK,PYCHGE,PYCOMP
13336 DOUBLE PRECISION PYALPS
13337 C...Parameter statement for maximum size of showers.
13338 PARAMETER (MAXNUR=1000)
13340 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13341 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13342 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13343 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13344 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13345 COMMON/PYINT1/MINT(400),VINT(400)
13346 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13347 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13348 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13349 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13350 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13351 COMMON/PYCTAG/NCT,MCT(4000,2)
13352 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13353 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13354 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13355 C...Local arrays and saved variables.
13356 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13357 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13360 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13361 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13363 C----------------------------------------------------------------------
13364 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13365 C...done only once per event, while MODE=0 is repeated each time the
13366 C...evolution needs to be restarted.
13367 IF (MODE.EQ.-1) THEN
13371 C...Store hard scattering variables
13388 C...Set shat for hardest scattering
13390 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13393 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13397 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13398 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13399 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13401 C----------------------------------------------------------------------
13402 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13403 C...interaction initiators, with no previous evolution. Check the input
13404 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13405 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13406 C...smaller than the CM energy / 2.)
13407 ELSEIF (MODE.EQ.0) THEN
13408 C...Reset counters and switches
13414 C...Reset hard scattering variables
13425 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13426 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13429 C...Reset statistics on activity in event.
13434 C...Reset extra companion reweighting factor
13437 C...We do not generate MI for soft process (ISUB=95), but the
13438 C...initialization must be done regardless, for later purposes.
13441 C...Initialize multiple interactions.
13442 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13443 IF(MINT(51).NE.0) RETURN
13445 C...Decide whether quarks in hard scattering were valence or sea
13449 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13450 IF(MINT(51).NE.0) RETURN
13453 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13455 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13456 IF (MSTP(70).EQ.2) THEN
13457 C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13458 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13459 ELSEIF (MSTP(70).EQ.3) THEN
13460 C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13461 ALPHA0 = MAX(1D-6,PARP(73))
13462 Q20 = ALAM3**2/PARP(64)
13463 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13464 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13466 C...Also store PT2MIN in VINT(17).
13467 180 VINT(17)=PT2MIN
13469 C...Set FS masses zero now.
13473 C...Initialize IS showers with VINT(56) as max scale.
13476 IF (MSTP(70).EQ.0) THEN
13477 PT20=MAX(PT2MIN,PARP(62)**2)
13478 ELSEIF (MSTP(70).EQ.1) THEN
13479 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13481 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13482 IF(MINT(51).NE.0) RETURN
13486 C----------------------------------------------------------------------
13487 C...MODE= 1: Evolve event from PTMAX to PTMIN.
13488 ELSEIF (MODE.EQ.1) THEN
13490 C...Skip if no phase space.
13491 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13493 C...Starting pT2 max scale (to be udpated successively).
13496 C...Evolve two sides of the event to find which branches at highest pT.
13501 C...Loop over current shower initiators.
13502 IF (MSTP(61).GE.1) THEN
13503 DO 230 MI=1,MINT(31)
13504 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13506 IF (MI.EQ.1) ISUB=ISUBHD
13509 C...Set up shat, initiator x values, and x remaining in BR.
13511 VINT(141)=XMI(1,MI)
13512 VINT(142)=XMI(2,MI)
13515 DO 210 JI=1,MINT(31)
13516 IF (JI.EQ.MINT(36)) GOTO 210
13517 VINT(143)=VINT(143)-XMI(1,JI)
13518 VINT(144)=VINT(144)-XMI(2,JI)
13520 C...Loop over sides.
13521 C...Generate trial branchings for this interaction. The hardest
13522 C...branching so far is automatically updated if necessary in /PYISMX/.
13526 IF (MSTP(70).EQ.0) THEN
13527 PT20=MAX(PT2MIN,PARP(62)**2)
13528 ELSEIF (MSTP(70).EQ.1) THEN
13530 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13532 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13533 IF (MINT(51).NE.0) RETURN
13538 C...Generate trial additional interaction.
13539 MINT(36)=MINT(31)+1
13540 240 IF (MOD(MSTP(81),10).GE.1) THEN
13542 C...Set up X remaining in BR.
13545 DO 250 JI=1,MINT(31)
13546 VINT(143)=VINT(143)-XMI(1,JI)
13547 VINT(144)=VINT(144)-XMI(2,JI)
13549 C...Generate trial interaction
13550 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13551 IF (MINT(51).EQ.1) RETURN
13554 C...And the winner is:
13555 IF (PT2MX.LT.PT2MIN) THEN
13557 ELSEIF (JSMX.EQ.0) THEN
13558 C...Accept additional interaction (may still fail).
13559 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13560 IF(MINT(51).NE.0) RETURN
13561 IF (IFAIL.EQ.0) THEN
13562 SHAT(MINT(36))=VINT(44)
13563 C...Decide on flavours (valence/sea/companion).
13566 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13567 IF(MINT(51).NE.0) RETURN
13570 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13571 C...Reconstruct kinematics of acceptable ISR branching.
13572 C...Set up shat, initiator x values, and x remaining in BR.
13575 VINT(44)=SHAT(MINT(36))
13576 VINT(141)=XMI(1,MINT(36))
13577 VINT(142)=XMI(2,MINT(36))
13580 DO 280 JI=1,MINT(31)
13581 IF (JI.EQ.MINT(36)) GOTO 280
13582 VINT(143)=VINT(143)-XMI(1,JI)
13583 VINT(144)=VINT(144)-XMI(2,JI)
13586 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13587 IF (MINT(51).EQ.1) RETURN
13588 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13589 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13590 MINT(354)=MINT(354)+1
13591 VINT(354)=VINT(354)+SQRT(PT2MX)
13592 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13593 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13594 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13597 C...Update PT2 iteration scale.
13600 C...Loop back to continue evolution.
13601 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13602 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13604 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13607 C----------------------------------------------------------------------
13608 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13609 ELSEIF (MODE.EQ.2) THEN
13611 C...Revert to "ordinary" meanings of some parameters.
13613 MINT(12+JS)=K(IMI(JS,1,1),2)
13614 VINT(140+JS)=XMI(JS,1)
13615 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13617 DO 300 MI=1,MINT(31)
13618 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13622 C...Restore saved quantities for hardest interaction.
13637 C*********************************************************************
13640 C...Generates spacelike parton showers.
13642 SUBROUTINE PYSSPA(IPU1,IPU2)
13644 C...Double precision and integer declarations.
13645 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13646 IMPLICIT INTEGER(I-N)
13647 INTEGER PYK,PYCHGE,PYCOMP
13648 PARAMETER (MAXNUR=1000)
13650 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13651 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13652 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13653 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13654 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13655 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13656 COMMON/PYINT1/MINT(400),VINT(400)
13657 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13658 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13659 COMMON/PYCTAG/NCT,MCT(4000,2)
13660 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13661 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13662 C...Local arrays and data.
13663 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13664 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13665 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13666 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13667 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13670 C...Read out basic information; set global Q^2 scale.
13675 VINT2R=VINT(2)*VINT(143)*VINT(144)
13676 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13677 &MIN(VINT2R,PARP(67)*VINT(56))
13680 C...Define which processes ME corrections have been implemented for.
13682 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13683 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13684 & ISUB.EQ.144) MECOR=1
13685 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13686 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13689 C...Initialize QCD evolution and check phase space.
13693 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13696 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13697 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13698 Q2INT=SQRT(Q0S*Q2EFF)
13699 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13700 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13701 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13703 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13706 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13707 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13708 Q2INT=SQRT(Q0S*Q2EFF)
13709 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13710 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13711 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13718 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13720 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13721 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13722 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13723 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13727 C...Initialize QED evolution and check phase space.
13731 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13732 &SPME=PMAS(13,1)**2
13733 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13734 &SPME=PMAS(15,1)**2
13735 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13738 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13740 TEMX=LOG(Q2MX/SPME)
13741 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13743 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13748 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13750 C...Loopback point in case of failure to reconstruct kinematics.
13759 IF(LOOP.GT.100) THEN
13770 C...Initial values: flavours, momenta, virtualities.
13773 KFBEAM(JT)=MINT(10+JT)
13774 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13775 KFLS(JT)=MINT(14+JT)
13776 KFLS(JT+2)=KFLS(JT)
13778 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13779 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13781 Q2S(JT)=FCQ2MX*Q2MX
13788 C...Calculate initial parton distribution weights.
13789 MINT(105)=MINT(102+JT)
13790 MINT(109)=MINT(106+JT)
13791 VINT(120)=VINT(2+JT)
13793 C.... Store side in MINT(124)
13796 IF(XS(JT).LT.1D0-XEE) THEN
13797 IF(MINT(31).GE.2) MINT(30)=JT
13798 IF(MSTP(57).LE.1) THEN
13799 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13801 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13805 XFS(JT,KFL)=XFB(KFL)
13807 C...Special kinematics check for c/b quarks (that g -> c cbar or
13808 C...b bbar kinematically possible).
13809 KFLCB=IABS(KFLS(JT))
13810 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13811 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13818 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13820 C...Find if interference with final state partons.
13822 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13826 KCA=PYCOMP(IABS(KFLS(I)))
13827 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13829 IF(KCFI(I).NE.0) THEN
13830 IF(I.EQ.1) IPFS=IPUS1
13831 IF(I.EQ.2) IPFS=IPUS2
13833 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13834 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13835 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13837 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13839 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13844 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13847 C...Pick up leg with highest virtuality.
13851 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13852 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13853 IF(MORE(JT).EQ.0) JT=3-JT
13858 XFB(KFL)=XFS(JT,KFL)
13863 C...Check if allowed to branch.
13865 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13867 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13868 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13871 IF(MINT(44+JT).EQ.3) THEN
13873 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13874 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13876 C***Currently kill QED shower for resolved photoproduction.
13877 IF(MINT(18+JT).EQ.1) MEEV=0
13878 C***Currently kill shower for W inside electron.
13879 IF(IABS(KFLB).EQ.24) THEN
13884 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13886 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13891 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13895 IF(MSTP(62).LE.1) THEN
13896 IF(ZS(JT).GT.0.99999D0) THEN
13899 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13900 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13901 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13903 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13904 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13907 ALSDUM=PYALPS(FQ2C*Q2B)
13908 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13910 B0=(33D0-2D0*MSTU(118))/6D0
13912 IF(MEEV.EQ.2) TEVEB=TEVCB
13916 C...Select side for interference with final state partons.
13917 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13920 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13922 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13923 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13924 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13926 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13930 C...Calculate preweighting factor for ME-corrected processes.
13931 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13933 C...Calculate Altarelli-Parisi weights.
13939 C...q -> q (g or gamma emission), g -> q.
13940 IF(IABS(KFLB).LE.10) THEN
13941 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13942 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13944 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13945 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13947 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13948 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13949 WTAPC(21)=WTGF*WTAPC(21)
13950 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13952 C...f -> f, gamma -> f.
13953 ELSEIF(IABS(KFLB).LE.20) THEN
13954 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13955 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13956 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13957 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13958 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13959 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13960 WTAPE(22)=WTGF*WTAPE(22)
13962 C...f -> g, g -> g.
13963 ELSEIF(KFLB.EQ.21) THEN
13964 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13965 DO 180 KFL=1,MSTP(58)
13969 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13970 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13971 DO 190 KFL=1,MSTP(58)
13972 WTAPC(KFL)=WTFG*WTAPC(KFL)
13973 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13975 WTAPC(21)=WTGG*WTAPC(21)
13977 C...f -> gamma, W+, W-.
13978 ELSEIF(KFLB.EQ.22) THEN
13979 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13982 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13983 WTAPE(11)=WTFG*WTAPE(11)
13984 WTAPE(-11)=WTFG*WTAPE(-11)
13986 ELSEIF(KFLB.EQ.24) THEN
13987 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13988 & (XEE*(XB+XEE)))/XB
13989 ELSEIF(KFLB.EQ.-24) THEN
13990 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13991 & (XEE*(XB+XEE)))/XB
13994 C...Calculate parton distribution weights and sum.
13997 IF(NTRY.GT.500) THEN
14003 XFBO=MAX(1D-10,XFB(KFLB))
14005 WTSF(KFL)=XFB(KFL)/XFBO
14006 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14007 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14009 WTSUMC=MAX(0.0001D0,WTSUMC)
14010 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14012 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14015 IF(NTRY2.GT.500) THEN
14020 IF(MSTP(64).LE.0) THEN
14021 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14022 ELSEIF(MSTP(64).EQ.1) THEN
14023 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14025 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14029 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14030 & (PARU(101)*FWTE*WTSUME*TEMX)))
14031 ELSEIF(MEEV.EQ.2) THEN
14032 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14035 C...Translate t into Q2 scale; choose between QCD and QED evolution.
14036 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14037 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14038 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14039 C...Ensure that Q2 is above threshold for charm/bottom.
14041 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14043 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14044 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14045 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14046 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14049 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14051 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14054 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14055 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14056 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14057 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14058 IF(Q2EB.GT.Q2MNE) MCE=2
14059 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14060 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14061 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14062 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14063 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14064 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14066 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14067 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14070 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14071 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14074 C...Evolution possibly ended. Update t values.
14078 ELSEIF(MCE.EQ.1) THEN
14081 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14082 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14086 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14089 C...Select flavour for branching parton.
14090 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14091 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14094 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14095 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14096 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14097 IF(KFLA.EQ.25) THEN
14102 C...Choose z value and corrective weight.
14104 C...q -> q + g or q -> q + gamma.
14105 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14106 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14107 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14108 WTZ=0.5D0*(1D0+Z**2)
14110 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14111 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14112 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14113 C...f -> f + gamma.
14114 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14115 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14116 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14117 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14119 Z=XB+XB*(XEE/(1D0-XEE))*
14120 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14122 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14123 C...f -> gamma + f.
14124 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) 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
14129 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14130 Z=XB+XB*(XEE/(1D0-XEE))*
14131 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14132 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14133 & (Q2B/(Q2B+PMAS(24,1)**2))
14135 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14136 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14137 WTZ=1D0-2D0*Z*(1D0-Z)
14139 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14140 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14141 WTZ=(1D0-Z*(1D0-Z))**2
14142 C...gamma -> f + fbar.
14143 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14144 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14145 WTZ=1D0-2D0*Z*(1D0-Z)
14147 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14149 C...Option with resummation of soft gluon emission as effective z shift.
14151 IF(MSTP(65).GE.1) THEN
14153 IF(KFLB.NE.21) RSOFT=8D0/3D0
14154 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14155 IF(Z.LE.XB) GOTO 220
14158 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14159 IF(MSTP(64).GE.2) THEN
14160 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14161 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14162 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14163 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14167 C...Remove kinematically impossible branchings.
14168 UHAT=Q2B-DSH*(1D0-Z)/Z
14169 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14171 C...Select phi angle of branching at random.
14172 PHIBR=PARU(2)*PYR(0)
14174 C...Matrix-element corrections for some processes.
14175 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14176 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14177 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14179 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14180 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14182 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14183 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14185 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14186 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14191 C...Impose angular constraint in first branching from interference
14192 C...with final state partons.
14194 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14195 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14196 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14197 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14198 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14199 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14203 C...Option with angular ordering requirement.
14204 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14205 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14206 IF(THE2T.GT.THE2(JT)) GOTO 220
14210 C...Weighting with new parton distributions.
14211 MINT(105)=MINT(102+JT)
14212 MINT(109)=MINT(106+JT)
14213 VINT(120)=VINT(2+JT)
14214 IF(MINT(31).GE.2) MINT(30)=JT
14216 C.... Store side in MINT(124)
14219 IF(MSTP(57).LE.1) THEN
14220 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14222 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14225 IF(XFBN.LT.1D-20) THEN
14226 IF(KFLA.EQ.KFLB) THEN
14232 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14233 TEVCB=0.5D0*(TEVCBS+TEVCB)
14235 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14236 TEVEB=0.5D0*(TEVEBS+TEVEB)
14248 C.... Store side in MINT(124)
14251 IF(MINT(31).GE.2) MINT(30)=JT
14252 IF(MSTP(57).LE.1) THEN
14253 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14255 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14258 IF(XFAN.LT.1D-20) GOTO 200
14260 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14262 C...Define two hard scatterers in their CM-frame.
14263 260 IF(N.EQ.NS+2) THEN
14265 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14268 IF(JR.EQ.1) IPO=IPUS1
14269 IF(JR.EQ.2) IPO=IPUS2
14279 P(I,3)=DPLCM*(-1)**(JR+1)
14280 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14281 P(I,5)=-SQRT(DQ2(JR))
14284 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14285 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14286 MCT(I,1)=MCT(IPO,1)
14287 MCT(I,2)=MCT(IPO,2)
14290 C...Find maximum allowed mass of timelike parton.
14291 ELSEIF(N.GT.NS+2) THEN
14296 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14297 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14298 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14299 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14300 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14302 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14303 & 1D-10*DPD(1)) IKIN=1
14304 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14305 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14306 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14307 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14309 C...Generate timelike parton shower (if required).
14316 C...f -> f + g (gamma).
14317 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14319 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14320 C...f -> g (gamma, W+-) + f.
14321 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14323 IF(KFLS(JT+2).EQ.24) THEN
14325 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14328 C...g (gamma) -> f + fbar, g + g.
14330 K(IT,2)=-KFLS(JT+2)
14331 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14334 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14335 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14336 P(IT,5)=PYMASS(K(IT,2))
14337 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14338 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14341 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14342 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14343 IF(MSTP(63).EQ.1) THEN
14345 ELSEIF(MSTP(63).EQ.2) THEN
14346 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14350 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14351 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14352 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14353 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14354 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14356 C...Only do timelike shower here if using PYSHOW
14357 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14358 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14362 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14365 C...Reconstruct kinematics of branching: timelike parton shower.
14367 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14368 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14369 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14370 & (4D0*DSH*DPC(3)**2)
14371 IF(DPT2.LT.0D0) GOTO 100
14372 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14373 & DSHR)/DPC(3)-DPC(3)
14375 P(IT,3)=DPB(1)*(-1)**(JT+1)
14376 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14378 DPB(1)=SQRT(DPB(1)**2+DPT2)
14379 DPB(2)=SQRT(DPB(1)**2+DMS)
14381 DPB(4)=SQRT(DPB(3)**2+DMS)
14382 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14384 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14385 THE=PYANGL(P(IT,3),P(IT,1))
14386 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14389 C...Reconstruct kinematics of branching: spacelike parton.
14398 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14399 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14400 P(N+1,5)=-SQRT(DQ2(3))
14404 C...Define colour flow of branching.
14409 C...f -> f + gamma (Z, W).
14410 IF(IABS(K(IT,2)).GE.22) THEN
14414 C...f -> gamma (Z, W) + f.
14415 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14418 C...gamma -> q + qbar, g + g.
14419 ELSEIF(K(N+1,2).EQ.22) THEN
14425 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14429 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14432 C...qbar -> qbar + g.
14433 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14436 C...qbar -> g + qbar.
14437 ELSEIF(K(N+1,2).LT.0) THEN
14440 C...g -> g + g; g -> q + qbar.
14441 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14448 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14449 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14450 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14451 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14452 IF(ID1.NE.ID2) THEN
14453 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14454 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14457 IF(K(IT,1).EQ.1) THEN
14462 C...Boost to new CM-frame.
14463 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14464 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14465 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14466 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14467 IR=N+(JT-1)*(IS(1)-N)
14468 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14471 C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14472 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14475 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14478 C...Global statistics.
14479 MINT(352)=MINT(352)+1
14480 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14481 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14485 C...Update kinematics variables.
14488 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14491 C...Save quantities; loop back.
14495 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14496 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14497 KFLS(JT+2)=KFLS(JT)
14502 XFS(JT,KFL)=XFA(KFL)
14511 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14512 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14513 IF(MSTU(21).GE.1) N=NS
14514 IF(MSTU(21).GE.1) RETURN
14516 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14518 C...Boost hard scattering partons to frame of shower initiators.
14520 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14526 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14527 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14528 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14530 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14531 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14532 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14534 C...Store user information. Reset Lambda value.
14535 IF(MINT(31).LE.1) THEN
14536 K(IPU1,3)=MINT(83)+3
14537 K(IPU2,3)=MINT(83)+4
14539 K(IPU1,3)=MINT(83)+1
14540 K(IPU2,3)=MINT(83)+2
14543 MINT(12+JT)=KFLS(JT)
14544 VINT(140+JT)=XS(JT)
14545 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14546 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14553 C*********************************************************************
14556 C...Generates pT-ordered spacelike initial-state parton showers and
14557 C...trial joinings.
14558 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14559 C... interaction initiators at PT2NOW.
14560 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14561 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14562 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14563 C... is below PT2CUT.
14564 C... (Also generate test joinings if MSTP(96)=1.)
14565 C...MODE= 1: Accept stored shower branching. Update event record etc.
14566 C...PT2NOW : Starting (max) PT2 scale for evolution.
14567 C...PT2CUT : Lower limit for evolution.
14568 C...PT2 : Result of evolution. Generated PT2 for trial emission.
14569 C...IFAIL : Status return code. IFAIL=0 when all is well.
14571 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14573 C...Double precision and integer declarations.
14574 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14575 IMPLICIT INTEGER(I-N)
14576 INTEGER PYK,PYCHGE,PYCOMP
14577 C...Parameter statement for maximum size of showers.
14578 PARAMETER (MAXNUR=1000)
14580 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14581 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14583 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14584 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14585 COMMON/PYINT1/MINT(400),VINT(400)
14586 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14587 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14588 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14589 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14590 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14591 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14592 COMMON/PYCTAG/NCT,MCT(4000,2)
14593 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14594 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14595 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14596 C...Local variables
14597 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14598 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14599 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14600 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14601 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14602 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14603 C...For check on excessive weights.
14606 C...Only give errors for very large weights, otherwise just warnings
14607 DATA WTEMAX /1.5D0/
14608 C...Only give errors for large pT, otherwise just warnings
14613 C----------------------------------------------------------------------
14614 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14615 C...starting from the hardest interaction initiators.
14616 IF (MODE.EQ.-1) THEN
14617 C...Set hard scattering SHAT.
14619 C...Mass thresholds and Lambda for QCD evolution.
14620 AEM2PI=PARU(101)/PARU(2)
14624 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14625 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14626 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14627 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14628 C...Optionally use Lambda_MC = Lambda_CMW
14629 IF (MSTP(64).EQ.3) THEN
14630 ALAM5 = ALAM5 * 1.569
14631 ALAM4 = ALAM4 * 1.618
14632 ALAM3 = ALAM3 * 1.661
14636 C...Massive quark forced creation threshold (in M**2).
14638 C...Set upper limit for X (ensures some X left for beam remnant).
14639 XMXC=1D0-2D0*PARP(111)/VINT(1)
14641 IF (MSTP(61).GE.1) THEN
14642 C...Initial values: flavours, momenta, virtualities.
14646 C...Special kinematics check for c/b quarks (that g -> c cbar or
14647 C...b bbar kinematically possible).
14648 KFLB=K(IMI(JS,1,1),2)
14650 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14651 C...Check PT2MAX > mQ^2
14652 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14653 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14654 & 'No Q creation possible.')
14658 C...Check for physical z values (m == MQ / sqrt(s))
14659 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14660 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14661 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14662 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14663 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14674 C...Zero joining array
14680 C----------------------------------------------------------------------
14681 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14682 C...MINT(30). Store if emission PT2 scale is largest so far.
14683 C...Also generate test joinings if MSTP(96)=1.
14684 ELSEIF(MODE.EQ.0) THEN
14689 C...No shower for structureless beam
14690 IF (MINT(44+JS).EQ.1) RETURN
14693 C...Absolute shower max scale = VINT(56)
14694 PT2=MIN(PT2NOW,VINT(56))
14695 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14696 C...Define for which processes ME corrections have been implemented.
14697 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14698 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14699 & .142.OR.ISUB.EQ.144) MECOR=1
14700 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14701 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14702 C...Calculate preweighting factor for ME-corrected processes.
14703 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14705 C...Basic info on daughter for which to find mother.
14706 KFLB=K(IMI(JS,MI,1),2)
14708 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14709 C...second companion.
14710 KSVCB=MAX(-1,IMI(JS,MI,2))
14711 C...Treat "first" companion of a pair like an ordinary sea quark
14712 C...(except that creation diagram is not allowed)
14713 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14714 C...X (rescaled to [0,1])
14715 XB=XMI(JS,MI)/VINT(142+JS)
14716 C...Massive quarks (use physical masses.)
14719 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14721 IF (KFLBA.EQ.5) RMQ2=RMB2
14722 C...Special threshold treatment for non-photon beams
14723 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14726 C...Flags for parton distribution calls.
14727 MINT(105)=MINT(102+JS)
14728 MINT(109)=MINT(106+JS)
14729 VINT(120)=VINT(2+JS)
14732 C.... Store side in MINT(124)
14735 C...Calculate initial parton distribution weights.
14736 IF(XB.GE.XMXC) THEN
14738 ELSEIF(MQMASS.EQ.0) THEN
14739 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14741 C...Initialize massive quark PT2 dependent pdf underestimate.
14743 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14744 C.!.Tentative treatment of massive valence quarks.
14745 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14747 TPM0=LOG(PT20/RMQ2)
14750 IF (KFLBA.LE.6) THEN
14751 C...For quarks, only include respective sea, val, or cmp part.
14752 IF (KSVCB.LE.0) THEN
14753 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14755 C...Find companion's companion
14758 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14762 C...Momentum fraction of the companion quark.
14763 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14765 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14769 C...Determine overestimated z range: switch at c and b masses.
14770 130 IF (PT2.GT.TMIN*RMB2) THEN
14772 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14775 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14777 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14786 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14787 ALAM2=ALAM2/PARP(64)
14788 C...Overestimated ZMAX:
14789 IF (MQMASS.EQ.0) THEN
14791 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14794 C...Massive (limit for bremsstrahlung diagram > creation)
14795 FMQ=SQRT(RMQ2/SHTNOW(MI))
14800 C...If kinematically impossible then do not evolve.
14801 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14803 C...Reset Altarelli-Parisi and PDF weights.
14810 C...Zero joining weights and compute X(partner) and X(mother) values.
14811 IF (MSTP(96).NE.0) THEN
14813 DO 150 MJ=1,MINT(31)
14816 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14817 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14822 C...Approximate Altarelli-Parisi weights (integrated AP dz).
14823 C...q -> q, g -> q or q -> q + gamma (already set which).
14824 IF(KFLBA.LE.5) THEN
14825 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14826 IF (KSVCB.LT.0) THEN
14827 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14829 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14830 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14831 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14833 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14834 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14835 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14836 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14837 WTAP(KFLB)=WTFF*WTAP(KFLB)
14838 WTAP(21)=WTGF*WTAP(21)
14841 IF (KSVCB.GE.1) THEN
14842 C...Kill normal creation but add joining diagrams for cmp quark.
14844 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14845 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14846 & " quark here. Not handled yet, giving up!")
14851 C...Check for possible joinings
14852 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14853 C...Find companion's companion.
14856 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14857 IF (MJOIND(JS,MJ).EQ.0) THEN
14860 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14861 IF (WTAPJ(MJ).GT.1D-6) THEN
14867 C...Add trial gluon joinings.
14868 DO 170 MJ=1,MINT(31)
14869 KFLC=K(IMI(JS,MJ,1),2)
14870 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14871 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14872 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14873 IF (WTAPJ(MJ).GT.1D-6) THEN
14880 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14881 C...Kill creation diagram for val quarks and sea quarks with companions.
14883 ELSEIF (MQMASS.EQ.0) THEN
14884 C...Extra safety factor for massless sea quark creation.
14885 WTAP(21)=WTAP(21)*1.25D0
14888 C... q -> g, g -> g.
14889 ELSEIF(KFLB.EQ.21) THEN
14890 C...Here we decide later whether a quark picked up is valence or
14891 C...sea, so we maintain the extra factor sqrt(z) since we deal
14892 C...with the *sum* of sea and valence in this context.
14893 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14894 C...new: do not allow backwards evol to pick up heavy flavour.
14895 DO 180 KFL=1,MIN(3,MSTP(58))
14899 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14900 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14902 WTAP(21)=WTGG*WTAP(21)
14904 C...Check for possible joinings (companions handled separately above)
14905 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14907 DO 190 MJ=1,MINT(31)
14908 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14910 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14911 IF (KSVCC.GE.1) GOTO 190
14912 KFLC=K(IMI(JS,MJ,1),2)
14913 C...Only try g -> g + g once.
14914 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14915 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14916 IF (KFLC.EQ.21) THEN
14917 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14919 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14921 IF (WTAPJ(MJ).GT.1D-6) THEN
14930 C...Initialize massive quark evolution
14931 IF (MQMASS.NE.0) THEN
14932 RML=(RMQ2+VINT(18))/ALAM2
14934 TPL=LOG((PT2+VINT(18))/ALAM2)
14935 TPM=LOG((PT2+VINT(18))/RMQ2)
14936 WN=WTAP(21)*WPDF0/B0
14940 C...Loopback point for iteration
14944 IF(NTRY.GT.500) THEN
14945 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14950 C... Calculate PDF weights and sum for evolution rate.
14952 XFBO=MAX(1D-10,XFB(KFLB))
14954 WTPDF(KFL)=XFB(KFL)/XFBO
14955 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14957 C...Only add gluon mother diagram for massless KFLB.
14958 IF(MQMASS.EQ.0) THEN
14959 WTPDF(21)=XFB(21)/XFBO
14960 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14962 WTSUM=MAX(0.0001D0,WTSUM)
14964 C...Add joining diagrams where applicable.
14966 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14967 DO 220 MJ=1,MINT(31)
14968 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14969 WTPDFJ(MJ)=1D0/XFBO
14970 C...x and x*pdf (+ sea/val) for parton C.
14971 KFLC=K(IMI(JS,MJ,1),2)
14973 KSVCC=MAX(-1,IMI(JS,MJ,2))
14974 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14978 C.... Store side in MINT(124)
14981 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14983 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14984 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14985 ELSEIF (KSVCC.GE.1) THEN
14986 print*, 'error! parton C is companion!'
14988 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14989 C...x and x*pdf (+ sea/val) for parton A.
14992 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14995 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15001 C.... Store side in MINT(124)
15004 IF (KSVCA.LE.0) THEN
15005 C...Consider C the "evolved" parton if B is gluon. Val/sea
15006 C...counting will then be done correctly in PYPDFU.
15007 IF (KFLBA.EQ.21) MINT(36)=MJ
15008 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15010 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15012 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15013 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15015 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15016 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15020 C...Pick normal pT2 (in overestimated z range).
15023 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15026 C...Evolve q -> q gamma separately, pick it if larger pT.
15027 IF(KFLBA.LE.5) THEN
15028 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15029 IF(PT2QED.GT.PT2) THEN
15036 C... Evolve massive quark creation separately.
15038 IF (MQMASS.NE.0) THEN
15039 if (WN .eq. 0.) THEN
15042 ARG = TPM/(TPL*PYR(0)**(-TML/WN)-TPM)
15044 PT2CR=(RMQ2+VINT(18))*(RML**ARG)-VINT(18)
15045 C... Ensure mininimum PT2CR and force creation near threshold.
15046 IF (PT2CR.LT.TMIN*RMQ2) THEN
15048 IF (NTHRES.GT.50) THEN
15049 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15050 & 'massive quark creation. Gave up trying.')
15052 C...Special return code if failing before any evolution at all: bad event
15053 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15060 C... Select largest PT2 (brems or creation):
15061 IF (PT2CR.GT.PT2) THEN
15070 C... Compute logarithms for this PT2
15071 TPL=LOG((PT2+VINT(18))/ALAM2)
15072 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15073 WTCRQQ=TPM/LOG(PT2/RMQ2)
15076 C...Evolve joining separately
15078 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15079 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15081 IF (PT2JN.GE.PT2) THEN
15087 C...Loopback if crossed c/b mass thresholds.
15088 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15091 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15096 C...Speed up shower. Skip if higher-PT acceptable branching
15097 C...already found somewhere else.
15098 C...Also finish if below lower cutoff.
15100 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
15102 C...Select parton A flavour (massive Q handled above.)
15103 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15107 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15108 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15109 IF(KFLA.EQ.6) KFLA=21
15110 ELSEIF (MJOIN.EQ.1) THEN
15111 C...Tentative joining accept/reject.
15112 WTRAN=PYR(0)*WTJOIN
15115 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15116 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15117 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15118 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15122 C...x*pdf (+ sea/val) at new pT2 for parton B.
15123 IF (KSVCB.LE.0) THEN
15126 C.... Store side in MINT(124)
15129 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15130 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15132 C...Companion distributions do not evolve.
15135 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15136 KFLC=K(IMI(JS,MJ,1),2)
15138 KSVCC=MAX(-1,IMI(JS,MJ,2))
15139 IF (KSVCB.GE.1) KSVCC=-1
15140 C...x*pdf (+ sea/val) at new pT2 for parton C.
15144 C.... Store side in MINT(124)
15147 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15149 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15150 WTVETO=WTVETO/XFJ(KFLC)
15151 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15154 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15157 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15161 IF (KSVCA.LE.0) THEN
15164 C.... Store side in MINT(124)
15167 IF (KFLB.EQ.21) MINT(36)=MJ
15168 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15170 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15172 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15174 WTVETO=WTVETO*XFJ(KFLA)
15175 C...Monte Carlo veto.
15176 IF (WTVETO.LT.PYR(0)) GOTO 200
15177 C...If accept, save PT2 of this joining.
15178 IF (PT2.GT.PT2MX) THEN
15186 C...Exit and continue evolution.
15191 C...Choose z value (still in overestimated range) and corrective weight.
15192 C...Unphysical z will be rejected below when Q2 has is computed.
15195 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15196 C...q -> q + g or q -> q + gamma (already set which).
15197 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15198 IF (KSVCB.LT.0) THEN
15199 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15201 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15202 Z=((1-ZFAC)/(1+ZFAC))**2
15204 WTZ=0.5D0*(1D0+Z**2)
15205 C...Massive weight correction.
15206 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15207 C...Valence quark weight correction (extra sqrt)
15208 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15211 C...NB: MQ>0 not yet implemented. Forced absent above.
15212 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15214 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15215 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15218 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15220 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15221 WTZ=Z**2+(1D0-Z)**2
15222 C...Massive correction
15223 IF (MQMASS.NE.0) THEN
15224 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15225 C...Extra safety margin for light sea quark creation
15226 ELSEIF (KSVCB.LT.0) THEN
15231 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15233 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15234 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15235 WTZ=(1D0-Z*(1D0-Z))**2
15238 C...Derive Q2 from pT2.
15240 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15242 C...Loopback if outside allowed z range for given pT2.
15243 RM2C=PYMASS(KFLC)**2
15244 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15245 IF (PT2ADJ.LT.1D-6) GOTO 230
15247 C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15248 C...No modification for very first emission if using ME correction
15250 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15254 C...For 1st branching, limit phase space by s-hat with color-partner
15255 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15258 C...Use anticolor tag for antiquark, or for gluon half the time
15259 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15260 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15262 MCTAG=MCT(IDIP,MSIDE)
15263 C...Default is to set up phase space using the opposite incoming parton
15264 JDIP=IMI(3-JS,MI,1)
15266 C...Alternatively, look for final-state color partner (pick first if several)
15268 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15273 C...Compute mass of pair
15274 SDIP=(P(IDIP,4)+P(JDIP,4))**2-(P(IDIP,3)+P(JDIP,3))**2
15275 & -(P(IDIP,2)+P(JDIP,2))**2-(P(IDIP,1)+P(JDIP,1))**2
15276 IF (MSTP67.EQ.1) THEN
15277 C...1 Option to completely kill radiation above s_dip * PARP(67)
15278 IF (4*PT2.GT.PARP(67)*SDIP) GOTO 230
15279 ELSE IF (MSTP67.EQ.2) THEN
15280 C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15281 C... (-> improved power showers?)
15282 IF (4*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15285 C...For subsequent branchings, loopback if nonordered in angle/rapidity
15286 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15287 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15291 C...Select phi angle of branching at random.
15294 C...Matrix-element corrections for some processes.
15295 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15296 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15297 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15299 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15300 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15302 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15303 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15305 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15306 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15311 C...Parton distributions at new pT2 but old x.
15314 C.... Store side in MINT(124)
15317 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15318 C...Treat val and cmp separately
15319 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15321 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15323 IF(XFBN.LT.1D-20) THEN
15324 IF(KFLA.EQ.KFLB) THEN
15337 C...Parton distributions at new pT2 and new x.
15341 C.... Store side in MINT(124)
15344 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15345 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15346 C...q -> q + g: only consider respective sea, val, or cmp content.
15347 IF (KSVCB.LE.0) THEN
15348 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15351 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15355 IF(XFAN.LT.1D-20) THEN
15359 C...If weighting fails continue evolution.
15361 IF (MCRQQ.EQ.0) THEN
15362 WTPDFA=1D0/WTPDF(KFLA)
15363 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15364 ELSEIF(MCRQQ.EQ.1) THEN
15366 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15368 ELSEIF(MCRQQ.EQ.2) THEN
15369 C...Force massive quark creation.
15373 C...Loop back if trial emission fails.
15374 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15375 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15376 IF(WTTOT.LT.0D0) THEN
15377 WRITE(CHWT,'(1P,E12.4)') WTTOT
15378 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15379 ELSEIF(WTTOT.GT.WTACC) THEN
15380 WRITE(CHWT,'(1P,E12.4)') WTTOT
15381 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15382 C...Too high weight: write out as error, but do not update error counter
15383 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15385 & '(PYPTIS:) Weight '//CHWT//' above unity')
15386 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15387 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15390 & '(PYPTIS:) Weight '//CHWT//' above unity')
15392 C...Useful for debugging but commented out for distribution:
15393 C print*, 'JS, MI',JS, MI
15394 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15395 C print*, 'A -> B C',KFLA, KFLB, KFLC
15397 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15400 C...Save acceptable branching.
15401 IF(PT2.GT.PT2MX) THEN
15414 C----------------------------------------------------------------------
15415 C...MODE= 1: Accept stored shower branching. Update event record etc.
15416 ELSEIF (MODE.EQ.1) THEN
15421 C...Shift down rest of event record to make room for insertion.
15426 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15427 KT1=K(I,4)/MSTU(5)**2
15428 KT2=K(I,5)/MSTU(5)**2
15429 ID1=MOD(K(I,4),MSTU(5))
15430 ID2=MOD(K(I,5),MSTU(5))
15431 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15432 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15433 IF (ID1.GE.IT) ID1=ID1+2
15434 IF (ID2.GE.IT) ID2=ID2+2
15435 IF (IM1.GE.IT) IM1=IM1+2
15436 IF (IM2.GE.IT) IM2=IM2+2
15437 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15438 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15444 MCT(I+2,1)=MCT(I,1)
15445 MCT(I+2,2)=MCT(I,2)
15448 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15449 DO 300 JI=1,MINT(31)
15450 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15451 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15452 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15453 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15454 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15455 C...Also update companion pointers to the present mother.
15456 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15459 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15461 C...Zero entries dedicated for new timelike and mother partons.
15472 C...Define timelike and new mother partons. History.
15479 C...Set mother origin = side.
15480 K(IM,3)=MINT(83)+JS+2
15481 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15483 C...Define colour flow of branching.
15486 C...q -> q + gamma.
15487 IF(K(IT,2).EQ.22) THEN
15492 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15496 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15499 C...qbar -> qbar + g.
15500 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15503 C...qbar -> g + qbar.
15504 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15507 C...g -> g + g; g -> q + qbar..
15508 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15515 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15516 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15517 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15518 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15519 IF(ID1.NE.ID2) THEN
15520 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15521 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15523 IF(K(IT,1).EQ.1) THEN
15527 C...Update IMI and colour tag arrays.
15535 C...If mother flag not yet set for spacelike parton, trace it.
15536 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15537 IF(MINT(51).NE.0) RETURN
15541 C...If mother flag not yet set for timelike parton, trace it.
15542 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15543 IF(MINT(51).NE.0) RETURN
15546 C...Boost recoiling parton to compensate for Q2 scale.
15547 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15548 & (1D0+(1D0+Q2BMX/SHAT)**2)
15550 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15552 C...Define system to be rotated and boosted
15553 C...(not including the 2 just added partons)
15554 C...(but including the docu lines for first interaction)
15555 IMIN=IMISEP(MI-1)+1
15556 IF (MI.EQ.1) IMIN=MINT(83)+5
15559 C...Rotate back system in phi to compensate for subsequent rotation.
15560 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15562 C...Define kinematics of new partons in old frame.
15564 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15565 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15566 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15567 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15569 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15570 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15571 P(IT,5)=SQRT(RM2CMX)
15573 C...Update internal line, now spacelike
15574 P(IS,1)=P(IM,1)-P(IT,1)
15575 P(IS,2)=P(IM,2)-P(IT,2)
15576 P(IS,3)=P(IM,3)-P(IT,3)
15577 P(IS,4)=P(IM,4)-P(IT,4)
15578 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15579 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15580 IF (P(IS,5).LT.0D0) THEN
15581 P(IS,5)=-SQRT(ABS(P(IS,5)))
15583 P(IS,5)=SQRT(P(IS,5))
15586 C...Boost entire system and rotate to new frame.
15587 C...(including docu lines)
15588 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15589 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15590 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15591 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15596 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15598 THETA=PYANGL(P(I1,3),P(I1,1))
15599 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15601 C...Global statistics.
15602 MINT(352)=MINT(352)+1
15603 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15604 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15606 C...Add parton with relevant pT scale for timelike shower.
15607 IF (K(IT,2).NE.22) THEN
15610 PTPART(NPART)=SQRT(PT2AMX)
15613 C...Update saved variables.
15614 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15615 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15616 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15617 PT2SAV(JSMX,MIMX)=PT2MX
15622 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15623 C...Gluon reconstructs to quark.
15624 C...Decide whether newly created quark is valence or sea:
15626 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15627 IF(MINT(51).NE.0) RETURN
15629 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15630 C...Quark reconstructs to gluon.
15631 C...Now some guy may have lost his companion. Check.
15633 IF (ICMP.GT.0) THEN
15634 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15635 & //' away. Cannot handle that yet. Giving up.')
15638 ELSEIF(ICMP.LT.0) THEN
15639 C...A sea quark with companion still in BR was reconstructed to a gluon.
15640 C...Companion should now be removed from the beam remnant.
15641 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15644 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15645 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15646 DO 370 JI=1,MINT(31)
15648 JFL=-K(IMI(JS,JI,1),2)
15649 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15653 NVC(JS,IFL)=NVC(JS,IFL)-1
15655 C...Set gluon IMI(JS,MI,2) = 0.
15657 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15658 C...Quark reconstructing to quark. If sea with companion still in BR
15659 C...then update associated x value.
15660 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15661 IF (IMI(JS,MI,2).LT.0) THEN
15664 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15670 C...If reached this point, normal exit.
15676 C*********************************************************************
15679 C...Generates maximum ME weight in some initial-state showers.
15680 C...Inparameter MECOR: kind of hard scattering process
15681 C...Outparameter WTFF: maximum weight for fermion -> fermion
15682 C... WTGF: maximum weight for gluon/photon -> fermion
15683 C... WTFG: maximum weight for fermion -> gluon/photon
15684 C... WTGG: maximum weight for gluon -> gluon
15686 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15688 C...Double precision and integer declarations.
15689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15690 IMPLICIT INTEGER(I-N)
15691 INTEGER PYK,PYCHGE,PYCOMP
15693 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15694 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15695 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15696 COMMON/PYINT1/MINT(400),VINT(400)
15697 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15698 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15700 C...Default maximum weight.
15706 C...Select maximum weight by process.
15707 IF(MECOR.EQ.1) THEN
15710 ELSEIF(MECOR.EQ.2) THEN
15718 C*********************************************************************
15721 C...Calculates actual ME weight in some initial-state showers.
15722 C...Inparameter MECOR: kind of hard scattering process
15723 C... IFLCB: flavour combination of branching,
15724 C... 1 for fermion -> fermion,
15725 C... 2 for gluon/photon -> fermion
15726 C... 3 for fermion -> gluon/photon,
15727 C... 4 for gluon -> gluon
15728 C... Q2: Q2 value of shower branching
15729 C... Z: Z value of branching
15730 C...In+outparameter PHIBR: azimuthal angle of branching
15731 C...Outparameter WTME: actual ME weight
15733 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15735 C...Double precision and integer declarations.
15736 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15737 IMPLICIT INTEGER(I-N)
15738 INTEGER PYK,PYCHGE,PYCOMP
15740 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15741 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15742 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15743 COMMON/PYINT1/MINT(400),VINT(400)
15744 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15745 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15747 C...Default output.
15750 C...Define kinematics of shower branching in Mandelstam variables.
15754 UH=Q2-SQM*(1D0-Z)/Z
15756 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15757 IF(MECOR.EQ.1) THEN
15758 IF(IFLCB.EQ.1) THEN
15759 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15760 ELSEIF(IFLCB.EQ.2) THEN
15761 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15764 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15765 ELSEIF(MECOR.EQ.2) THEN
15766 IF(IFLCB.EQ.3) THEN
15767 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15768 ELSEIF(IFLCB.EQ.4) THEN
15769 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15772 C...Matrix-element corrections for q + qbar -> Higgs (h0)
15773 ELSEIF(MECOR.EQ.3) THEN
15774 IF(IFLCB.EQ.2) THEN
15775 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15776 1 (SH**2+2D0*SQM*(SQM-SH))
15783 C*********************************************************************
15786 C...Handles the generation of additional interactions in the new
15787 C...multiple interactions framework.
15788 C...MODE=-1 : Initalize MI from scratch.
15789 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15790 C... Sudakov for PT2, abort if below PT2CUT.
15791 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15792 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15793 C...PT2NOW : Starting (max) PT2 scale for evolution.
15794 C...PT2CUT : Lower limit for evolution.
15795 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15796 C...IFAIL : Status return code.
15797 C... = 0: All is well.
15798 C... < 0: Phase space exhausted, generation to be terminated.
15799 C... > 0: Additional interaction vetoed, but continue evolution.
15801 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15802 C...Double precision and integer declarations.
15803 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15804 IMPLICIT INTEGER(I-N)
15805 INTEGER PYK,PYCHGE,PYCOMP
15806 C...Parameter statement for maximum size of showers.
15807 PARAMETER (MAXNUR=1000)
15809 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15810 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15812 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15813 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15814 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15815 COMMON/PYINT1/MINT(400),VINT(400)
15816 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15817 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15818 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15819 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15820 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15821 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15822 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15823 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15824 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15825 COMMON/PYCTAG/NCT,MCT(4000,2)
15826 C...Local arrays and saved variables.
15827 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15829 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15830 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15831 & /PYISMX/,/PYCTAG/
15835 C...Set MI subprocess = QCD 2 -> 2.
15838 C----------------------------------------------------------------------
15839 C...MODE=-1: Initialize from scratch
15840 IF (MODE.EQ.-1) THEN
15841 C...Initialize PT2 array.
15843 C...Initialize list of incoming beams and partons from two sides.
15850 IMI(JS,1,1)=MINT(84)+JS
15852 XMI(JS,1)=VINT(40+JS)
15853 C...Rescale x values to fractions of photon energy.
15854 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15855 C...Hard reset: hard interaction initiators motherless by definition.
15856 K(MINT(84)+JS,3)=2+JS
15857 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15858 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15862 IF (MOD(MSTP(81),10).GE.1) THEN
15863 IF(MSTP(82).LE.1) THEN
15864 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15866 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15867 & VINT(317)/(VINT(318)*VINT(320))
15868 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15870 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15871 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15874 C...Zero entries relating to scatterings beyond the first.
15880 IMISEP(MI)=IMISEP(1)
15885 C...Initialize factors for PDF reshaping.
15887 KFBEAM(JS)=MINT(10+JS)
15888 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15889 KFABM=IABS(KFBEAM(JS))
15890 KFSBM=ISIGN(1,KFBEAM(JS))
15892 C...Zero flavour content of incoming beam particle.
15896 C... Flavour content of baryon.
15897 IF(KFABM.GT.1000) THEN
15898 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15899 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15900 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15901 C... Flavour content of pi+-, K+-.
15902 ELSEIF(KFABM.EQ.211) THEN
15903 KFIVAL(JS,1)=KFSBM*2
15904 KFIVAL(JS,2)=-KFSBM
15905 ELSEIF(KFABM.EQ.321) THEN
15906 KFIVAL(JS,1)=-KFSBM*3
15907 KFIVAL(JS,2)=KFSBM*2
15908 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15911 C...Zero initial valence and companion content.
15916 C...Set up colour line tags starting from hard interaction initiators.
15918 C...Reset colour tag array and colour processing flags.
15919 DO 150 I=IMISEP(0)+1,N
15922 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15923 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15925 C... Consider each side in turn.
15930 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15932 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15934 CALL PYCTTR(I1,KCS,I2)
15935 IF(MINT(51).NE.0) RETURN
15939 C...Range checking for companion quark pdf large-x param.
15940 IF (MSTP(87).LT.0) THEN
15941 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15944 ELSEIF (MSTP(87).GT.4) THEN
15945 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15950 C----------------------------------------------------------------------
15951 C...MODE=0: Generate trial interaction. Return codes:
15952 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15953 C...IFAIL = 0: Additional interaction generated at PT2.
15954 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15955 ELSEIF (MODE.EQ.0) THEN
15956 C...Abolute MI max scale = VINT(62)
15957 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15958 180 IF(MSTP(82).LE.1) THEN
15959 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15960 IF(XT2.LT.VINT(149)) IFAIL=-2
15962 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15965 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15966 & LOG(PYR(0)))-VINT(149)
15969 C...Also exit if below lower limit or if higher trial branching
15971 PT2=0.25D0*VINT(2)*XT2
15972 IF (PT2.LE.PT2CUT) IFAIL=-4
15973 IF (PT2.LE.PT2MX) IFAIL=-5
15974 IF (IFAIL.NE.0) THEN
15978 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15979 VINT(25)=4D0*PT2/VINT(2)
15982 C...Choose tau and y*. Calculate cos(theta-hat).
15983 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15984 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15985 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15987 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15990 C...New: require shat > 1.
15991 IF(TAU*VINT(2).LT.1D0) GOTO 180
15995 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15996 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15997 CALL PYKMAP(2,MYST,PYR(0))
15998 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
16000 C...Check that x not used up. Accept or reject kinematical variables.
16001 X1M=SQRT(TAU)*EXP(VINT(22))
16002 X2M=SQRT(TAU)*EXP(-VINT(22))
16003 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
16004 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
16005 CALL PYSIGH(NCHN,SIGS)
16006 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16007 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16008 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16010 C...Save if highest PT so far.
16011 IF (PT2.GT.PT2MX) THEN
16017 C----------------------------------------------------------------------
16018 C...MODE=1: Generate and save accepted scattering.
16019 ELSEIF (MODE.EQ.1) THEN
16021 C...Reset K, P, V, and MCT vectors.
16033 C...Choose flavour of reacting partons (and subprocess).
16035 IF (NTRY.GT.50) THEN
16036 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16037 & //'interaction. Giving up!')
16045 ICONMI=ISIG(ICHN,3)
16046 RSIGS=RSIGS-SIGH(ICHN)
16047 IF(RSIGS.LE.0D0) GOTO 230
16050 C...Reassign to appropriate process codes.
16051 230 ISUBMI=ICONMI/10
16052 ICONMI=MOD(ICONMI,10)
16054 C...Choose new quark flavour for annihilation graphs
16055 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16056 SH=VINT(21)*VINT(2)
16057 CALL PYWIDT(21,SH,WDTP,WDTE)
16058 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16059 DO 250 I=1,MDCY(21,3)
16060 KFLF=KFDP(I+MDCY(21,2)-1,1)
16061 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16062 IF(RKFL.LE.0D0) GOTO 260
16064 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16065 IF(KFLF.GE.4) GOTO 240
16066 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16069 ELSEIF(ISUBMI.EQ.53) THEN
16075 C...Final state flavours and colour flow: default values
16082 IF(ISUBMI.EQ.11) THEN
16083 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16085 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16087 ELSEIF(ISUBMI.EQ.12) THEN
16088 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16089 KFL3=ISIGN(KFLF,KFL1)
16093 ELSEIF(ISUBMI.EQ.13) THEN
16094 C...f + fbar -> g + g; th arbitrary
16099 ELSEIF(ISUBMI.EQ.28) THEN
16100 C...f + g -> f + g; th = (p(f)-p(f))**2
16101 IF(KFL1.EQ.21) JS=2
16103 IF(KFL1.EQ.21) KCC=KCC+2
16104 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16105 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16107 ELSEIF(ISUBMI.EQ.53) THEN
16108 C...g + g -> f + fbar; th arbitrary
16109 KCS=(-1)**INT(1.5D0+PYR(0))
16110 KFL3=ISIGN(KFLF,KCS)
16114 ELSEIF(ISUBMI.EQ.68) THEN
16115 C...g + g -> g + g; th arbitrary
16117 KCS=(-1)**INT(1.5D0+PYR(0))
16120 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16121 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16122 & .OR.IABS(KFL4).EQ.5) THEN
16123 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16124 IF (PT2.LE.1.05*RMMAX2) THEN
16125 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16126 & //' too close to threshold (2nd try).')
16131 C...Store flavours of scattering.
16139 C...Set flavours and mothers of scattering partons.
16148 K(N+1,3)=MINT(83)+1
16149 K(N+2,3)=MINT(83)+2
16153 C...Store colour connection indices.
16156 IF(KCS.EQ.-1) JC=3-J
16157 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16158 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16159 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16160 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16163 C...Store incoming and outgoing partons in their CM-frame.
16164 SHR=SQRT(VINT(21))*VINT(1)
16167 P(N+2,3)=-0.5D0*SHR
16169 P(N+3,5)=PYMASS(K(N+3,2))
16170 P(N+4,5)=PYMASS(K(N+4,2))
16171 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16175 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16176 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16177 P(N+4,4)=SHR-P(N+3,4)
16180 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16182 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16184 C...Global statistics.
16185 MINT(351)=MINT(351)+1
16186 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16187 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16189 C...Keep track of loose colour ends and information on scattering.
16190 MINT(31)=MINT(31)+1
16192 PT2MI(MINT(36))=PT2
16193 IMISEP(MINT(31))=N+4
16195 IMI(JS,MINT(31),1)=N+JS
16196 IMI(JS,MINT(31),2)=0
16197 XMI(JS,MINT(31))=VINT(40+JS)
16199 C...Update cumulative counters
16200 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16201 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16204 C...Add to list of final state partons
16207 PTPART(NPART+1)=SQRT(PT2)
16208 PTPART(NPART+2)=SQRT(PT2)
16212 NISGEN(1,MINT(31))=0
16213 NISGEN(2,MINT(31))=0
16217 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16218 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16223 C...Finally, assign colour tags to new partons
16225 I1=IMI(JS,MINT(31),1)
16226 I2=IMI(3-JS,MINT(31),1)
16228 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16230 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16232 CALL PYCTTR(I1,KCS,I2)
16233 IF(MINT(51).NE.0) RETURN
16237 C----------------------------------------------------------------------
16238 C...MODE=2: Decide whether quarks in last scattering were valence,
16239 C...companion, or sea.
16240 ELSEIF (MODE.EQ.2) THEN
16244 KFSBM=ISIGN(1,MINT(10+JS))
16245 IFL=K(IMI(JS,MI,1),2)
16247 IF (IABS(IFL).GE.6) THEN
16248 IF (IABS(IFL).EQ.6) THEN
16249 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16253 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16254 C...(Do not include the parton itself in the X rescaling.)
16256 XRSC=X/(VINT(142+JS)+X)
16257 C...Note: XPSVC = x*pdf.
16260 C.... Store side in MINT(124)
16263 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16266 C...Ensure that pdfs are positive definite
16267 IF (SEA.LT.0D0) THEN
16268 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16270 ELSEIF (VAL.LT.0D0) THEN
16271 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16275 DO 310 IVC=1,NVC(JS,IFL)
16276 CMP=CMP+XPSVC(IFL,IVC)
16280 C...Decide (Extra factor x cancels in the dvision).
16281 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16284 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16285 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16287 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16288 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16289 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16290 IF(KFIVAL(JS,1).EQ.0) THEN
16291 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16292 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16293 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16294 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16296 C...Count down valence remaining. Do not count current scattering.
16297 DO 340 I1=1,NMI(JS)
16298 IF (I1.EQ.MINT(36)) GOTO 340
16299 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16303 IF(IVNOW.EQ.0) GOTO 330
16306 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16307 IF(KFIVAL(JS,1).EQ.0) THEN
16308 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16311 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16313 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16314 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16318 ELSEIF (RVCS.LE.VAL+SEA) THEN
16319 C...If sea, add opposite sign companion parton. Store X and I.
16320 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16321 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16322 C...Set pointer to companion
16323 IMI(JS,MI,2)=-NVC(JS,-IFL)
16326 C...If companion, check whether we've got any in the books
16327 IF (NVC(JS,IFL).EQ.0) THEN
16329 C...Only report error first time for this event
16331 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16332 C...Try a few times
16333 IF (NTRY.LE.10) THEN
16335 C... But if it stil fails, abort this event
16341 C...If several possibilities, decide which one
16345 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16346 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16347 C...Find original sea (anti-)quark. Do not consider current scattering.
16349 DO 360 I1=1,NMI(JS)
16350 IF (I1.EQ.MINT(36)) GOTO 360
16351 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16352 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16353 IMI(JS,MI,2)=IMI(JS,I1,1)
16354 IMI(JS,I1,2)=IMI(JS,MI,1)
16357 C...Mark companion "out-kicked".
16358 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16365 C*********************************************************************
16367 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16368 C...Giving the x*f pdf of a companion quark, with its partner at XS,
16369 C...using an approximate gluon density like (1-X)^NPOW/X. The value
16370 C...corresponds to an unrescaled range between 0 and 1-X.
16372 FUNCTION PYFCMP(XC,XS,NPOW)
16374 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16378 C...Parent gluon momentum fraction
16380 IF (Y.GE.1D0) RETURN
16381 C...Common factor (includes factor XC, since PYFCMP=x*f)
16382 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16383 C...Store normalized companion x*f distribution.
16384 IF (NPOW.LE.0) THEN
16385 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16386 ELSEIF (NPOW.EQ.1) THEN
16387 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16388 ELSEIF (NPOW.EQ.2) THEN
16389 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16390 & +3D0*XS*(1D0+XS)*LOG(XS)))
16391 ELSEIF (NPOW.EQ.3) THEN
16392 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16393 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16394 ELSEIF (NPOW.GE.4) THEN
16395 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16396 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16401 C*********************************************************************
16403 C...PYPCMP: Auxiliary to PYPDFU.
16404 C...Giving the momentum integral of a companion quark, with its
16405 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16406 C...The value corresponds to an unrescaled range between 0 and 1-XS.
16408 FUNCTION PYPCMP(XS,NPOW)
16410 DOUBLE PRECISION XS, PYPCMP
16412 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16414 ELSEIF (NPOW.LE.0) THEN
16415 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16416 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16417 ELSEIF (NPOW.EQ.1) THEN
16418 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16419 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16420 ELSEIF (NPOW.EQ.2) THEN
16421 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16422 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16423 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16424 & -3D0*XS*LOG(XS)*(1+XS)))
16425 ELSEIF (NPOW.EQ.3) THEN
16426 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16427 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16428 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16429 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16431 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16432 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16433 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16434 & -6D0*XS*LOG(XS)*(1D0+XS)))
16439 C*********************************************************************
16442 C...Rearranges contents of the HEPEUP commonblock so that
16443 C...mothers precede daughters and daughters of a decay are
16444 C...listed consecutively.
16448 C...Double precision and integer declarations.
16449 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16450 IMPLICIT INTEGER(I-N)
16452 C...User process event common block.
16454 PARAMETER (MAXNUP=500)
16455 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16456 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16457 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16458 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16459 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16463 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16464 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16465 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16467 C...Check whether a rearrangement is required.
16470 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16473 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16477 C...Find the new order that particles should have.
16483 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16488 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16489 IF(NNEW.NE.NUP) THEN
16491 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16495 C...Copy old info into temporary storage.
16499 MOTUPT(1,I)=MOTHUP(1,I)
16500 MOTUPT(2,I)=MOTHUP(2,I)
16501 ICOUPT(1,I)=ICOLUP(1,I)
16502 ICOUPT(2,I)=ICOLUP(2,I)
16506 VTIUPT(I)=VTIMUP(I)
16507 SPIUPT(I)=SPINUP(I)
16510 C...Copy info back into HEPEUP in right order.
16513 IDUP(I)=IDUPT(IOLD)
16514 ISTUP(I)=ISTUPT(IOLD)
16518 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16519 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16521 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16523 MOTHUP(1,I)=MOTHUP(2,I)
16526 ICOLUP(1,I)=ICOUPT(1,IOLD)
16527 ICOLUP(2,I)=ICOUPT(2,IOLD)
16529 PUP(J,I)=PUPT(J,IOLD)
16531 VTIMUP(I)=VTIUPT(IOLD)
16532 SPINUP(I)=SPIUPT(IOLD)
16536 c...If incoming particles are massive recalculate to put them massless.
16537 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16538 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16539 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16540 PUP(4,1)=0.5D0*PPLUS
16543 PUP(4,2)=0.5D0*PMINUS
16551 C*********************************************************************
16554 C...Administers the generation of successive final-state showers
16555 C...in external processes.
16557 SUBROUTINE PYADSH(NFIN)
16559 C...Double precision and integer declarations.
16560 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16561 IMPLICIT INTEGER(I-N)
16562 INTEGER PYK,PYCHGE,PYCOMP
16563 C...Parameter statement for maximum size of showers.
16564 PARAMETER (MAXNUR=1000)
16566 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16567 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16568 COMMON/PYCTAG/NCT,MCT(4000,2)
16569 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16570 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16571 COMMON/PYINT1/MINT(400),VINT(400)
16572 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16574 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16576 C...Set primary vertex.
16578 V(MINT(83)+5,J)=0D0
16579 V(MINT(83)+6,J)=0D0
16580 V(MINT(84)+1,J)=0D0
16581 V(MINT(84)+2,J)=0D0
16584 C...Isolate systems of particles with the same mother.
16587 DO 140 I=MINT(84)+3,NFIN
16589 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16596 C...Set production vertices.
16597 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16604 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16607 IF(MSTP(125).GE.1) THEN
16615 C...End loop over systems. Return if no showers to be performed.
16616 IBEG(NSYS+1)=NFIN+1
16617 IF(MSTP(71).LE.0) RETURN
16619 C...Loop through systems of particles; check that sensible size.
16621 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16622 IF(MINT(35).LE.2) THEN
16623 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16625 ELSEIF(NSIZ.LE.1) THEN
16626 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16628 ELSEIF(NSIZ.GT.80) THEN
16629 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16634 C...Save status codes and daughters of showering particles; reset them.
16641 IF(K(I,1).GT.10) THEN
16643 IF(KSAV(II,1).EQ.14) K(I,1)=3
16645 IF(KSAV(II,1).LE.10) THEN
16646 ELSEIF(K(I,1).EQ.1) THEN
16652 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16653 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16654 K(I,4)=K(I,4)-KSAV(II,4)
16655 K(I,5)=K(I,5)-KSAV(II,5)
16658 PSUM(J)=PSUM(J)+P(I,J)
16662 C...Perform shower.
16663 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16665 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16667 IF(MINT(35).LE.2) THEN
16669 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16671 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16674 C...For external processes, first call, also ISR partons radiate.
16675 C...Can use existing PYPART list, removing partons that radiate later.
16676 ELSEIF(ISYS.EQ.1) THEN
16679 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16681 IPART(NPARTN)=IPART(II)
16682 PTPART(NPARTN)=PTPART(II)
16686 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16688 C...For subsequent calls use the systems excluded above.
16694 PTPART(II)=0.5D0*QMAX
16696 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16699 C...Look up showered copies of original showering particles.
16703 C...Particles without daughters need not be studied.
16704 IF(KSAV(II,1).LE.10) GOTO 260
16705 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16706 ELSEIF(K(I,1).EQ.11) THEN
16707 190 IMV=MOD(K(IMV,4),MSTU(5))
16708 IF(K(IMV,1).EQ.11) GOTO 190
16710 KDA1=MOD(K(I,4),MSTU(5))
16712 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16714 KDA2=MOD(K(I,5),MSTU(5))
16716 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16719 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16722 KDA1=MOD(K(I3,4),MSTU(5))
16724 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16726 KDA2=MOD(K(I3,5),MSTU(5))
16728 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16734 C...Restore daughter info of original partons to showered copies.
16735 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16736 IF(KSAV(II,1).LE.10) THEN
16737 ELSEIF(K(I,1).EQ.1) THEN
16738 K(IMV,4)=KSAV(II,4)
16739 K(IMV,5)=KSAV(II,5)
16741 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16742 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16745 C...Reset mother info of existing daughters to showered copies.
16746 DO 210 I3=IBEG(ISYS+1),NFIN
16747 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16748 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16749 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16750 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16754 C...Boost all original daughters to new frame of showered copy.
16755 C...Also update their colour tags.
16758 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16760 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16762 BETA(J)=FAC*BETA(J)
16764 DO 250 I3=IBEG(ISYS+1),NFIN
16767 IF(MSTP(128).LE.0) THEN
16768 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16769 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16771 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16772 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16773 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16776 IF(IMO.EQ.IMV) THEN
16777 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16778 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16779 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16780 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16788 C...End of loop over showering systems
16794 C*********************************************************************
16797 C...Interface to UPVETO, which allows user to veto event generation
16798 C...on the parton level, after parton showers but before multiple
16799 C...interactions, beam remnants and hadronization is added.
16801 SUBROUTINE PYVETO(IVETO)
16803 C...All real arithmetic in double precision.
16804 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16805 C...Three Pythia functions return integers, so need declaring.
16806 INTEGER PYK,PYCHGE,PYCOMP
16808 C...PYTHIA commonblocks.
16809 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16810 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16812 COMMON/PYINT1/MINT(400),VINT(400)
16813 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16814 C...HEPEVT commonblock.
16815 PARAMETER (NMXHEP=4000)
16816 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16817 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16818 DOUBLE PRECISION PHEP,VHEP
16821 DIMENSION IRESO(100)
16823 C...Define longitudinal boost from initiator rest frame to cm frame.
16824 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16825 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16827 C...Presentation is different if using pT-ordered shower
16828 IF(MINT(35).EQ.3) THEN
16833 C... Reset counters.
16838 C...Oth pass: identify beam and incoming partons
16839 DO 140 I=MINT(83)+1,MINT(83)+6
16841 IF(K(I,2).EQ.94) THEN
16850 C...First pass: identify final locations of resonances
16851 C...and of their daughters before showering.
16852 DO 150 I=MINT(84)+3,N
16856 C...Skip shower CM frame documentation lines.
16857 IF(K(I,2).EQ.94) THEN
16859 C... Store a new intermediate product, when mother in documentation.
16860 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16861 & K(I,3).LE.MINT(84)) THEN
16867 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
16869 C... Store a new intermediate product, when mother in main section.
16870 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16871 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16877 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
16880 IF(ISTORE.EQ.1) THEN
16881 C...Copy parton info, boosting momenta along z axis to cm frame.
16886 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16887 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16889 C...Store one mother. Rest of history and vertex info zeroed.
16901 C...Second pass: identify current set of "final" partons.
16902 DO 200 I=MINT(84)+3,N
16906 C...Store a final parton.
16907 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16911 C..Trace it back through shower, to check if from documented particle.
16915 IF(IHIST.GT.MINT(84)) THEN
16916 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16918 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16922 IF(IMOTH.EQ.0) GOTO 160
16923 IMOTH=MAX(0,IMOTH-6)
16924 ELSEIF(IHIST.LE.4) THEN
16925 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16934 IF(ISTORE.EQ.1) THEN
16935 C...Copy parton info, boosting momenta along z axis to cm frame.
16940 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16941 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16943 C...Store one mother. Rest of history and vertex info zeroed.
16954 C...Call user-written routine to decide whether to keep events.
16958 C*********************************************************************
16961 C...Allows resonances to decay (including parton showers for hadronic
16964 SUBROUTINE PYRESD(IRES)
16966 C...Double precision and integer declarations.
16967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16968 IMPLICIT INTEGER(I-N)
16969 INTEGER PYK,PYCHGE,PYCOMP
16970 C...Parameter statement to help give large particle numbers.
16971 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16972 &KEXCIT=4000000,KDIMEN=5000000)
16973 C...Parameter statement for maximum size of showers.
16974 PARAMETER (MAXNUR=1000)
16976 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16977 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16978 COMMON/PYCTAG/NCT,MCT(4000,2)
16979 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16980 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16981 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16982 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16983 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16984 COMMON/PYINT1/MINT(400),VINT(400)
16985 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16986 COMMON/PYINT4/MWID(500),WIDS(500,5)
16987 COMMON/PYPUED/IUED(0:99),RUED(0:99)
16988 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16989 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
16990 C...Local arrays and complex and character variables.
16991 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16992 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16993 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16994 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16995 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16996 COMPLEX FGK,HA(6,6),HC(6,6)
16998 CHARACTER CODE*9,MASS*9
17000 C...The F, Xi and Xj functions of Gunion and Kunszt
17001 C...(Phys. Rev. D33, 665, plus errata from the authors).
17002 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
17003 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
17004 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
17005 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
17006 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17007 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17008 &2D0*(D34/D56+D56/D34))
17010 C...Some general constants.
17013 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17017 GMMZ=PMAS(23,1)*PMAS(23,2)
17019 GMMW=PMAS(24,1)*PMAS(24,2)
17022 C...Boost and rotate to rest frame of incoming partons,
17023 C...to get proper amount of smearing of decay angles.
17029 C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17030 C...(101,102) are off shell and can have inconsistent momenta, resulting
17031 C...in boosts larger than unity. However, the corresponding docu partons
17032 C...(5,6) are kept on shell, and have consistent momenta that can be used
17033 C...to derive this boost instead. Ultimately, should change the way the new
17034 C...shower stores intermediate partons, but just using partons (5,6) for now
17035 C...does define the boost and furnishes a quick and much needed solution.
17036 IF (MINT(35).EQ.3) THEN
17040 ETOTIN=P(IIN1,4)+P(IIN2,4)
17041 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17042 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17043 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17044 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17045 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17046 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17047 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17048 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17051 C...Reset original resonance configuration.
17056 C...Define initial one, two or three objects for subprocess.
17060 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17061 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17062 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17064 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17065 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17066 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17067 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17068 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17070 ELSEIF(ISET(ISUB).EQ.5) THEN
17071 IREF(1,1)=MINT(84)+3
17072 IREF(1,2)=MINT(84)+4
17073 IREF(1,3)=MINT(84)+5
17074 IREF(1,4)=MINT(83)+7
17075 IREF(1,5)=MINT(83)+8
17076 IREF(1,6)=MINT(83)+9
17080 C...Define original resonance for odd cases.
17083 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17085 IF(IHDEC.EQ.1) ISUB=3
17087 IREF(1,4)=K(IRES,3)
17089 IF(IREF(1,4).GT.MINT(84)) THEN
17090 110 ITMPMO=IREF(1,4)
17091 IF(K(ITMPMO,2).EQ.94) THEN
17092 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17093 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17094 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17096 C...Explicitly check that reference particle exists, otherwise stop recursion
17097 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17098 IREF(1,4)=K(ITMPMO,3)
17103 IF(IREF(1,4).GT.MINT(84)) THEN
17106 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17107 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17110 EMATCH=ABS(P(II,4)-P(IREF14,4))
17117 C...Check if initial resonance has been moved (in resonance + jet).
17119 IF(IREF(1,JT).GT.0) THEN
17120 IF(K(IREF(1,JT),1).GT.10) THEN
17121 KFA=IABS(K(IREF(1,JT),2))
17122 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17123 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17124 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17125 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17126 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17128 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17129 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17131 DO 130 I=IREF(1,JT)+1,N
17132 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17135 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17136 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17137 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17138 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17140 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17141 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17146 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17147 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17153 C...Set decay vertex for initial resonances
17156 V(IREF(1,JT),I)=0D0
17160 C...Loop over decay history.
17166 IF(IREF(IP,2).EQ.0) JTMAX=1
17167 IF(IREF(IP,3).NE.0) JTMAX=3
17171 C...Check for Higgs which appears as decay product of user-process.
17174 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17176 IF(IHDEC.EQ.1) ISUB=3
17179 C...Start treatment of one, two or three resonances in parallel.
17191 C...Check whether particle can/is allowed to decay.
17192 IF(ID.EQ.0) GOTO 330
17195 IF(MWID(KCA).EQ.0) GOTO 330
17196 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17197 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17198 & KFA.EQ.18) IT4=IT4+1
17199 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17200 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17202 C...Choose lifetime and determine decay vertex.
17203 IF(K(ID,1).EQ.5) THEN
17205 ELSEIF(K(ID,1).NE.4) THEN
17206 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17209 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17212 C...Determine whether decay allowed or not.
17214 IF(MSTJ(22).EQ.2) THEN
17215 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17216 ELSEIF(MSTJ(22).EQ.3) THEN
17217 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17218 ELSEIF(MSTJ(22).EQ.4) THEN
17219 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17220 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17222 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17227 C...Info for selection of decay channel: sign, pairings.
17228 IF(KCHG(KCA,3).EQ.0) THEN
17231 IPM=(5-ISIGN(1,K(ID,2)))/2
17234 IF(JTMAX.EQ.2) THEN
17235 KFB=IABS(K(IREF(IP,3-JT),2))
17236 ELSEIF(JTMAX.EQ.3) THEN
17238 KFB=IABS(K(IREF(IP,JT2),2))
17239 IF(KFB.NE.KFA) THEN
17240 JT2=JT+2-3*((JT+1)/3)
17241 KFB=IABS(K(IREF(IP,JT2),2))
17245 C...Select decay channel.
17246 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17247 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17248 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17249 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17250 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17251 IF(WDTE0S.LE.0D0) GOTO 330
17255 IDC=IDL+MDCY(KCA,2)-1
17256 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17257 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17258 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17260 C...Read out flavours and colour charges of decay channel chosen.
17261 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17262 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17263 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17264 KFC1A=PYCOMP(IABS(KFL1(JT)))
17265 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17266 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17267 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17268 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17269 KFC2A=PYCOMP(IABS(KFL2(JT)))
17270 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17271 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17272 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17273 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17275 IF(KFL3(JT).NE.0) THEN
17276 KFC3A=PYCOMP(IABS(KFL3(JT)))
17277 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17278 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17279 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17282 C...Set/save further info on channel.
17284 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17286 HGZ(JT,1)=VINT(111)
17287 HGZ(JT,2)=VINT(112)
17288 HGZ(JT,3)=VINT(114)
17291 C...Select masses; to begin with assume resonances narrow.
17296 KFLW=IABS(KFL1(JT))
17298 ELSEIF(I.EQ.2) THEN
17299 KFLW=IABS(KFL2(JT))
17301 ELSEIF(I.EQ.3) THEN
17302 IF(KFL3(JT).EQ.0) GOTO 220
17303 KFLW=IABS(KFL3(JT))
17306 P(N+I,5)=PMAS(KCW,1)
17308 C...This prevents SUSY/t particles from becoming too light.
17309 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17310 PMMN(I)=PMAS(KCW,1)
17311 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17312 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17313 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17314 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17315 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17316 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17317 PMMN(I)=MIN(PMMN(I),PMSUM)
17321 ELSEIF(KFLW.EQ.6) THEN
17322 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17324 C...UED: select a graviton mass from continuous distribution
17325 C...(stored in PMAS(39,1) so no value returned)
17326 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17330 C...Check which two out of three are widest.
17333 PWID1=PMAS(KFC1A,2)
17334 PWID2=PMAS(KFC2A,2)
17335 KFLW1=IABS(KFL1(JT))
17336 KFLW2=IABS(KFL2(JT))
17337 IF(KFL3(JT).NE.0) THEN
17338 PWID3=PMAS(KFC3A,2)
17339 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17342 KFLW1=IABS(KFL3(JT))
17343 ELSEIF(PWID3.GT.PWID2) THEN
17346 KFLW2=IABS(KFL3(JT))
17350 C...If all narrow then only check that masses consistent.
17351 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17352 & PWID2.LT.PARP(41))) THEN
17354 C....Handle near degeneracy cases.
17355 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17356 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17357 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17358 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17362 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17363 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17366 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
17367 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
17372 C...For three wide resonances select narrower of three
17373 C...according to BW decoupled from rest.
17376 IF(KFL3(JT).NE.0) THEN
17377 IWID3=6-IWID1-IWID2
17378 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17382 P(N+IWID3,5)=PYMASS(KFLW3)
17383 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17384 PMTOT=PMTOT-P(N+IWID3,5)
17386 C...Select other two correlated within remaining phase space.
17390 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17391 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17392 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17397 CKIN(49)=PMMN(IWID1)
17398 CKIN(50)=PMMN(IWID2)
17399 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17404 IF(MINT(51).EQ.1) GOTO 720
17407 C...Begin fill decay products, with colour flow for coloured objects.
17412 C...Three-body decays
17413 IF(KFL3(JT).NE.0) THEN
17430 C...Generate kinematics (default is flat)
17433 C...Set generic colour flows whenever unambiguous,
17434 C...(independently of the order of the decay products)
17435 C...Sum up total colour content
17444 IF (KCQ(J).EQ.-1) THEN
17447 ELSEIF (KCQ(J).EQ.1) THEN
17450 ELSEIF (KCQ(J).EQ.2) THEN
17456 C...Set color flow for generic 1 -> N processes (N arbitrary)
17457 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17458 C...All singlets: do nothing
17460 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17461 C...Two octets, zero triplets, n singlets:
17462 IF (KCQ(0).EQ.2) THEN
17464 K(ID,4)=K(ID,4)+IOCT(2)
17465 K(ID,5)=K(ID,5)+IOCT(2)
17467 K(IOCT(2),4)=MSTU(5)*ID
17468 K(IOCT(2),5)=MSTU(5)*ID
17469 MCT(IOCT(2),1)=MCT(ID,1)
17470 MCT(IOCT(2),2)=MCT(ID,2)
17472 C...1 -> 8 + 8 + n(1)
17474 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17475 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17477 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17478 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17487 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17488 C...Two triplets, zero octets, n singlets.
17489 IF (KCQ(0).EQ.1) THEN
17491 K(ID,4)=K(ID,4)+ITRI(2)
17493 K(ITRI(2),4)=MSTU(5)*ID
17494 MCT(ITRI(2),1)=MCT(ID,1)
17495 ELSEIF (KCQ(0).EQ.-1) THEN
17496 C...3bar -> 3bar + n(1)
17497 K(ID,5)=K(ID,5)+IANT(2)
17499 K(IANT(2),5)=MSTU(5)*ID
17500 MCT(IANT(2),2)=MCT(ID,2)
17502 C...1 -> 3 + 3bar + n(1)
17504 K(ITRI(1),4)=MSTU(5)*IANT(1)
17506 K(IANT(1),5)=MSTU(5)*ITRI(1)
17512 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17513 C...Two triplets, one octet, n singlets.
17514 IF (KCQ(0).EQ.2) THEN
17515 C...8 -> 3 + 3bar + n(1)
17516 K(ID,4)=K(ID,4)+ITRI(1)
17517 K(ID,5)=K(ID,5)+IANT(1)
17519 K(ITRI(1),4)=MSTU(5)*ID
17521 K(IANT(1),5)=MSTU(5)*ID
17522 MCT(ITRI(1),1)=MCT(ID,1)
17523 MCT(IANT(1),2)=MCT(ID,2)
17524 ELSEIF (KCQ(0).EQ.1) THEN
17525 C...3 -> 8 + 3 + n(1)
17526 K(ID,4)=K(ID,4)+IOCT(1)
17528 K(IOCT(1),4)=MSTU(5)*ID
17529 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17531 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17532 MCT(IOCT(1),1)=MCT(ID,1)
17536 ELSEIF (KCQ(0).EQ.-1) THEN
17537 C...3bar -> 8 + 3bar + n(1)
17538 K(ID,5)=K(ID,5)+IOCT(1)
17540 K(IOCT(1),5)=MSTU(5)*ID
17541 K(IOCT(1),4)=MSTU(5)*IANT(2)
17543 K(IANT(2),5)=MSTU(5)*IOCT(1)
17544 MCT(IOCT(1),2)=MCT(ID,2)
17549 C...1 -> 3 + 3bar + 8 + n(1)
17551 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17553 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17554 K(IOCT(1),4)=MSTU(5)*IANT(1)
17556 K(IANT(1),5)=MSTU(5)*IOCT(1)
17564 CPS-- End of generic cases
17565 C...(could three octets also be handled?)
17566 C...(could (some of) the RPV cases be made generic as well?)
17568 C...Special cases (= old treatment)
17569 C...Set colour flow for t -> W + b + Z.
17570 ELSEIF(KFA.EQ.6) THEN
17573 IF(KCQM(JT).EQ.-1) ISID=5
17575 K(ID,ISID)=K(ID,ISID)+IDAU
17576 K(IDAU,ISID)=MSTU(5)*ID
17578 C...Set colour flow in three-body decays - programmed as special cases.
17580 ELSEIF(KFC2A.LE.6) THEN
17584 IF(KFL2(JT).LT.0) ISID=5
17585 K(N+2,ISID)=MSTU(5)*(N+3)
17586 K(N+3,9-ISID)=MSTU(5)*(N+2)
17587 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17588 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
17589 & .AND.KFL3(JT).NE.0) THEN
17590 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
17591 C...3-body decays of squarks to colour singlets plus one quark
17592 IF (KQSUMA.EQ.1) THEN
17595 IF (KCQ1(JT).NE.0) IQ=1
17596 IF (KCQ2(JT).NE.0) IQ=2
17597 IF (KCQ3(JT).NE.0) IQ=3
17599 IF (K(N+IQ,2).LT.0) ISID=5
17601 K(ID,ISID)=K(ID,ISID)+(N+IQ)
17602 K(N+IQ,ISID)=MSTU(5)*ID
17605 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
17610 IF(KFL2(JT).LT.0) ISID=5
17611 K(N+1,ISID)=MSTU(5)*(N+2)
17612 K(N+1,9-ISID)=MSTU(5)*(N+3)
17613 K(N+2,ISID)=MSTU(5)*(N+1)
17614 K(N+3,9-ISID)=MSTU(5)*(N+1)
17615 ELSEIF(KFA.EQ.KSUSY1+21) THEN
17619 IF(KFL2(JT).LT.0) ISID=5
17620 K(ID,ISID)=K(ID,ISID)+(N+2)
17621 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17622 K(N+2,ISID)=MSTU(5)*ID
17623 K(N+3,9-ISID)=MSTU(5)*ID
17626 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17627 & IABS(KCQ2(JT)).EQ.1) THEN
17631 IF(KFL2(JT).LT.0) ISID=5
17632 K(N+2,ISID)=MSTU(5)*(N+3)
17633 K(N+3,9-ISID)=MSTU(5)*(N+2)
17638 C...Set colour flow in three-body decays with baryon number violation.
17639 C...Neutralino and chargino decays first.
17640 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17641 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17642 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17643 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17644 C...Insert junction to keep track of colours.
17645 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17646 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17647 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17648 C...Set special junction codes:
17652 C...Order decay products by invariant mass. (will be used in PYSTRF).
17653 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)-
17654 & P(N+1,3)*P(N+2,3)
17655 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)-
17656 & P(N+1,3)*P(N+3,3)
17657 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)-
17658 & P(N+2,3)*P(N+3,3)
17659 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17660 K(N+4,4)=N+3+K(N+4,4)
17661 K(N+4,5)=N+1+MSTU(5)*(N+2)
17662 ELSEIF(PM13.LT.PM23) THEN
17663 K(N+4,4)=N+2+K(N+4,4)
17664 K(N+4,5)=N+1+MSTU(5)*(N+3)
17666 K(N+4,4)=N+1+K(N+4,4)
17667 K(N+4,5)=N+2+MSTU(5)*(N+3)
17673 C...Connect daughters to junction.
17677 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17679 C...Particle counter should be stepped up one extra for junction.
17683 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17684 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17685 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17686 C...Insert junction to keep track of colours.
17687 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17688 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17689 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17700 C...Start by connecting all daughters to junction.
17701 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17702 C...Only consider colour topologies with off shell resonances.
17703 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17704 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17705 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17706 IF (RMGLU-RMQ1.LT.RMRES) THEN
17707 C...Calculate propagators for each colour topology.
17708 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17709 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17710 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17714 CTMSUM=CTMSUM+CTM2(II-N)
17716 CTMSUM=PYR(0)*CTMSUM
17717 C...Select colour topology J, with most off shell least likely.
17720 CTMSUM=CTMSUM-CTM2(J)
17721 IF (CTMSUM.GT.0D0) GOTO 300
17722 C...The lucky winner gets its colour (anti-colour) directly from gluino.
17723 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17724 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17725 C...The other gluino colour is connected to junction
17726 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17728 K(N+4,4)=K(N+4,4)+ID
17729 C...Lastly, connect junction to remaining daughters.
17730 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17731 C...Particle counter should be stepped up one extra for junction.
17735 C...Update particle counter.
17738 C...2) Everything else two-body decay.
17740 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17745 C...First set colour flow as if mother colour singlet.
17746 IF(KCQ1(JT).NE.0) THEN
17748 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17749 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17751 IF(KCQ2(JT).NE.0) THEN
17753 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17754 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17756 C...Then redirect colour flow if mother (anti)triplet.
17757 IF(KCQM(JT).EQ.0) THEN
17758 ELSEIF(KCQM(JT).NE.2) THEN
17760 IF(KCQM(JT).EQ.-1) ISID=5
17762 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17763 K(ID,ISID)=K(ID,ISID)+IDAU
17764 K(IDAU,ISID)=MSTU(5)*ID
17765 C...Then redirect colour flow if mother octet.
17766 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17768 IF(KCQ1(JT).EQ.0) IDAU=N
17769 K(ID,4)=K(ID,4)+IDAU
17770 K(ID,5)=K(ID,5)+IDAU
17771 K(IDAU,4)=MSTU(5)*ID
17772 K(IDAU,5)=MSTU(5)*ID
17775 IF(KCQ1(JT).EQ.-1) ISID=5
17776 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17777 K(ID,ISID)=K(ID,ISID)+(N-1)
17778 K(ID,9-ISID)=K(ID,9-ISID)+N
17779 K(N-1,ISID)=MSTU(5)*ID
17780 K(N,9-ISID)=MSTU(5)*ID
17783 C...Insert junction
17784 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17786 C...~q* mother: type 3 junction. ~q mother: type 4.
17787 ITJUNC(JT)=(7+KCQM(JT))/2
17788 C...Specify junction KF and set colour flow from junction
17792 C...Junction type encoded together with mother:
17793 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17794 K(N,5)=N-1+MSTU(5)*(N-2)
17795 C...Zero P and V for junction (V filled later)
17800 C...Set colour flow from mother to junction
17801 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17802 C...Set colour flow from daughters to junction
17806 C...(Anti-)colour mother is junction.
17807 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17812 C...End loop over resonances for daughter flavour and mass selection.
17814 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17816 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17817 & KFL1(JT).EQ.0) THEN
17818 WRITE(CODE,'(I9)') K(ID,2)
17819 WRITE(MASS,'(F9.3)') P(ID,5)
17820 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17821 & CODE//' with mass'//MASS)
17827 C...Check for allowed combinations. Skip if no decays.
17828 IF(JTMAX.EQ.1) THEN
17829 IF(KDCY(1).EQ.0) GOTO 710
17830 ELSEIF(JTMAX.EQ.2) THEN
17831 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17832 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17833 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17834 ELSEIF(JTMAX.EQ.3) THEN
17835 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17836 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17837 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17838 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17839 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17840 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17841 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17844 C...Special case: matrix element option for Z0 decay to quarks.
17845 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17846 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17848 C...Check consistency of MSTJ options set.
17849 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17851 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17854 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17856 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17861 C...Select alpha_strong behaviour.
17864 MSTU(111)=MSTJ(108)
17865 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17867 PARU(112)=PARJ(121)
17868 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17870 C...Find axial fraction in total cross section for scalar gluon model.
17872 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17873 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17874 POLL=1D0-PARJ(131)*PARJ(132)
17875 SFF=1D0/(16D0*XW*XW1)
17876 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17877 & (PARJ(123)*PARJ(124))**2)
17878 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17880 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17881 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17882 & (PARJ(132)-PARJ(131)))
17885 QF=KCHG(KFLC,1)/3D0
17887 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17888 & 1D0-(2D0*PMQ/P(ID,5))**2))
17889 VF=SIGN(1D0,QF)-4D0*QF*XW
17890 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17891 & VF**2*HF1W)+VQ**3*HF1W
17892 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17895 C...Choice of jet configuration.
17896 CALL PYXJET(P(ID,5),NJET,CUT)
17900 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17901 ELSEIF(NJET.EQ.3) THEN
17902 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17907 C...Fill jet configuration; return if incorrect kinematics.
17909 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17910 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17911 ELSEIF(NJET.EQ.2) THEN
17912 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17913 ELSEIF(NJET.EQ.3) THEN
17914 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17915 ELSEIF(KFLN.EQ.21) THEN
17916 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17919 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17922 IF(MSTU(24).NE.0) THEN
17929 C...Angular orientation according to matrix element.
17930 IF(MSTJ(106).EQ.1) THEN
17931 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17932 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17934 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17935 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17938 C...Boost partons to Z0 rest frame.
17939 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17940 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17942 C...Mark decayed resonance and add documentation lines,
17944 IDOC=MINT(83)+MINT(4)
17946 I1=MINT(83)+MINT(4)+1
17948 IF(MSTP(128).GE.1) K(I,3)=ID
17949 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17960 C...Generate parton shower.
17961 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17962 CALL PYSHOW(N-1,N,P(ID,5))
17963 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17967 PTPART(1)=0.5D0*P(ID,5)
17968 PTPART(2)=PTPART(1)
17970 IF(K(N-1,2).GT.0) THEN
17977 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17980 C... End special case for Z0: skip ahead.
17986 C...Order incoming partons and outgoing resonances.
17987 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17990 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17991 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17992 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17993 ILIN(2)=2*MINT(84)+3-ILIN(1)
17995 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17999 IF(K(IREF(IP,1),2).EQ.23) IORD=2
18000 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
18001 IAKIPD=IABS(K(IREF(IP,IORD),2))
18002 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
18003 IF(KDCY(IORD).EQ.0) IORD=3-IORD
18005 C...Order decay products of resonances.
18006 DO 370 JT=IORD,3-IORD,3-2*IORD
18007 IF(KDCY(JT).EQ.0) THEN
18008 ILIN(IMAX+1)=NSD(JT)
18010 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18011 ILIN(IMAX+1)=N+2*JT-1
18012 ILIN(IMAX+2)=N+2*JT
18014 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18015 K(N+2*JT,2)=K(NSD(JT)+2,2)
18017 ILIN(IMAX+1)=N+2*JT
18019 ILIN(IMAX+2)=N+2*JT-1
18021 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18022 K(N+2*JT,2)=K(NSD(JT)+2,2)
18026 C...Find charge, isospin, left- and righthanded couplings.
18031 KFA=IABS(K(ILIN(I),2))
18032 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18033 COUP(I,1)=KCHG(KFA,1)/3D0
18034 COUP(I,2)=(-1)**MOD(KFA,2)
18035 COUP(I,4)=-2D0*COUP(I,1)*XWV
18036 COUP(I,3)=COUP(I,2)+COUP(I,4)
18039 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18040 IF(ISUB.EQ.22) THEN
18043 IF(I.EQ.5) I1=3-IORD
18046 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18047 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18048 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18053 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18054 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18055 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18056 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18058 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18062 C...Select angular orientation type - Z'/W' only.
18064 IF(ISUB.EQ.141) THEN
18065 IF(PYR(0).LT.PARU(130)) MZPWP=1
18067 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18068 IAKIR=IABS(K(IREF(2,2),2))
18069 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18070 IF(IAKIR.LE.20) MZPWP=2
18072 IF(IP.GE.3) MZPWP=2
18073 ELSEIF(ISUB.EQ.142) THEN
18074 IF(PYR(0).LT.PARU(136)) MZPWP=1
18076 IAKIR=IABS(K(IREF(2,2),2))
18077 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18078 IF(IAKIR.LE.20) MZPWP=2
18080 IF(IP.GE.3) MZPWP=2
18083 C...Select random angles (begin of weighting procedure).
18084 430 DO 440 JT=1,JTMAX
18085 IF(KDCY(JT).EQ.0) GOTO 440
18086 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18087 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18088 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18091 CTHE(JT)=2D0*PYR(0)-1D0
18092 PHI(JT)=PARU(2)*PYR(0)
18096 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18097 C...Construct massless four-vectors.
18106 IF(KDCY(JT).EQ.0) GOTO 470
18108 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18109 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18110 P(N+2*JT,3)=-0.5D0*P(ID,5)
18111 P(N+2*JT,4)=0.5D0*P(ID,5)
18112 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18113 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18116 C...Store incoming and outgoing momenta, with random rotation to
18117 C...avoid accidental zeroes in HA expressions.
18121 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18122 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18123 P(N+4+I,5)=P(ILIN(I),5)
18125 P(N+4+I,J)=P(ILIN(I),J)
18128 500 THERR=ACOS(2D0*PYR(0)-1D0)
18129 PHIRR=PARU(2)*PYR(0)
18130 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18132 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18133 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18140 C...Calculate internal products.
18141 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18142 & ISUB.EQ.142) THEN
18143 DO 540 I1=IMIN,IMAX-1
18144 DO 530 I2=I1+1,IMAX
18145 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18146 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18147 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18148 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18149 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18150 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18151 HC(I1,I2)=CONJG(HA(I1,I2))
18152 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18153 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18154 HA(I2,I1)=-HA(I1,I2)
18155 HC(I2,I1)=-HC(I1,I2)
18160 C...Calculate four-products.
18167 DO 580 I1=IMIN,IMAX-1
18168 DO 570 I2=I1+1,IMAX
18169 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18170 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18171 PKK(I2,I1)=PKK(I1,I2)
18177 KFAGM=IABS(IREF(IP,7))
18178 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18179 C...Isotropic decay selected by user.
18183 ELSEIF(JTMAX.EQ.3) THEN
18184 C...Isotropic decay when three mother particles.
18188 ELSEIF(IT4.GE.1) THEN
18189 C... Isotropic decay t -> b + W etc for 4th generation q and l.
18193 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18194 & IREF(IP,7).EQ.36) THEN
18195 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18196 C...CP-odd case added by Kari Ertresvag Myklevoll.
18197 C...Now also with mixed Higgs CP-states
18199 IF(IP.EQ.1) WTMAX=SH**2
18200 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18201 KFA=IABS(K(IREF(IP,1),2))
18202 KFT=IABS(K(IREF(IP,2),2))
18204 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18205 & MSTP(25).GE.3) THEN
18206 C...For mixed CP states need epsilon product.
18223 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18224 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18225 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18226 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18227 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18228 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18229 & P22*P30*P41+P13*P22*P31*P40
18230 C...For mixed CP states need gauge boson masses.
18231 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18232 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18233 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18234 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18239 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18240 KFLF1A=IABS(KFL1(1))
18241 EF1=KCHG(KFLF1A,1)/3D0
18242 AF1=SIGN(1D0,EF1+0.1D0)
18243 VF1=AF1-4D0*EF1*XWV
18244 KFLF2A=IABS(KFL1(2))
18245 EF2=KCHG(KFLF2A,1)/3D0
18246 AF2=SIGN(1D0,EF2+0.1D0)
18247 VF2=AF2-4D0*EF2*XWV
18248 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18249 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18252 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18253 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18254 ELSEIF(MSTP(25).LE.2) THEN
18256 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18257 & -2*PKK(3,4)*PKK(5,6)
18258 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18259 & (PKK(3,4)*PKK(5,6))
18260 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18261 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18263 C...Mixed CP states.
18264 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18265 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18266 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18267 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18268 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18269 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18270 & +PKK(3,4)*PKK(5,6)
18271 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18272 & +VA12AS*PKK(3,4)*PKK(5,6)
18273 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18274 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18275 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18276 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18280 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18281 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18284 WT=16D0*PKK(3,5)*PKK(4,6)
18285 ELSEIF(MSTP(25).LE.2) THEN
18287 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18288 & -2*PKK(3,4)*PKK(5,6)
18289 & -2*(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(3,6)-PKK(4,5)-PKK(4,6))*
18292 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18294 C...Mixed CP states.
18295 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18296 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18297 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18298 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18299 & +PKK(3,4)*PKK(5,6)
18300 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18301 & +PKK(3,4)*PKK(5,6)
18302 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18303 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18304 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18305 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18308 C...No angular correlations in other Higgs decays.
18313 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18314 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18316 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18318 IF(MOD(KFAGM,2).EQ.0) THEN
18326 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18327 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18328 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18329 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18331 ELSEIF(ISUB.EQ.1) THEN
18332 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18333 EI=KCHG(IABS(MINT(15)),1)/3D0
18334 AI=SIGN(1D0,EI+0.1D0)
18336 EF=KCHG(IABS(KFL1(1)),1)/3D0
18337 AF=SIGN(1D0,EF+0.1D0)
18340 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18341 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18342 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18343 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18344 & (VI**2+AI**2)*VINT(114)*VF**2)
18345 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18346 & 4D0*VI*AI*VINT(114)*VF*AF)
18347 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18348 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18349 WTMAX=2D0*(WT1+ABS(WT3))
18351 ELSEIF(ISUB.EQ.2) THEN
18352 C...Angular weight for W+/- -> 2 quarks/leptons.
18353 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18354 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18355 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18356 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18359 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18360 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18361 C...-> gluon/gamma + 2 quarks/leptons.
18362 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18363 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18364 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18365 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18366 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18367 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18368 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18369 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18370 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18371 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18372 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18373 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18374 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18375 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18376 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18377 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18379 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18380 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18381 C...-> gluon/gamma + 2 quarks/leptons.
18382 WT=PKK(1,3)**2+PKK(2,4)**2
18383 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18385 ELSEIF(ISUB.EQ.22) THEN
18386 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18387 S34=P(IREF(IP,IORD),5)**2
18388 S56=P(IREF(IP,3-IORD),5)**2
18389 TI=PKK(1,3)+PKK(1,4)+S34
18390 UI=PKK(1,5)+PKK(1,6)+S56
18393 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18394 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18395 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18396 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18397 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18398 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18399 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18400 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18403 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18404 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18405 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18406 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18407 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18408 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18409 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18412 ELSEIF(ISUB.EQ.23) THEN
18413 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18414 D34=P(IREF(IP,IORD),5)**2
18415 D56=P(IREF(IP,3-IORD),5)**2
18416 DT=PKK(1,3)+PKK(1,4)+D34
18417 DU=PKK(1,5)+PKK(1,6)+D56
18418 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18419 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18420 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18421 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18423 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18424 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18425 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18426 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18427 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18428 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18430 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18431 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18432 C...(or H0, or A0).
18433 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18434 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18435 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18436 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18437 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18439 ELSEIF(ISUB.EQ.25) THEN
18440 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18441 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18442 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18443 D34=P(IREF(IP,IORD),5)**2
18444 D56=P(IREF(IP,3-IORD),5)**2
18445 DT=PKK(1,3)+PKK(1,4)+D34
18446 DU=PKK(1,5)+PKK(1,6)+D56
18447 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18448 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18449 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18450 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18451 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18452 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18453 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18454 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18455 IF(MSTP(50).LE.0) THEN
18456 WT=FGK135**2+(CCWW*FGK253)**2
18457 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18458 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18461 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18462 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18463 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18464 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18467 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18468 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18469 C...(or H0, or A0).
18470 WT=PKK(1,3)*PKK(2,4)
18471 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18473 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18474 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18475 C...-> f + 2 quarks/leptons.
18476 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18477 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18478 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18479 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18480 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18481 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18482 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18483 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18484 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18485 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18486 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18487 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18488 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18489 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18490 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18491 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18492 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18493 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18495 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18496 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18497 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18498 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18499 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18501 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18503 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18504 WT=16D0*PKK(3,5)*PKK(4,6)
18507 ELSEIF(ISUB.EQ.110) THEN
18508 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18512 ELSEIF(ISUB.EQ.141) THEN
18513 C...Special case: if only branching ratios known then isotropic decay.
18514 IF(MWID(32).EQ.2) THEN
18517 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18518 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18519 C...Couplings of incoming flavour.
18520 KFAI=IABS(MINT(15))
18521 EI=KCHG(KFAI,1)/3D0
18522 AI=SIGN(1D0,EI+0.1D0)
18525 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18526 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18527 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18528 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18529 VPI=PARU(119+2*KFAIC)
18530 API=PARU(120+2*KFAIC)
18531 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18532 VPI=PARJ(178+2*KFAIC)
18533 API=PARJ(179+2*KFAIC)
18535 VPI=PARJ(186+2*KFAIC)
18536 API=PARJ(187+2*KFAIC)
18538 C...Couplings of final flavour.
18540 EF=KCHG(KFAF,1)/3D0
18541 AF=SIGN(1D0,EF+0.1D0)
18544 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18545 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18546 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18547 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18548 VPF=PARU(119+2*KFAFC)
18549 APF=PARU(120+2*KFAFC)
18550 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18551 VPF=PARJ(178+2*KFAFC)
18552 APF=PARJ(179+2*KFAFC)
18554 VPF=PARJ(186+2*KFAFC)
18555 APF=PARJ(187+2*KFAFC)
18557 C...Asymmetry and weight.
18558 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18559 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18560 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18561 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18562 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18563 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18564 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18565 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18566 WTMAX=2D0+ABS(ASYM)
18567 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
18568 C...Angular weight for f + fbar -> Z' -> W+ + W-.
18569 RM1=P(NSD(1)+1,5)**2/SH
18570 RM2=P(NSD(1)+2,5)**2/SH
18571 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18572 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18573 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18575 WT=CFLAT+CCOS2*CTHE(1)**2
18576 WTMAX=CFLAT+MAX(0D0,CCOS2)
18577 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
18578 & IABS(KFL1(1)).EQ.37)) THEN
18579 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18582 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18583 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18584 RM1=P(NSD(1)+1,5)**2/SH
18585 RM2=P(NSD(1)+2,5)**2/SH
18586 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18587 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18588 WTMAX=1D0+FLAM2/(8D0*RM1)
18589 ELSEIF(MZPWP.EQ.0) THEN
18590 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18591 C...(W:s like if intermediate Z).
18592 D34=P(IREF(IP,IORD),5)**2
18593 D56=P(IREF(IP,3-IORD),5)**2
18594 DT=PKK(1,3)+PKK(1,4)+D34
18595 DU=PKK(1,5)+PKK(1,6)+D56
18596 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18597 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18598 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
18599 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
18600 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18601 ELSEIF(MZPWP.EQ.1) THEN
18602 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18603 C...(W:s approximately longitudinal, like if intermediate H).
18604 WT=16D0*PKK(3,5)*PKK(4,6)
18607 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18608 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18613 ELSEIF(ISUB.EQ.142) THEN
18614 C...Special case: if only branching ratios known then isotropic decay.
18615 IF(MWID(34).EQ.2) THEN
18618 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18619 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18620 KFAI=IABS(MINT(15))
18622 IF(KFAI.GT.10) KFAIC=2
18623 VI=PARU(129+2*KFAIC)
18624 AI=PARU(130+2*KFAIC)
18627 IF(KFAF.GT.10) KFAFC=2
18628 VF=PARU(129+2*KFAFC)
18629 AF=PARU(130+2*KFAFC)
18630 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18631 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18632 WTMAX=2D0+ABS(ASYM)
18633 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18634 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18635 RM1=P(NSD(1)+1,5)**2/SH
18636 RM2=P(NSD(1)+2,5)**2/SH
18637 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18638 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18639 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18641 WT=CFLAT+CCOS2*CTHE(1)**2
18642 WTMAX=CFLAT+MAX(0D0,CCOS2)
18643 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18644 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18645 RM1=P(NSD(1)+1,5)**2/SH
18646 RM2=P(NSD(1)+2,5)**2/SH
18647 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18648 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18649 WTMAX=1D0+FLAM2/(8D0*RM1)
18650 ELSEIF(MZPWP.EQ.0) THEN
18651 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18652 C...(W/Z like if intermediate W).
18653 D34=P(IREF(IP,IORD),5)**2
18654 D56=P(IREF(IP,3-IORD),5)**2
18655 DT=PKK(1,3)+PKK(1,4)+D34
18656 DU=PKK(1,5)+PKK(1,6)+D56
18657 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18658 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18659 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18660 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18661 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18662 ELSEIF(MZPWP.EQ.1) THEN
18663 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18664 C...(W/Z approximately longitudinal, like if intermediate H).
18665 WT=16D0*PKK(3,5)*PKK(4,6)
18668 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18669 C...t + bbar -> t + W + bbar.
18674 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18676 C...Isotropic decay of leptoquarks (assumed spin 0).
18680 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18681 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18683 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18684 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18685 WT=1D0+SIDE*CTHE(1)
18687 ELSEIF(IP.EQ.1) THEN
18689 RM1=P(NSD(1)+1,5)**2/SH
18690 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18691 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18693 C...W/Z decay assumed isotropic, since not known.
18698 ELSEIF(ISUB.EQ.149) THEN
18699 C...Isotropic decay of techni-eta.
18703 ELSEIF(ISUB.EQ.191) THEN
18704 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18705 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18706 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18709 ELSEIF(IP.EQ.1) THEN
18710 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18711 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18712 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18713 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18714 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18715 KFAI=IABS(MINT(15))
18716 EI=KCHG(KFAI,1)/3D0
18717 AI=SIGN(1D0,EI+0.1D0)
18721 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18722 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18724 EF=KCHG(KFAF,1)/3D0
18725 AF=SIGN(1D0,EF+0.1D0)
18729 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18730 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18731 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18732 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18733 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18734 WTMAX=4D0*MAX(ASAME,AFLIP)
18736 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18741 ELSEIF(ISUB.EQ.192) THEN
18742 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18743 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18744 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18747 ELSEIF(IP.EQ.1) THEN
18748 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18749 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18753 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18758 ELSEIF(ISUB.EQ.193) THEN
18759 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18760 C...Angular weight for f + fbar -> omega_tc0 ->
18761 C...gamma pi_tc0 or Z0 pi_tc0.
18764 ELSEIF(IP.EQ.1) THEN
18765 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18766 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18767 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18768 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18769 KFAI=IABS(MINT(15))
18770 EI=KCHG(KFAI,1)/3D0
18771 AI=SIGN(1D0,EI+0.1D0)
18775 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18776 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18778 EF=KCHG(KFAF,1)/3D0
18779 AF=SIGN(1D0,EF+0.1D0)
18783 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18784 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18785 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18786 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18787 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18788 WTMAX=4D0*MAX(BSAME,BFLIP)
18790 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18795 ELSEIF(ISUB.EQ.353) THEN
18796 C...Angular weight for Z_R0 -> 2 quarks/leptons.
18797 EI=KCHG(IABS(MINT(15)),1)/3D0
18798 AI=SIGN(1D0,EI+0.1D0)
18800 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18801 AF=SIGN(1D0,EF+0.1D0)
18803 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18804 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18805 WT2=RMF*(VI**2+AI**2)*VF**2
18806 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18807 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18808 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18809 WTMAX=2D0*(WT1+ABS(WT3))
18811 ELSEIF(ISUB.EQ.354) THEN
18812 C...Angular weight for W_R+/- -> 2 quarks/leptons.
18813 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18814 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18815 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18816 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18819 ELSEIF(ISUB.EQ.391) THEN
18820 C...Angular weight for f + fbar -> G* -> f + fbar
18821 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18822 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18824 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18825 C...implemented by M.-C. Lemaire
18826 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18827 & IABS(KFL1(1)).EQ.22)) THEN
18830 C...Other G* decays not yet implemented angular distributions.
18836 ELSEIF(ISUB.EQ.392) THEN
18837 C...Angular weight for g + g -> G* -> f + fbar
18838 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18841 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18842 C...implemented by M.-C. Lemaire
18843 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18844 & IABS(KFL1(1)).EQ.22)) THEN
18845 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18847 C...Other G* decays not yet implemented angular distributions.
18853 C...Obtain correct angular distribution by rejection techniques.
18858 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18860 C...Construct massive four-vectors using angles chosen.
18861 590 DO 690 JT=1,JTMAX
18862 IF(KDCY(JT).EQ.0) GOTO 690
18867 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18869 IF(KFL3(JT).EQ.0) THEN
18870 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18871 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18874 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18875 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18880 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18882 C...Fill in position of decay vertex.
18883 DO 630 I=NSD(JT)+1,N0
18892 C...Mark decayed resonances; trace history.
18896 IF(KCQM(JT).NE.0) THEN
18897 C...Do not kill colour flow through coloured resonance!
18901 C...If 3-body or 2-body with junction:
18902 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18903 C...If 3-body with junction:
18904 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18907 C...Add documentation lines.
18908 ISUBRG=MAX(1,MIN(500,MINT(1)))
18909 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18910 IDOC=MINT(83)+MINT(4)
18913 IF(KFL3(JT).NE.0) IHI=IHI+1
18914 DO 650 I=NSD(JT)+1,IHI
18916 I1=MINT(83)+MINT(4)+1
18918 IF(MSTP(128).GE.1) K(I,3)=ID
18919 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18923 K(I1,3)=IREF(IP,JT+3)
18932 C...If 3-body or 2-body with junction:
18933 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18934 C...If 3-body with junction:
18935 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18938 C...Do showering of two or three objects.
18940 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18941 IF(KFL3(JT).EQ.0) THEN
18942 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18944 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18947 c...For pT-ordered shower need set up first, especially colour tags.
18948 C...(Need to set up colour tags even if MSTP(71) = 0)
18949 ELSEIF(MINT(35).GE.2) THEN
18951 IF(KFL3(JT).NE.0) NPART=3
18955 PTPART(1)=0.5D0*P(ID,5)
18956 PTPART(2)=PTPART(1)
18957 PTPART(3)=PTPART(1)
18958 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18959 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18960 IF(MOTHER.LE.NSD(JT)) THEN
18961 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18964 MCT(NSD(JT)+1,1)=NCT
18968 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18969 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18970 IF(MOTHER.LE.NSD(JT)) THEN
18971 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18974 MCT(NSD(JT)+1,2)=NCT
18978 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18979 & KCQ2(JT).EQ.2)) THEN
18980 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18981 IF(MOTHER.LE.NSD(JT)) THEN
18982 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18985 MCT(NSD(JT)+2,1)=NCT
18989 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18990 & KCQ2(JT).EQ.2)) THEN
18991 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18992 IF(MOTHER.LE.NSD(JT)) THEN
18993 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18996 MCT(NSD(JT)+2,2)=NCT
19000 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
19001 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
19002 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
19003 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
19005 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
19006 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19007 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19008 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19010 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19013 IF(JT.EQ.1) NAFT1=N
19015 C...Check if decay products moved by shower.
19019 IF(NSHAFT.GT.NSHBEF) THEN
19020 IF(K(NSD1,1).GT.10) THEN
19021 DO 660 I=NSHBEF+1,NSHAFT
19022 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19025 IF(K(NSD2,1).GT.10) THEN
19026 DO 670 I=NSHBEF+1,NSHAFT
19027 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19028 & I.NE.NSD1) NSD2=I
19031 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19032 DO 680 I=NSHBEF+1,NSHAFT
19033 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19034 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19039 C...Store decay products for further treatment.
19044 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19048 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19049 IREF(NP,7)=K(IREF(IP,JT),2)
19050 IREF(NP,8)=IREF(IP,JT)
19054 C...Fill information for 2 -> 1 -> 2.
19055 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19056 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19057 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19063 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19064 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19065 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19066 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19067 VINT(47)=SQRT(VINT(48))
19070 C...Possibility of colour rearrangement in W+W- events.
19071 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19072 IAKF1=IABS(KFL1(1))
19073 IAKF2=IABS(KFL1(2))
19074 IAKF3=IABS(KFL2(1))
19075 IAKF4=IABS(KFL2(2))
19076 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19077 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19078 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19079 IF(MINT(51).NE.0) RETURN
19082 C...Loop back if needed.
19083 710 IF(IP.LT.NP) GOTO 170
19085 C...Boost back to standard frame.
19086 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19092 C*********************************************************************
19095 C...Initializes treatment of multiple interactions, selects kinematics
19096 C...of hardest interaction if low-pT physics included in run, and
19097 C...generates all non-hardest interactions.
19099 SUBROUTINE PYMULT(MMUL)
19101 C...Double precision and integer declarations.
19102 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19103 IMPLICIT INTEGER(I-N)
19104 INTEGER PYK,PYCHGE,PYCOMP
19106 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19107 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19108 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19109 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19110 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19111 COMMON/PYINT1/MINT(400),VINT(400)
19112 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19113 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19114 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19115 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19116 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19117 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19118 C...Local arrays and saved variables.
19119 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19120 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19121 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19122 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19124 C...Initialization of multiple interaction treatment.
19126 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19134 C...Loop over phase space points: xT2 choice in 20 bins.
19137 NMUL(IXT2)=MSTP(83)
19139 DO 110 ITRY=1,MSTP(83)
19140 RSCA=0.05D0*((21-IXT2)-PYR(0))
19141 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19142 XT2=MAX(0.01D0*VINT(149),XT2)
19145 C...Choose tau and y*. Calculate cos(theta-hat).
19146 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19147 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19148 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19150 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19156 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19157 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19158 CALL PYKMAP(2,MYST,PYR(0))
19159 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19161 C...Calculate differential cross-section.
19162 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19163 CALL PYSIGH(NCHN,SIGS)
19164 SIGM(IXT2)=SIGM(IXT2)+SIGS
19166 SIGSUM=SIGSUM+SIGM(IXT2)
19168 SIGSUM=SIGSUM/(20D0*MSTP(83))
19170 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19171 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19172 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19173 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19174 PARP(82)=0.9D0*PARP(82)
19175 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19179 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19180 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19182 C...Start iteration to find k factor.
19183 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19184 P83A=(1D0-PARP(83))**2
19185 P83B=2D0*PARP(83)*(1D0-PARP(83))
19187 CQ2I=1D0/PARP(84)**2
19188 CQ2R=2D0/(1D0+PARP(84)**2)
19196 130 IF(IIT.EQ.0) THEN
19198 ELSEIF(IIT.EQ.1) THEN
19201 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19204 C...Evaluate overlap integrals. Find where to divide the b range.
19205 IF(MSTP(82).EQ.2) THEN
19206 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19209 IF(MSTP(82).EQ.3) THEN
19211 ELSEIF(MSTP(82).EQ.4) THEN
19212 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19214 POWIP=MAX(0.4D0,PARP(83))
19215 RPWIP=2D0/POWIP-1D0
19216 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19226 IF(MSTP(82).EQ.3) THEN
19227 OV=EXP(-B**2)/PARU(2)
19228 ELSEIF(MSTP(82).EQ.4) THEN
19229 OV=(P83A*EXP(-MIN(50D0,B**2))+
19230 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19231 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19233 OV=EXP(-B**POWIP)/PARU(2)
19234 SO=SO+PARU(2)*B*DELTAB*OV
19236 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19237 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19238 SP=SP+PARU(2)*B*DELTAB*PACC
19239 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19240 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19241 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19243 BDIV=B+0.5D0*DELTAB
19245 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19247 YK=PARU(1)*XK*SO/SP
19249 C...Continue iteration until convergence.
19259 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19261 C...Store some results for subsequent use.
19269 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19270 PIK=(VNT146/VNT147)*YKE
19272 C...Find relative weight for low and high impact parameter.
19273 PLOWB=PARU(1)*BDIV**2
19274 IF(MSTP(82).EQ.3) THEN
19275 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19276 ELSEIF(MSTP(82).EQ.4) THEN
19277 S4A=P83A*EXP(-BDIV**2)
19278 S4B=P83B*EXP(-BDIV**2*CQ2R)
19279 S4C=P83C*EXP(-BDIV**2*CQ2I)
19280 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19281 ELSEIF(PARP(83).GE.1.999D0) THEN
19287 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19291 C...Initialize iteration in xT2 for hardest interaction.
19292 ELSEIF(MMUL.EQ.2) THEN
19296 IF(MSTP(82).LE.0) THEN
19297 ELSEIF(MSTP(82).EQ.1) THEN
19299 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19300 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19301 & VINT(317)/(VINT(318)*VINT(320))
19302 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19303 ELSEIF(MSTP(82).EQ.2) THEN
19305 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19306 & VINT(149)*(1D0+VINT(149))
19308 XC2=4D0*CKIN(3)**2/VINT(2)
19309 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19312 C...Select impact parameter for hardest interaction.
19313 IF(MSTP(82).LE.2) RETURN
19314 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19315 C...Treatment in low b region.
19317 B=BDIV*SQRT(PYR(0))
19318 IF(MSTP(82).EQ.3) THEN
19319 OV=EXP(-B**2)/PARU(2)
19320 ELSEIF(MSTP(82).EQ.4) THEN
19321 OV=(P83A*EXP(-MIN(50D0,B**2))+
19322 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19323 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19325 OV=EXP(-B**POWIP)/PARU(2)
19327 VINT(148)=OV/VNT147
19328 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19330 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19331 & VINT(149)*(1D0+VINT(149))
19333 C...Treatment in high b region.
19335 IF(MSTP(82).EQ.3) THEN
19336 B=SQRT(BDIV**2-LOG(PYR(0)))
19337 OV=EXP(-B**2)/PARU(2)
19338 ELSEIF(MSTP(82).EQ.4) THEN
19339 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19340 IF(S4RNDM.LT.S4A) THEN
19341 B=SQRT(BDIV**2-LOG(PYR(0)))
19342 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19343 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19345 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19347 OV=(P83A*EXP(-MIN(50D0,B**2))+
19348 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19349 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19350 ELSEIF(PARP(83).GE.1.999D0) THEN
19351 144 B2RPW=B2RPDV-LOG(PYR(0))
19352 ACCIP=(B2RPW/B2RPDV)**RPWIP
19353 IF(ACCIP.LT.PYR(0)) GOTO 144
19354 OV=EXP(-B2RPW)/PARU(2)
19355 B=B2RPW**(1D0/POWIP)
19357 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19358 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19359 IF(ACCIP.LT.PYR(0)) GOTO 146
19360 OV=EXP(-B2RPW)/PARU(2)
19361 B=B2RPW**(1D0/POWIP)
19363 VINT(148)=OV/VNT147
19364 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19366 IF(PACC.LT.PYR(0)) GOTO 142
19369 ELSEIF(MMUL.EQ.3) THEN
19370 C...Low-pT or multiple interactions (first semihard interaction):
19371 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19372 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19377 IF(MSTP(82).LE.0) THEN
19379 ELSEIF(MSTP(82).EQ.1) THEN
19380 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19381 C...Use with "Sudakov" for low b values when impact parameter dependence.
19382 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19383 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19384 & VINT(149)))).GT.PYR(0)) XT2=1D0
19385 IF(XT2.GE.1D0) THEN
19386 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19387 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19390 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19391 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19394 XT2=MAX(0.01D0*VINT(149),XT2)
19395 C...Use without "Sudakov" for high b values when impact parameter dep.
19397 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19398 & PYR(0)*(1D0-XC2))-VINT(149)
19399 XT2=MAX(0.01D0*VINT(149),XT2)
19403 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19404 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19405 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19406 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19409 VINT(21)=0.01D0*VINT(149)
19412 VINT(25)=0.01D0*VINT(149)
19415 C...Multiple interactions (first semihard interaction).
19416 C...Choose tau and y*. Calculate cos(theta-hat).
19417 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19418 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19419 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19421 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19427 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19428 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19429 CALL PYKMAP(2,MYST,PYR(0))
19430 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19432 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19434 C...Store results of cross-section calculation.
19435 ELSEIF(MMUL.EQ.4) THEN
19441 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19442 IF(ISET(ISUB).EQ.2)
19443 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19444 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19445 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19446 & (XTS+VINT(149))))
19447 IRBIN=INT(1D0+20D0*RBIN)
19448 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19449 NMUL(IRBIN)=NMUL(IRBIN)+1
19450 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19453 C...Choose impact parameter if not already done.
19454 ELSEIF(MMUL.EQ.5) THEN
19459 150 IF(MINT(39).GT.0) THEN
19460 ELSEIF(MSTP(82).EQ.3) THEN
19463 VINT(148)=EXPB2/(PARU(2)*VNT147)
19464 VINT(139)=SQRT(B2)/BAVG
19465 ELSEIF(MSTP(82).EQ.4) THEN
19467 IF(RTYPE.LT.P83A) THEN
19469 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19470 B2=-LOG(PYR(0))/CQ2R
19472 B2=-LOG(PYR(0))/CQ2I
19474 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19475 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19476 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19477 VINT(139)=SQRT(B2)/BAVG
19478 ELSEIF(PARP(83).GE.1.999D0) THEN
19479 POWIP=MAX(2D0,PARP(83))
19480 RPWIP=2D0/POWIP-1D0
19481 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19482 160 IF(PYR(0).LT.PROB1) THEN
19483 B2RPW=PYR(0)**(0.5D0*POWIP)
19486 B2RPW=1D0-LOG(PYR(0))
19489 IF(ACCIP.LT.PYR(0)) GOTO 160
19490 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19491 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19493 POWIP=MAX(0.4D0,PARP(83))
19494 RPWIP=2D0/POWIP-1D0
19495 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19496 170 IF(PYR(0).LT.PROB1) THEN
19497 B2RPW=2D0*RPWIP*PYR(0)
19498 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19500 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19501 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19503 IF(ACCIP.LT .PYR(0)) GOTO 170
19504 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19505 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19508 C...Multiple interactions (variable impact parameter) : reject with
19509 C...probability exp(-overlap*cross-section above pT/normalization).
19510 C...Does not apply to low-b region, where "Sudakov" already included.
19512 IF(MINT(39).NE.1) THEN
19513 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19514 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19515 DO 180 IBIN=IRBIN+1,20
19516 RNCOR=RNCOR+NMUL(IBIN)
19517 SIGCOR=SIGCOR+SIGM(IBIN)
19519 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19520 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19521 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19522 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19524 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19525 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19526 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19527 IF(VINT(150).LT.PYR(0)) GOTO 150
19531 C...Generate additional multiple semihard interactions.
19532 ELSEIF(MMUL.EQ.6) THEN
19545 C...Reconstruct strings in hard scattering.
19547 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
19548 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
19550 DO 210 I=MINT(84)+1,NMAX
19551 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
19552 IF(KCS.EQ.0) GOTO 210
19554 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
19555 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
19557 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
19559 IST=MOD(K(I,J+1),MSTU(5))
19561 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
19562 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
19564 IF(J.EQ.1.OR.J.EQ.4) THEN
19574 C...Set up starting values for iteration in xT2.
19575 XT2=4D0*VINT(62)/VINT(2)
19576 IF(MSTP(82).LE.1) THEN
19577 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19578 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19579 & VINT(317)/(VINT(318)*VINT(320))
19580 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19582 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19583 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19587 VINT(143)=1D0-VINT(141)
19588 VINT(144)=1D0-VINT(142)
19590 C...Iterate downwards in xT2.
19591 220 IF(MSTP(82).LE.1) THEN
19592 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19593 IF(XT2.LT.VINT(149)) GOTO 270
19595 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
19596 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19597 & LOG(PYR(0)))-VINT(149)
19598 IF(XT2.LE.0D0) GOTO 270
19599 XT2=MAX(0.01D0*VINT(149),XT2)
19603 C...Choose tau and y*. Calculate cos(theta-hat).
19604 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19605 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19606 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19608 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19614 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19615 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19616 CALL PYKMAP(2,MYST,PYR(0))
19617 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19619 C...Check that x not used up. Accept or reject kinematical variables.
19620 X1M=SQRT(TAU)*EXP(VINT(22))
19621 X2M=SQRT(TAU)*EXP(-VINT(22))
19622 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19623 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19624 CALL PYSIGH(NCHN,SIGS)
19625 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19626 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19628 C...Reset K, P and V vectors. Select some variables.
19637 PT=0.5D0*VINT(1)*SQRT(XT2)
19641 C...Add first parton to event record.
19644 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19645 & 1+INT((2D0+PARJ(2))*PYR(0))
19646 P(N+1,1)=PT*COS(PHI)
19647 P(N+1,2)=PT*SIN(PHI)
19648 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19649 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19652 C...Add second parton to event record.
19655 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19658 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19659 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19662 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19663 C....Choose relevant string pieces to place gluons on.
19669 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19670 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19671 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19672 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19673 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19681 C....Colour flow adjustments, new string pieces.
19682 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19683 & MOD(K(IST1,4),MSTU(5))
19684 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19685 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19686 K(I,5)=MSTU(5)*IST1
19687 K(I,4)=MSTU(5)*IST2
19688 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19689 & MOD(K(IST2,5),MSTU(5))
19690 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19691 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19694 KSTR(NSTR+1,2)=IST2
19698 C...String drawing and colour flow for gluon loop.
19699 ELSEIF(K(N+1,2).EQ.21) THEN
19700 K(N+1,4)=MSTU(5)*(N+2)
19701 K(N+1,5)=MSTU(5)*(N+2)
19702 K(N+2,4)=MSTU(5)*(N+1)
19703 K(N+2,5)=MSTU(5)*(N+1)
19710 C...String drawing and colour flow for qqbar pair.
19712 K(N+1,4)=MSTU(5)*(N+2)
19713 K(N+2,5)=MSTU(5)*(N+1)
19719 C...Global statistics.
19720 MINT(351)=MINT(351)+1
19721 VINT(351)=VINT(351)+PT
19722 IF (MINT(351).EQ.1) VINT(356)=PT
19724 C...Update remaining energy; iterate.
19726 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19727 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19731 MINT(31)=MINT(31)+1
19732 VINT(151)=VINT(151)+VINT(41)
19733 VINT(152)=VINT(152)+VINT(42)
19734 VINT(143)=VINT(143)-VINT(41)
19735 VINT(144)=VINT(144)-VINT(42)
19736 C...Allow FSR for UE (always handle with old showers)
19737 IF(MSTP(152).EQ.1) THEN
19739 IF (MSTJ(41).EQ.10) MSTJ(41)=2
19740 MSTJ(41)=MOD(MSTJ(41),10)
19741 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19744 IF(MINT(31).LT.240) GOTO 220
19752 C...Format statements for printout.
19753 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19754 &'actions for MSTP(82) =',I2,' ******')
19755 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19756 &D9.2,' mb: rejected')
19757 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19758 &D9.2,' mb: accepted')
19763 C*********************************************************************
19766 C...Adds on target remnants (one or two from each side) and
19767 C...includes primordial kT for hadron beams.
19769 SUBROUTINE PYREMN(IPU1,IPU2)
19771 C...Double precision and integer declarations.
19772 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19773 IMPLICIT INTEGER(I-N)
19774 INTEGER PYK,PYCHGE,PYCOMP
19776 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19777 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19778 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19779 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19780 COMMON/PYINT1/MINT(400),VINT(400)
19781 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19783 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19784 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19786 C...Find event type and remaining energy.
19789 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19790 VINT(143)=1D0-VINT(141)
19791 VINT(144)=1D0-VINT(142)
19794 C...Define initial partons.
19799 IF(JT.EQ.1) IPU=IPU1
19800 IF(JT.EQ.2) IPU=IPU2
19807 IF(MINT(47).EQ.1) THEN
19811 ELSEIF(ISUB.EQ.95) THEN
19816 C...No primordial kT, or chosen according to truncated Gaussian or
19817 C...exponential, or (for photon) predetermined or power law.
19818 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19819 IF(MSTP(91).LE.0) THEN
19821 ELSEIF(MSTP(91).EQ.1) THEN
19822 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19826 PT=-PARP(92)*LOG(RPT1*RPT2)
19828 IF(PT.GT.PARP(93)) GOTO 120
19829 ELSEIF(MINT(106+JT).EQ.3) THEN
19830 PTA=SQRT(VINT(282+JT))
19832 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19833 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19834 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19837 PTB=-PARP(99)*LOG(RPT1*RPT2)
19839 IF(PTB.GT.PARP(100)) GOTO 120
19840 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19841 PT=PT*0.8D0**MINT(57)
19842 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19843 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19844 IF(MSTP(93).LE.0) THEN
19846 ELSEIF(MSTP(93).EQ.1) THEN
19847 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19848 ELSEIF(MSTP(93).EQ.2) THEN
19851 PT=-PARP(99)*LOG(RPT1*RPT2)
19852 ELSEIF(MSTP(93).EQ.3) THEN
19855 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19859 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19860 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19862 IF(PT.GT.PARP(100)) GOTO 120
19870 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19873 IF(MINT(47).EQ.1) RETURN
19875 C...Kinematics construction for initial partons.
19878 IF(ISUB.EQ.95) THEN
19882 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19883 & (P(I1,2)+P(I2,2))**2
19884 SHR=SQRT(MAX(0D0,SHS))
19885 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19886 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19887 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19888 P(I2,4)=SHR-P(I1,4)
19891 C...Transform partons to overall CM-frame.
19892 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19893 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19894 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19895 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19896 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19897 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19898 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19899 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19900 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19901 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19902 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19905 C...Optionally fix up x and Q2 definitions for leptoproduction.
19907 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19908 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19909 IF(IDISXQ.EQ.1) THEN
19911 C...Find where incoming and outgoing leptons/partons are sitting.
19913 IF(MINT(42).EQ.1) LESD=2
19914 LPIN=MINT(83)+3-LESD
19916 LQIN=MINT(84)+3-LESD
19917 LEOUT=MINT(84)+2+LESD
19918 LQOUT=MINT(84)+5-LESD
19919 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19920 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19922 DO 140 I=MINT(84)+5,N
19923 IF(K(I,2).EQ.94) THEN
19930 IF(LESD.EQ.1) LQBG=IPU2
19932 C...Calculate actual and wanted momentum transfer.
19935 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19936 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19937 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19938 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19939 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19940 P(N+1,1)=FAC*P(LEOUT,1)
19941 P(N+1,2)=FAC*P(LEOUT,2)
19942 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19943 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19944 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19947 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19948 QNEW(J)=P(LEIN,J)-P(N+1,J)
19951 C...Boost outgoing electron and daughters.
19952 IF(LSCMS.EQ.0) THEN
19954 P(LEOUT,J)=P(N+1,J)
19958 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19960 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19962 DBE(J)=PINV*P(N+2,J)
19966 190 IORIG=K(IORIG,3)
19967 IF(IORIG.GT.LEOUT) GOTO 190
19968 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19969 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19973 C...Copy shower initiator and all outgoing partons.
19977 P(NCOP,J)=P(LQBG,J)
19979 DO 240 I=MINT(84)+1,N
19981 IF(K(I,1).GT.10) GOTO 240
19982 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19986 220 IORIG=K(IORIG,3)
19987 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19989 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
20002 C...Calculate relative rescaling factors.
20006 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20009 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20012 C...Transfer extra three-momentum of current.
20015 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20017 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20020 C...Iterate change of initiator momentum to get energy right.
20023 PEEX=-P(N+1,4)-QNEW(4)
20024 PEMV=-P(N+1,3)/P(N+1,4)
20027 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20029 IF(ABS(PEMV).LT.1D-10) THEN
20031 MINT(57)=MINT(57)+1
20035 P(N+1,3)=P(N+1,3)+PZCH
20036 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)
20038 P(I,3)=P(I,3)+V(I,1)*PZCH
20039 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20041 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20043 C...Modify momenta in event record.
20044 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20045 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20046 IF(ABS(HBE).GE.1D0) THEN
20048 MINT(57)=MINT(57)+1
20052 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20061 C...Check minimum invariant mass of remnant system(s).
20062 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20063 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20064 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20065 PMIN(0)=SQRT(PMS(0))
20067 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20068 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20070 IF(MINT(44+JT).EQ.1) GOTO 340
20071 MINT(105)=MINT(102+JT)
20072 MINT(109)=MINT(106+JT)
20073 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20074 IF(MINT(51).NE.0) THEN
20075 MINT(57)=MINT(57)+1
20078 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20079 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20080 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20081 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20082 & P(MINT(83)+JT+2,2)**2)
20084 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20085 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20088 MINT(57)=MINT(57)+1
20092 C...Loop over two remnants; skip if none there.
20096 IF(MINT(44+JT).EQ.1) GOTO 410
20097 IF(JT.EQ.1) IPU=IPU1
20098 IF(JT.EQ.2) IPU=IPU2
20100 C...Store first remnant parton.
20112 P(I,5)=PYMASS(K(I,2))
20114 C...First parton colour connections and kinematics.
20115 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20118 K(I,4)=MSTU(5)*IPU+IPU
20119 K(I,5)=MSTU(5)*IPU+IPU
20120 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20121 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20122 ELSEIF(KCOL.NE.0) THEN
20124 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20126 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20128 IF(KFLCH(JT).EQ.0) THEN
20129 P(I,1)=-P(MINT(83)+JT+2,1)
20130 P(I,2)=-P(MINT(83)+JT+2,2)
20131 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20132 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20136 C...When extra remnant parton or hadron: store extra remnant.
20148 P(I,5)=PYMASS(K(I,2))
20150 C...Find parton colour connections of extra remnant.
20151 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20154 K(I,4)=MSTU(5)*IPU+IPU
20155 K(I,5)=MSTU(5)*IPU+IPU
20156 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20157 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20158 ELSEIF(KCOL.NE.0) THEN
20160 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20162 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20165 C...Relative transverse momentum when two remnants.
20168 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20169 IF(IABS(MINT(10+JT)).LT.20) THEN
20173 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20174 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20176 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20177 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20178 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20179 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20181 C...Meson or baryon; photon as meson. For splitup below.
20183 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20185 C***Relative distribution for electron into two electrons. Temporary!
20186 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20190 C...Relative distribution of electron energy into electron plus parton.
20191 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20194 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20196 C...Relative distribution of energy for particle into two jets.
20197 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20198 CHIK=PARP(92+2*IMB)
20199 IF(MSTP(92).LE.1) THEN
20200 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20201 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20202 ELSEIF(MSTP(92).EQ.2) THEN
20203 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20204 ELSEIF(MSTP(92).EQ.3) THEN
20205 CUT=2D0*0.3D0/VINT(1)
20206 380 CHI(JT)=PYR(0)**2
20207 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20208 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20209 ELSEIF(MSTP(92).EQ.4) THEN
20210 CUT=2D0*0.3D0/VINT(1)
20211 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20212 390 CHIR=CUT*CUTR**PYR(0)
20213 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20214 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20216 CUT=2D0*0.3D0/VINT(1)
20217 CUTA=CUT**(1D0-PARP(98))
20218 CUTB=(1D0+CUT)**(1D0-PARP(98))
20219 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20220 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20221 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20224 C...Relative distribution of energy for particle into jet plus particle.
20226 IF(MSTP(94).LE.1) THEN
20227 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20228 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20229 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20230 ELSEIF(MSTP(94).EQ.2) THEN
20231 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20232 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20233 ELSEIF(MSTP(94).EQ.3) THEN
20234 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20237 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20242 C...Construct total transverse mass; reject if too large.
20243 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20244 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20245 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20246 IF(LOOP.LT.100) THEN
20250 MINT(57)=MINT(57)+1
20254 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20255 VINT(158+JT)=CHI(JT)
20257 C...Subdivide longitudinal momentum according to value selected above.
20258 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20259 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20260 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20261 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20262 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20267 C...Check if longitudinal boosts needed - if so pick two systems.
20268 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20269 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20270 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20271 IF(ISN(1).EQ.0) THEN
20274 ELSEIF(ISN(2).EQ.0) THEN
20277 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20280 ELSEIF(VINT(143).GT.0.2D0) THEN
20283 ELSEIF(VINT(144).GT.0.2D0) THEN
20286 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20295 C...E+-pL wanted for system to be modified.
20296 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20300 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20301 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20304 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20305 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20306 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20307 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20311 DO 450 I=MINT(84)+1,NS
20312 IF(K(I,1).GT.10) GOTO 450
20315 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20317 IF(IORIG.GT.LPIN) GOTO 430
20318 IF(INCL.EQ.0) GOTO 450
20320 PSYS(0,J)=PSYS(0,J)+P(I,J)
20323 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20324 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20325 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20328 C...Construct longitudinal boosts.
20332 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20333 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20335 MINT(57)=MINT(57)+1
20338 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20339 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20340 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20341 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20342 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20343 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20344 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20346 C...Perform longitudinal boosts.
20347 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20349 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20350 ELSEIF(IR.EQ.1) THEN
20351 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20352 ELSEIF(IDISXQ.EQ.1) THEN
20356 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20358 IF(IORIG.GT.LPIN) GOTO 460
20359 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20362 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20364 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20366 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20367 ELSEIF(IL.EQ.2) THEN
20368 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20369 ELSEIF(IDISXQ.EQ.1) THEN
20373 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20375 IF(IORIG.GT.LPIN) GOTO 480
20376 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20379 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20382 C...Final check that energy-momentum conservation worked.
20385 DO 500 I=MINT(84)+1,N
20386 IF(K(I,1).GT.10) GOTO 500
20390 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20391 IF(PDEV.GT.1D-4*VINT(1)) THEN
20393 MINT(57)=MINT(57)+1
20397 C...Calculate rotation and boost from overall CM frame to
20398 C...hadronic CM frame in leptoproduction.
20400 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20403 IF(MINT(42).EQ.1) LESD=2
20404 LPIN=MINT(83)+3-LESD
20406 C...Sum upp momenta of everything not lepton or photon to define boost.
20411 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20412 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20413 IF(K(I,2).EQ.22) GOTO 530
20415 PSUM(J)=PSUM(J)+P(I,J)
20418 VINT(223)=-PSUM(1)/PSUM(4)
20419 VINT(224)=-PSUM(2)/PSUM(4)
20420 VINT(225)=-PSUM(3)/PSUM(4)
20422 C...Boost incoming hadron to hadronic CM frame to determine rotations.
20428 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20429 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20430 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20432 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20434 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20441 C*********************************************************************
20444 C...Initializes treatment of new multiple interactions scenario,
20445 C...selects kinematics of hardest interaction if low-pT physics
20446 C...included in run, and generates all non-hardest interactions.
20448 SUBROUTINE PYMIGN(MMUL)
20450 C...Double precision and integer declarations.
20451 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20452 IMPLICIT INTEGER(I-N)
20453 INTEGER PYK,PYCHGE,PYCOMP
20455 DOUBLE PRECISION PYALPS
20457 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20458 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20459 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20460 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20461 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20462 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20463 COMMON/PYINT1/MINT(400),VINT(400)
20464 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20465 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20466 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20467 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20468 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20469 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20470 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20471 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20472 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20473 C...Local arrays and saved variables.
20474 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20475 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20476 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20477 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20478 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20480 C...Initialization of multiple interaction treatment.
20482 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20490 C...Loop over phase space points: xT2 choice in 20 bins.
20493 NMUL(IXT2)=MSTP(83)
20495 DO 110 ITRY=1,MSTP(83)
20496 RSCA=0.05D0*((21-IXT2)-PYR(0))
20497 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20498 XT2=MAX(0.01D0*VINT(149),XT2)
20501 C...Choose tau and y*. Calculate cos(theta-hat).
20502 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20503 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20504 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20506 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20512 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20513 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20514 CALL PYKMAP(2,MYST,PYR(0))
20515 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20517 C...Calculate differential cross-section.
20518 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20519 CALL PYSIGH(NCHN,SIGS)
20520 SIGM(IXT2)=SIGM(IXT2)+SIGS
20522 SIGSUM=SIGSUM+SIGM(IXT2)
20524 SIGSUM=SIGSUM/(20D0*MSTP(83))
20526 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20527 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
20528 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
20529 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
20530 PARP(82)=0.9D0*PARP(82)
20531 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
20535 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
20536 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
20538 C...Start iteration to find k factor.
20539 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
20540 P83A=(1D0-PARP(83))**2
20541 P83B=2D0*PARP(83)*(1D0-PARP(83))
20543 CQ2I=1D0/PARP(84)**2
20544 CQ2R=2D0/(1D0+PARP(84)**2)
20552 130 IF(IIT.EQ.0) THEN
20554 ELSEIF(IIT.EQ.1) THEN
20557 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
20560 C...Evaluate overlap integrals. Find where to divide the b range.
20561 IF(MSTP(82).EQ.2) THEN
20562 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
20565 IF(MSTP(82).EQ.3) THEN
20567 ELSEIF(MSTP(82).EQ.4) THEN
20568 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
20570 POWIP=MAX(0.4D0,PARP(83))
20571 RPWIP=2D0/POWIP-1D0
20572 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
20582 IF(MSTP(82).EQ.3) THEN
20583 OV=EXP(-B**2)/PARU(2)
20584 ELSEIF(MSTP(82).EQ.4) THEN
20585 OV=(P83A*EXP(-MIN(50D0,B**2))+
20586 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20587 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20589 OV=EXP(-B**POWIP)/PARU(2)
20590 SO=SO+PARU(2)*B*DELTAB*OV
20592 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
20593 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
20594 SP=SP+PARU(2)*B*DELTAB*PACC
20595 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
20596 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
20597 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
20599 BDIV=B+0.5D0*DELTAB
20601 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
20603 YK=PARU(1)*XK*SO/SP
20605 C...Continue iteration until convergence.
20615 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
20617 C...Store some results for subsequent use.
20625 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20626 PIK=(VNT146/VNT147)*YKE
20628 C...Find relative weight for low and high impact parameter..
20629 PLOWB=PARU(1)*BDIV**2
20630 IF(MSTP(82).EQ.3) THEN
20631 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20632 ELSEIF(MSTP(82).EQ.4) THEN
20633 S4A=P83A*EXP(-BDIV**2)
20634 S4B=P83B*EXP(-BDIV**2*CQ2R)
20635 S4C=P83C*EXP(-BDIV**2*CQ2I)
20636 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20637 ELSEIF(PARP(83).GE.1.999D0) THEN
20643 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20647 C...Initialize iteration in xT2 for hardest interaction.
20648 ELSEIF(MMUL.EQ.2) THEN
20652 IF(MSTP(82).LE.0) THEN
20653 ELSEIF(MSTP(82).EQ.1) THEN
20655 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20656 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20657 & VINT(317)/(VINT(318)*VINT(320))
20658 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20659 ELSEIF(MSTP(82).EQ.2) THEN
20661 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20662 & VINT(149)*(1D0+VINT(149))
20664 XC2=4D0*CKIN(3)**2/VINT(2)
20665 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20668 C...Select impact parameter for hardest interaction.
20669 IF(MSTP(82).LE.2) RETURN
20670 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20671 C...Treatment in low b region.
20673 B=BDIV*SQRT(PYR(0))
20674 IF(MSTP(82).EQ.3) THEN
20675 OV=EXP(-B**2)/PARU(2)
20676 ELSEIF(MSTP(82).EQ.4) THEN
20677 OV=(P83A*EXP(-MIN(50D0,B**2))+
20678 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20679 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20681 OV=EXP(-B**POWIP)/PARU(2)
20683 VINT(148)=OV/VNT147
20684 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20686 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20687 & VINT(149)*(1D0+VINT(149))
20689 C...Treatment in high b region.
20691 IF(MSTP(82).EQ.3) THEN
20692 B=SQRT(BDIV**2-LOG(PYR(0)))
20693 OV=EXP(-B**2)/PARU(2)
20694 ELSEIF(MSTP(82).EQ.4) THEN
20695 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20696 IF(S4RNDM.LT.S4A) THEN
20697 B=SQRT(BDIV**2-LOG(PYR(0)))
20698 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20699 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20701 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20703 OV=(P83A*EXP(-MIN(50D0,B**2))+
20704 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20705 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20706 ELSEIF(PARP(83).GE.1.999D0) THEN
20707 144 B2RPW=B2RPDV-LOG(PYR(0))
20708 ACCIP=(B2RPW/B2RPDV)**RPWIP
20709 IF(ACCIP.LT.PYR(0)) GOTO 144
20710 OV=EXP(-B2RPW)/PARU(2)
20711 B=B2RPW**(1D0/POWIP)
20713 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20714 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20715 IF(ACCIP.LT.PYR(0)) GOTO 146
20716 OV=EXP(-B2RPW)/PARU(2)
20717 B=B2RPW**(1D0/POWIP)
20719 VINT(148)=OV/VNT147
20720 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20722 IF(PACC.LT.PYR(0)) GOTO 142
20725 ELSEIF(MMUL.EQ.3) THEN
20726 C...Low-pT or multiple interactions (first semihard interaction):
20727 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20728 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20733 IF(MSTP(82).LE.0) THEN
20735 ELSEIF(MSTP(82).EQ.1) THEN
20736 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20737 C...Use with "Sudakov" for low b values when impact parameter dependence.
20738 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20739 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20740 & VINT(149)))).GT.PYR(0)) XT2=1D0
20741 IF(XT2.GE.1D0) THEN
20742 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20743 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20746 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20747 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20750 XT2=MAX(0.01D0*VINT(149),XT2)
20751 C...Use without "Sudakov" for high b values when impact parameter dep.
20753 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20754 & PYR(0)*(1D0-XC2))-VINT(149)
20755 XT2=MAX(0.01D0*VINT(149),XT2)
20759 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20760 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20761 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20762 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20765 VINT(21)=1D-12*VINT(149)
20768 VINT(25)=1D-12*VINT(149)
20771 C...Multiple interactions (first semihard interaction).
20772 C...Choose tau and y*. Calculate cos(theta-hat).
20773 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20774 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20775 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20777 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20783 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20784 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20785 CALL PYKMAP(2,MYST,PYR(0))
20786 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20788 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20790 C...Store results of cross-section calculation.
20791 ELSEIF(MMUL.EQ.4) THEN
20797 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20798 IF(ISET(ISUB).EQ.2)
20799 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20800 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20801 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20802 & (XTS+VINT(149))))
20803 IRBIN=INT(1D0+20D0*RBIN)
20804 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20805 NMUL(IRBIN)=NMUL(IRBIN)+1
20806 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20809 C...Choose impact parameter if not already done.
20810 ELSEIF(MMUL.EQ.5) THEN
20815 150 IF(MINT(39).GT.0) THEN
20816 ELSEIF(MSTP(82).EQ.3) THEN
20819 VINT(148)=EXPB2/(PARU(2)*VNT147)
20820 VINT(139)=SQRT(B2)/BAVG
20821 ELSEIF(MSTP(82).EQ.4) THEN
20823 IF(RTYPE.LT.P83A) THEN
20825 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20826 B2=-LOG(PYR(0))/CQ2R
20828 B2=-LOG(PYR(0))/CQ2I
20830 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20831 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20832 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20833 VINT(139)=SQRT(B2)/BAVG
20834 ELSEIF(PARP(83).GE.1.999D0) THEN
20835 POWIP=MAX(2D0,PARP(83))
20836 RPWIP=2D0/POWIP-1D0
20837 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20838 160 IF(PYR(0).LT.PROB1) THEN
20839 B2RPW=PYR(0)**(0.5D0*POWIP)
20842 B2RPW=1D0-LOG(PYR(0))
20845 IF(ACCIP.LT.PYR(0)) GOTO 160
20846 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20847 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20849 POWIP=MAX(0.4D0,PARP(83))
20850 RPWIP=2D0/POWIP-1D0
20851 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20852 170 IF(PYR(0).LT.PROB1) THEN
20853 B2RPW=2D0*RPWIP*PYR(0)
20854 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20856 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20857 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20859 IF(ACCIP.LT .PYR(0)) GOTO 170
20860 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20861 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20864 C...Multiple interactions (variable impact parameter) : reject with
20865 C...probability exp(-overlap*cross-section above pT/normalization).
20866 C...Does not apply to low-b region, where "Sudakov" already included.
20868 IF(MINT(39).NE.1) THEN
20869 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20870 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20871 DO 180 IBIN=IRBIN+1,20
20872 RNCOR=RNCOR+NMUL(IBIN)
20873 SIGCOR=SIGCOR+SIGM(IBIN)
20875 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20876 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20877 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20878 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20880 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20881 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20882 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20883 IF(VINT(150).LT.PYR(0)) GOTO 150
20887 C...Generate additional multiple semihard interactions.
20888 ELSEIF(MMUL.EQ.6) THEN
20890 C...Save data for hardest initeraction, to be restored.
20907 C...Store data on hardest interaction.
20914 C...Change process to generate; sum of x values so far.
20917 VINT(143)=1D0-VINT(141)
20918 VINT(144)=1D0-VINT(142)
20922 C...Initialize factors for PDF reshaping.
20926 KFSBM=ISIGN(1,KFBEAM)
20928 C...Zero flavour content of incoming beam particle.
20932 C...Flavour content of baryon.
20933 IF(KFABM.GT.1000) THEN
20934 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20935 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20936 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20937 C...Flavour content of pi+-, K+-.
20938 ELSEIF(KFABM.EQ.211) THEN
20939 KFIVAL(JS,1)=KFSBM*2
20940 KFIVAL(JS,2)=-KFSBM
20941 ELSEIF(KFABM.EQ.321) THEN
20942 KFIVAL(JS,1)=-KFSBM*3
20943 KFIVAL(JS,2)=KFSBM*2
20944 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20947 C...Zero initial valence and companion content.
20952 C...Initiate listing of all incoming partons from two sides.
20954 DO 210 I=MINT(84)+1,N
20955 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20961 C...Decide whether quarks in hard scattering were valence or sea.
20962 IFL=K(IMI(JS,1,1),2)
20963 IF (IABS(IFL).GT.6) GOTO 230
20965 C...Get PDFs at X and Q2 of the parton shower initiator for the
20966 C...hard scattering.
20968 IF(MSTP(61).GE.1) THEN
20973 C...Note: XPSVC = x*pdf.
20976 C.... Store side in MINT(124)
20979 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20983 C...Decide (Extra factor x cancels in the division).
20984 RVCS=PYR(0)*(SEA+VAL)
20986 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20987 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20989 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20990 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20991 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20992 IF(KFIVAL(JS,1).EQ.0) THEN
20993 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20994 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20995 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20996 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20998 IF(IVNOW.EQ.0) GOTO 220
21001 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21002 IF(KFIVAL(JS,1).EQ.0) THEN
21003 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21006 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21008 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21009 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21013 C...If sea, add opposite sign companion parton. Store X and I.
21015 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21016 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21017 C...Set pointer to companion
21018 IMI(JS,1,2)=-NVC(JS,-IFL)
21022 C...Update counter number of multiple interactions.
21026 C...Set up starting values for iteration in xT2.
21027 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21028 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21029 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21030 & ISUBSV.NE.96)) THEN
21031 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21034 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21035 IF(ISET(ISUBSV).EQ.2)
21036 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21037 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21039 IF(MSTP(82).LE.1) THEN
21040 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21041 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21042 & VINT(317)/(VINT(318)*VINT(320))
21043 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21045 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21046 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21051 C...Iterate downwards in xT2.
21052 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21055 ELSEIF(MSTP(82).LE.1) THEN
21056 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21057 IF(XT2.LT.VINT(149)) GOTO 440
21059 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21060 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21061 & LOG(PYR(0)))-VINT(149)
21062 IF(XT2.LE.0D0) GOTO 440
21063 XT2=MAX(0.01D0*VINT(149),XT2)
21067 C...Choose tau and y*. Calculate cos(theta-hat).
21068 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21069 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21070 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21072 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21075 C...New: require shat > 1.
21076 IF(TAU*VINT(2).LT.1D0) GOTO 240
21080 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21081 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21082 CALL PYKMAP(2,MYST,PYR(0))
21083 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21085 C...Check that x not used up. Accept or reject kinematical variables.
21086 X1M=SQRT(TAU)*EXP(VINT(22))
21087 X2M=SQRT(TAU)*EXP(-VINT(22))
21088 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21089 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21090 CALL PYSIGH(NCHN,SIGS)
21091 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21092 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21093 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21095 C...Reset K, P and V vectors.
21103 PT=0.5D0*VINT(1)*SQRT(XT2)
21105 C...Choose flavour of reacting partons (and subprocess).
21110 ICONMI=ISIG(ICHN,3)
21111 RSIGS=RSIGS-SIGH(ICHN)
21112 IF(RSIGS.LE.0D0) GOTO 280
21115 C...Reassign to appropriate process codes.
21116 280 ISUBMI=ICONMI/10
21117 ICONMI=MOD(ICONMI,10)
21119 C...Choose new quark flavour for annihilation graphs
21120 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21122 CALL PYWIDT(21,SH,WDTP,WDTE)
21123 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21124 DO 300 I=1,MDCY(21,3)
21125 KFLF=KFDP(I+MDCY(21,2)-1,1)
21126 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21127 IF(RKFL.LE.0D0) GOTO 310
21129 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21130 IF(KFLF.GE.4) GOTO 290
21131 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21134 ELSEIF(ISUBMI.EQ.53) THEN
21140 C...Final state flavours and colour flow: default values
21147 IF(ISUBMI.EQ.11) THEN
21148 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21150 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21152 ELSEIF(ISUBMI.EQ.12) THEN
21153 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21154 KFL3=ISIGN(KFLF,KFL1)
21158 ELSEIF(ISUBMI.EQ.13) THEN
21159 C...f + fbar -> g + g; th arbitrary
21164 ELSEIF(ISUBMI.EQ.28) THEN
21165 C...f + g -> f + g; th = (p(f)-p(f))**2
21166 IF(KFL1.EQ.21) JS=2
21168 IF(KFL1.EQ.21) KCC=KCC+2
21169 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21170 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21172 ELSEIF(ISUBMI.EQ.53) THEN
21173 C...g + g -> f + fbar; th arbitrary
21174 KCS=(-1)**INT(1.5D0+PYR(0))
21175 KFL3=ISIGN(KFLF,KCS)
21179 ELSEIF(ISUBMI.EQ.68) THEN
21180 C...g + g -> g + g; th arbitrary
21182 KCS=(-1)**INT(1.5D0+PYR(0))
21185 C...Store flavours of scattering.
21193 C...Set flavours and mothers of scattering partons.
21202 K(N+1,3)=MINT(83)+1
21203 K(N+2,3)=MINT(83)+2
21207 C...Store colour connection indices.
21210 IF(KCS.EQ.-1) JC=3-J
21211 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21212 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21213 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21214 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21217 C...Store incoming and outgoing partons in their CM-frame.
21218 SHR=SQRT(TAU)*VINT(1)
21221 P(N+2,3)=-0.5D0*SHR
21223 P(N+3,5)=PYMASS(K(N+3,2))
21224 P(N+4,5)=PYMASS(K(N+4,2))
21225 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21226 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21227 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21228 P(N+4,4)=SHR-P(N+3,4)
21231 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21233 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21235 C...Set up default values before showers.
21236 MINT(31)=MINT(31)+1
21245 C...Showering of initial state partons (optional).
21246 C...Note: no showering of final state partons here; it comes later.
21247 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21254 KSAV(I,J)=K(N-4+I,J)
21255 PSAV(I,J)=P(N-4+I,J)
21258 CALL PYSSPA(IPU1,IPU2)
21260 C...If shower failed then restore to situation before shower.
21261 IF(MINT(51).GE.1) THEN
21265 K(N-4+I,J)=KSAV(I,J)
21266 P(N-4+I,J)=PSAV(I,J)
21276 C...Keep track of loose colour ends and information on scattering.
21277 370 IMI(1,MINT(31),1)=IPU1
21278 IMI(2,MINT(31),1)=IPU2
21279 IMI(1,MINT(31),2)=0
21280 IMI(2,MINT(31),2)=0
21281 XMI(1,MINT(31))=VINT(141)
21282 XMI(2,MINT(31))=VINT(142)
21283 PT2MI(MINT(31))=VINT(54)
21286 C...Decide whether quarks in last scattering were valence, companion or
21290 KFSBM=ISIGN(1,MINT(10+JS))
21291 IFL=K(IMI(JS,MINT(31),1),2)
21292 IMI(JS,MINT(31),2)=0
21293 IF (IABS(IFL).GT.6) GOTO 430
21295 C...Get PDFs at X and Q2 of the parton shower initiator for the
21296 C...last scattering. At this point VINT(143:144) do not yet
21297 C...include the scattered x values VINT(141:142).
21298 X=VINT(140+JS)/VINT(142+JS)
21299 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21304 C...Note: XPSVC = x*pdf.
21307 C.... Store side in MINT(124)
21310 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21314 DO 380 IVC=1,NVC(JS,IFL)
21315 CMP=CMP+XPSVC(IFL,IVC)
21318 C...Decide (Extra factor x cancels in the dvision).
21319 RVCS=PYR(0)*(SEA+VAL+CMP)
21321 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21322 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21324 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21325 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21326 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21327 IF(KFIVAL(JS,1).EQ.0) THEN
21328 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21329 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21330 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21331 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21333 DO 400 I1=1,NMI(JS)
21334 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21338 IF(IVNOW.EQ.0) GOTO 390
21340 IMI(JS,MINT(31),2)=0
21341 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21342 IF(KFIVAL(JS,1).EQ.0) THEN
21343 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21346 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21348 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21349 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21353 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21354 C...If sea, add opposite sign companion parton. Store X and I.
21355 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21356 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21357 C...Set pointer to companion
21358 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21360 C...If companion, decide which one.
21364 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21365 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21366 C...Find original sea (anti-)quark:
21368 DO 420 I1=1,NMI(JS)
21369 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21370 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21371 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21372 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21375 C...Change X to what associated companion had, so that the correct
21376 C...amount of momentum can be subtracted from the companion sum below.
21377 X=XASSOC(JS,IFL,ISEL)
21378 C...Mark companion read.
21379 XASSOC(JS,IFL,ISEL)=0D0
21383 C...Global statistics.
21384 MINT(351)=MINT(351)+1
21385 VINT(351)=VINT(351)+PT
21386 IF (MINT(351).EQ.1) VINT(356)=PT
21388 C...Update remaining energy and other counters.
21389 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21390 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21396 VINT(151)=VINT(151)+VINT(41)
21397 VINT(152)=VINT(152)+VINT(42)
21398 VINT(143)=VINT(143)-VINT(141)
21399 VINT(144)=VINT(144)-VINT(142)
21401 C...Iterate, with more interactions allowed.
21402 IF(MINT(31).LT.240) GOTO 240
21405 C...Restore saved quantities for hardest interaction.
21421 C...Format statements for printout.
21422 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21423 &'actions for MSTP(82) =',I2,' ******')
21424 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21425 &D9.2,' mb: rejected')
21426 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21427 &D9.2,' mb: accepted')
21432 C*********************************************************************
21435 C...Finds left-behind remnant flavour content and hooks up
21436 C...the colour flow between the hard scattering and remnants
21440 C...Double precision and integer declarations.
21441 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21442 IMPLICIT INTEGER(I-N)
21443 INTEGER PYK,PYCHGE,PYCOMP
21444 C...The event record
21445 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21447 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21448 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21449 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21450 COMMON/PYINT1/MINT(400),VINT(400)
21451 C...The common block of dangling ends
21452 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21453 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21454 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21455 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21456 C...Local variables
21457 PARAMETER (NERSIZ=4000)
21458 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21460 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21461 SAVE /PYCBLS/,/PYCTAG/
21462 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21463 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21466 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)
21468 C...Set up error checkers
21471 C...Initialize colour arrays: MCO (Original) and MCT (New)
21472 DO 110 I=MINT(84)+1,NERSIZ
21477 C...Also zero colour tracing information, if existed.
21479 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21480 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21484 C...Initialize colour tag collapse arrays:
21485 C...JCCO (Original) and JCCN (New).
21486 DO 130 MG=MINT(84)+1,NERSIZ
21493 C...Zero gluon insertion array
21500 C...Compute hard scattering system rapidities
21501 IF (MSTP(89).EQ.1) THEN
21503 IF (IM.LE.MINT(31)) THEN
21504 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21506 C...Set (unsigned) rapidity = 100 for beam remnant systems.
21512 C...Treat each side separately
21515 C...Initialize side.
21518 KFS=ISIGN(1,MINT(10+JS))
21520 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21521 IF(KFIVAL(JS,1).EQ.0) THEN
21522 IF(MINT(10+JS).EQ.111) THEN
21523 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
21524 KFIVAL(JS,2)=-KFIVAL(JS,1)
21525 ELSEIF(MINT(10+JS).EQ.22) THEN
21528 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
21529 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
21530 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
21531 KFIVAL(JS,2)=-KFIVAL(JS,1)
21532 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
21533 IF(PYR(0).GT.0.5D0) THEN
21543 C...Initialize beam remnant sea and valence content flavour by flavour.
21547 C...Count up original number of JFA valence quarks and antiquarks.
21552 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
21553 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
21555 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
21556 C...Subtract kicked out valence and determine sea from flavour cons.
21557 DO 180 IM=1,NMI(JS)
21558 IFL = K(IMI(JS,IM,1),2)
21561 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21562 C...Subtract K.O. valence quark from remainder.
21564 JV=NVSUM(JS)-NVALQ-NVALQB
21565 IV(JS,JV)=IMI(JS,IM,1)
21566 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21567 C...Subtract K.O. valence antiquark from remainder.
21569 JV=NVSUM(JS)-NVALQ-NVALQB
21570 IV(JS,JV)=IMI(JS,IM,1)
21571 ELSEIF (IFA.EQ.JFA) THEN
21572 C...Outside sea without companion: add opposite sea flavour inside.
21573 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
21576 C...Check if space left in PYJETS for additional BR flavours
21577 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
21578 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
21579 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
21580 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
21584 C...Add required val+sea content to beam remnant.
21585 IF (NFLSUM.GT.0) THEN
21587 C...Insert beam remnant quark as p.t. symbolic parton in ER.
21595 K(N,2)=ISIGN(JFA,NSEA)
21596 IF (IA.LE.NVALQ) K(N,2)=JFA
21597 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
21599 C...Also update NMI, IMI, and IV arrays.
21601 IMI(JS,NMI(JS),1)=N
21602 IMI(JS,NMI(JS),2)=-1
21603 IF (IA.LE.NVALQ+NVALQB) THEN
21604 IMI(JS,NMI(JS),2)=0
21606 IV(JS,JV)=IMI(JS,NMI(JS),1)
21614 IF (IM.LE.NMI(JS)) THEN
21615 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
21617 C...Add fictitious parent gluons for companion pairs.
21618 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
21619 C...Randomly assign companions to sea quarks which have none.
21620 IF (IMI(JS,IM,2).LT.0) THEN
21622 230 IMC=MOD(IMC,NMI(JS))+1
21623 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
21624 IF (IMI(JS,IMC,2).GE.0) GOTO 230
21625 IMI(JS, IM,2) = IMI(JS,IMC,1)
21626 IMI(JS,IMC,2) = IMI(JS, IM,1)
21628 C...Add fictitious parent gluon
21638 C...Set gluon (anti-)colour daughter pointers
21639 K(N,4)=IMI(JS, IM,1)
21640 K(N,5)=IMI(JS, IM,2)
21641 C...Set quark (anti-)colour parent pointers
21642 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21643 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21644 C...Add gluon to IMI
21646 IMI(JS,NMI(JS),1)=N
21647 IMI(JS,NMI(JS),2)=0
21652 C...If incoming (anti-)baryon, insert inside (anti-)junction.
21653 C...Set up initial v-v-j-v configuration. Otherwise set up
21654 C...mesonic v-vbar configuration
21655 IF (IABS(MINT(10+JS)).GT.1000) THEN
21656 C...Determine junction type (1: B=1 2: B=-1)
21657 ITJUNC(JS) = (3-KFS)/2
21658 C...Insert junction.
21665 C...Set special junction codes:
21668 C...Set parent to side.
21670 K(N,4)=ITJUNC(JS)*MSTU(5)
21672 C...Connect valence quarks to junction.
21675 C...Set (anti)colour mother = junction.
21677 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21679 C...Keep track of partons adjacent to junction:
21680 JST(JS,JV)=IV(JS,JV)
21683 C...Mesons: set up initial q-qbar topology
21685 IF (K(IV(JS,1),2).GT.0) THEN
21696 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21697 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21698 C...Special for mesons. Insert gluon if BR empty.
21699 IF (NBRTOT(JS).EQ.0) THEN
21713 C...Add gluon to IMI
21715 IMI(JS,NMI(JS),1)=N
21716 IMI(JS,NMI(JS),2)=0
21721 C...Count up number of valence quarks outside BR.
21723 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21724 & MOUT(JS)=MOUT(JS)+1
21729 C...Now both sides have been prepared in an initial vvjv (baryonic) or
21730 C...v(g)vbar (mesonic) configuration.
21732 C...Create colour line tags starting from initiators.
21734 DO 320 IM=1,MINT(31)
21735 C...Consider each side in turn.
21740 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21742 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21745 CALL PYCTTR(I1,KCS,I2)
21746 IF(MINT(51).NE.0) RETURN
21753 C...Create colour tags for beam remnant partons.
21754 DO 330 IM=MINT(31)+1,NMI(JS)
21756 IF (K(IP,2).NE.21) THEN
21757 JC=(3-ISIGN(1,K(IP,2)))/2
21758 IF (MCT(IP,JC).EQ.0) THEN
21767 C...Fictituous gluons just inherit from their quark daughters.
21771 C...Real beam remnant gluons get their own colours
21782 C...Create colour tags for colour lines which are detached from the
21786 DO 350 I=MINT(84)+1,N
21788 C...Look for coloured string endpoint, or (later) leftover gluon.
21789 IF (K(I,1).NE.3) GOTO 350
21791 IF(KC.EQ.0) GOTO 350
21793 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21795 C...Pick up loose string end with no previous tag.
21797 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21798 IF(MCT(I,KCS-3).NE.0) GOTO 350
21800 CALL PYCTTR(I,KCS,I)
21801 IF(MINT(51).NE.0) RETURN
21806 C...Store original colour tags
21807 DO 370 I=MINT(84)+1,N
21812 C...Iteratively add gluons to already existing string pieces, enforcing
21813 C...various possible orderings, and rejecting insertions that would give
21814 C...rise to singlet gluons.
21815 C...<kappa tau> normalization.
21820 C...Set up simplified kinematics.
21821 C...Boost hard interaction systems.
21823 DO 380 IM=1,MINT(31)
21824 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21825 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21827 C...Assign preliminary beam remnant momenta.
21828 DO 390 I=MINT(53)+1,N
21832 IF (K(I,2).NE.88) THEN
21833 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21835 IF (JS.EQ.2) P(I,3)=-P(I,3)
21837 C...Junctions are wildcards for the present.
21843 C...Reset colour processing information.
21844 400 DO 410 I=MINT(84)+1,N
21845 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21846 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21851 C...If meson, without gluon in BR, collapse q-qbar colour tags:
21852 IF (ITJUNC(JS).EQ.0) THEN
21853 JC1=MCT(JST(JS,1),1)
21854 JC2=MCT(JST(JS,2),2)
21856 JCCO(NCC,1)=MAX(JC1,JC2)
21857 JCCO(NCC,2)=MIN(JC1,JC2)
21858 C...Collapse colour tags in event record
21859 DO 420 I=MINT(84)+1,N
21860 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21861 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21867 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21868 IF (NG(JS).GT.0) THEN
21871 C...Start at random gluon (optimizes speed for random attachments)
21873 IMGL=PYR(0)*NMI(JS)+1
21874 450 IMGL=MOD(IMGL,NMI(JS))+1
21876 C...Only loop through NMI once (with upper limit to save time)
21877 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21878 IGL = IMI(JS,IMGL,1)
21879 C...If not gluon or if already connected, try next.
21880 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21881 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21882 C...Now loop through all possible insertions of this gluon.
21884 IMP1=PYR(0)*NMI(JS)+1
21885 460 IMP1=MOD(IMP1,NMI(JS))+1
21887 IF (IMP1.EQ.IMGL) GOTO 460
21888 C...Only loop through NMI once (with upper limit to save time).
21889 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21890 IP1 = IMI(JS,IMP1,1)
21891 C...Try both colour mother and colour anti-mother.
21892 C...Randomly select which one to try first.
21895 470 MANTI=MOD(MANTI+1,2)
21897 IF (NANTI.LE.2) THEN
21898 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21899 C...Reject if no appropriate mother (or if mother is fictitious
21901 IF (IP2.LE.0) GOTO 470
21902 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21903 C...Also reject if this link has already been tried.
21904 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21905 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21906 C...Set flag to indicate that this link has now been tried for this
21907 C...gluon. IP2 may be junction, which has several mothers.
21908 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21909 IF (K(IP2,2).NE.88) THEN
21910 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21913 C...JCG1: Original colour tag of gluon on IP1 side
21914 C...JCG2: Original colour tag of gluon on IP2 side
21915 C...JCP1: Original colour tag of IP1 on gluon side
21916 C...JCP2: Original colour tag of IP2 on gluon side.
21917 JCG1=MCO(IGL,2-MANTI)
21918 JCG2=MCO(IGL,1+MANTI)
21919 JCP1=MCO(IP1,1+MANTI)
21920 JCP2=MCO(IP2,2-MANTI)
21922 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21923 C...Reject gluon attachments that give rise to singlet gluons.
21924 IF (MACCPT.EQ.0) GOTO 470
21927 JCG1=MCT(IGL,2-MANTI)
21928 JCG2=MCT(IGL,1+MANTI)
21929 JCP1=MCT(IP1,1+MANTI)
21930 JCP2=MCT(IP2,2-MANTI)
21932 C...Select whether to accept this insertion
21933 IF (MSTP(89).EQ.0) THEN
21934 C...Random insertions: no measure.
21936 C...For random ordering, we want to suppress beam remnant breakups
21937 C...already at this point.
21938 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21939 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21944 ELSEIF (MSTP(89).EQ.1) THEN
21945 C...Rapidity ordering:
21946 C...YGL = Rapidity of gluon.
21948 C...If fictitious gluon
21949 IF (YGL.EQ.100D0) THEN
21951 IDA1=MOD(K(IGL,4),MSTU(5))
21952 IDA2=MOD(K(IGL,5),MSTU(5))
21953 DO 480 IMT=1,NMI(JS)
21954 C...Select (arbitrarily) the most central daughter.
21955 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21957 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21961 C...YP1 = Rapidity IP1
21963 C...If fictitious gluon
21964 IF (YP1.EQ.100D0) THEN
21966 IDA1=MOD(K(IP1,4),MSTU(5))
21967 IDA2=MOD(K(IP1,5),MSTU(5))
21968 DO 490 IMT=1,NMI(JS)
21969 C...Select (arbitrarily) the most central daughter.
21970 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21972 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21976 C...YP2 = Rapidity of mother system
21977 IF (K(IP2,2).NE.88) THEN
21978 DO 500 IMT=1,NMI(JS)
21979 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21981 C...If fictitious gluon
21982 IF (YP2.EQ.100D0) THEN
21984 IDA1=MOD(K(IP2,4),MSTU(5))
21985 IDA2=MOD(K(IP2,5),MSTU(5))
21986 DO 510 IMT=1,NMI(JS)
21987 C...Select (arbitrarily) the most central daughter.
21988 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21990 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21994 C...Assign (arbitrarily) 100D0 to junction also
21998 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21999 ELSEIF (MSTP(89).EQ.2) THEN
22000 C...Lambda ordering:
22001 C...Compute lambda measure for this insertion.
22006 C...If IP2 is junction, not caught below.
22007 IF (JCP2.EQ.0) THEN
22008 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22009 C...Anti-junction is colour endpoint et vv., always on JCG2.
22012 DO 530 I=MINT(84)+1,N
22013 IF (K(I,1).LT.10) THEN
22014 C...The new string pieces
22015 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22016 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22017 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22018 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22021 C...Also identify junctions as string endpoints.
22022 DO 540 I=MINT(84)+1,N
22023 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22024 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22025 C...Find partons adjacent to junctions.
22026 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22027 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22028 & .EQ.0) ISTR(2) = ICMO
22029 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22030 & .EQ.0) ISTR(4) = ICMO
22032 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22033 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22034 & .EQ.0) ISTR(1) = IAMO
22035 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22036 & .EQ.0) ISTR(3) = IAMO
22039 C...The old string piece
22040 ISTR(5)=ISTR(1+2*MANTI)
22041 ISTR(6)=ISTR(4-2*MANTI)
22042 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22043 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22044 C...If one or more of the colour tags for this connection is/are still
22045 C...dangling, skip this attempt for the time being.
22048 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22049 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22053 C...Allow some breadth to speed things up.
22054 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22056 ELSEIF (RL.GT.RLOPT) THEN
22062 C...INSR(NOPT,1)=Gluon colour mother
22063 C...INSR(NOPT,2)=Gluon
22064 C...INSR(NOPT,3)=Gluon anticolour mother
22065 IF (NOPT.GT.1000) GOTO 470
22066 INSR(NOPT,1+2*MANTI)=IP2
22068 INSR(NOPT,3-2*MANTI)=IP1
22069 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22071 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22073 C...Reset link test information.
22074 DO 550 I=MINT(84)+1,N
22075 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22076 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22078 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22080 C...Now we have a list of best gluon insertions, none of which cause
22081 C...singlets to arise. If list is empty, try again a few times. Note:
22082 C...this should never happen if we have a meson with a gluon inserted
22083 C...in the beam remnant, since that breaks up the colour line.
22084 IF (NOPT.EQ.0) THEN
22085 C...Abandon BR-g-BR suppression for retries. This is not serious, it
22086 C...just means we happened to start with trying a bad sequence.
22088 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22089 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22092 IF (ITJUNC(JS).NE.0) THEN
22096 C...Reset valence quark parent pointers
22097 DO 560 I=MINT(53)+1,N
22098 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22101 C...Set (anti)colour mother = junction.
22103 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22107 C...Same for mesons. JST unchanged, so needn't be restored.
22110 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22111 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22113 C...Also reset gluon parent pointers.
22115 DO 580 IM=1,NMI(JS)
22117 IF (K(I,2).EQ.21) THEN
22118 K(I,4)=MOD(K(I,4),MSTU(5))
22119 K(I,5)=MOD(K(I,5),MSTU(5))
22124 C...Reset colour tags
22125 DO 600 I=MINT(84)+1,N
22131 IF(NERRPR.LT.5) THEN
22134 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22135 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22137 C...Kill event and start another.
22142 C...Select between insertions, suppressing insertions wholly in the BR.
22144 610 IIN=MOD(IIN,NOPT)+1
22145 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22146 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22149 C...Now we know which gluon to insert where. Colour tags in JCCO and
22150 C...colour connection information should be updated, NG(JS) should be
22151 C...counted down, and a new loop performed if there are still gluons
22152 C...left on any side.
22156 C...JCG : Original gluon colour tag
22157 C...JCAG: Original gluon anticolour tag.
22158 C...JCM : Original anticolour tag of gluon colour mother
22159 C...JACM: Original colour tag of gluon anticolour mother
22165 CALL PYMIHG(JACM,JACG,JCM,JCG)
22166 IF (MACCPT.EQ.0) THEN
22167 IF(NERRPR.LT.5) THEN
22170 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22171 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22173 C...Kill event and start another.
22177 C...If everything went fine, store new JCCN in JCCO.
22180 JCCO(ICC,1)=JCCN(ICC,1)
22181 JCCO(ICC,2)=JCCN(ICC,2)
22185 C...One gluon attached is counted as equivalent to one end outside.
22187 C...Set IGL colour mother = ICM.
22188 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22189 C...Set ICM anticolour mother = IGL colour.
22190 IF (K(ICM,2).NE.88) THEN
22191 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22193 C...If ICM is junction, just update JST array for now.
22195 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22198 C...Set IGL anticolour mother = IACM.
22199 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22200 C...Set IACM anticolour mother = IGL anticolour.
22201 IF (K(IACM,2).NE.88) THEN
22202 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22204 C...If IACM is junction, just update JST array for now.
22206 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22209 C...Count down # unconnected gluons.
22212 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22215 C...Collapse fictitious gluons.
22216 DO 670 IGL=MINT(53)+1,N
22217 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22218 & K(IGL,1).EQ.14) THEN
22219 ICM=K(IGL,4)/MSTU(5)
22220 IAM=K(IGL,5)/MSTU(5)
22221 ICD=MOD(K(IGL,4),MSTU(5))
22222 IAD=MOD(K(IGL,5),MSTU(5))
22223 C...Set gluon daughters pointing to gluon mothers
22224 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22225 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22226 C...Set gluon mothers pointing to gluon daughters.
22227 IF (K(ICM,2).NE.88) THEN
22228 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22230 C...Special case: mother=junction. Just update JST array for now.
22232 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22235 IF (K(IAM,2).NE.88) THEN
22236 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22239 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22245 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22248 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22249 IF (IM.GT.MINT(31)) THEN
22251 DO 690 IMR=IM,NMI(JS)
22252 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22253 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22258 C...Finally, connect junction.
22259 IF (ITJUNC(JS).NE.0) THEN
22260 DO 700 I=MINT(53)+1,N
22261 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22263 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22268 C...Find jq with no glue inbetween inside beam remnant.
22269 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22272 C...Set IDQ = -I if q non-valence and = +I if q valence.
22273 IDQ(NBRJQ)=-JST(JS,MSJ)
22275 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22276 IDQ(NBRJQ)=JST(JS,MSJ)
22283 IF (MSJ.EQ.3) I45=4
22284 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22287 C...Check if diquark can be formed.
22288 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22290 C...If there is less than 2 valence quarks connected to junction
22291 C...and MSTP(88)>1, use random non-valence quarks to fill up.
22292 IF (NBRVQ.LE.1) THEN
22294 730 JFLIP=NBRJQ*PYR(0)+1
22295 IF (IDQ(JFLIP).LT.0) THEN
22296 IDQ(JFLIP)=-IDQ(JFLIP)
22299 IF (NDIQ.LE.1) GOTO 730
22301 C...Place selected quarks first in IDQ, ordered in flavour.
22303 IF (IDQ(JDQ).LE.0) THEN
22307 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22314 C...Choose diquark spin.
22315 IF (NBRVQ.EQ.2) THEN
22316 C...If the selected quarks are both valence, we may use SU(6) rules
22317 C...to figure out which spin the diquark has, by a subdivision of the
22318 C...original beam hadron into the selected diquark system plus a kicked
22319 C...out quark, IKO.
22323 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22327 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22329 C...If one or more of the selected quarks are not valence, we cannot use
22330 C...SU(6) subdivisions of the original beam hadron. Instead, with the
22331 C...flavours of the diquark already selected, we assume for now
22332 C...50:50 spin-1:spin-0 (where spin-0 possible).
22333 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22335 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22336 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22337 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22340 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22341 C...Note: third quark can per definition not also be valence,
22342 C...therefore we can only do this if we are allowed to use sea quarks.
22343 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22346 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22347 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22349 ELSEIF(NTRY.GT.100) THEN
22350 C...If no baryon can be found, give up and form diquark.
22354 C...Replace junction by baryon.
22357 K(IJU,3)=MINT(83)+JS
22360 P(IJU,5)=PYMASS(KFBAR)
22362 C...Prepare removal of participating quarks from ER.
22363 K(JST(JS,MSJ),1)=-1
22367 C...If collapse to baryon not possible or not allowed, replace junction
22368 C...by diquark. This way, collapsed gluons that were pointing at the
22369 C...junction will now point (correctly) at diquark.
22373 K(IJU,3)=MINT(83)+JS
22378 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22380 K(IJU,5-MANTI)=IP*MSTU(5)
22381 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22383 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22385 C...Prepare removal of participating quarks from ER.
22391 C...Update so ER pointers to collapsed quarks
22392 C...now go to collapsed object.
22393 DO 820 I=MINT(84)+1,N
22394 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22395 & .K(I,1).GT.0) THEN
22397 IMO=K(I,ISID)/MSTU(5)
22398 IDA=MOD(K(I,ISID),MSTU(5))
22400 IF (K(IMO,1).EQ.-1) IMO=IJU
22403 IF (K(IDA,1).EQ.-1) IDA=IJU
22405 K(I,ISID)=IDA+MSTU(5)*IMO
22412 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22413 C...(this only happens for baryons, where we want to force the gluon
22414 C...to sit next to the junction. Mesons handled above.)
22415 IF (NBRTOT(JS).EQ.0) THEN
22425 K(IGL,3)=MINT(83)+JS
22426 IF (ITJUNC(JS).NE.0) THEN
22427 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22428 JLEG=PYR(0)*NVSUM(JS)+1
22431 JCT=MCT(I1,ITJUNC(JS))
22432 MCT(IGL,3-ITJUNC(JS))=JCT
22434 MCT(IGL,ITJUNC(JS))=NCT
22437 C...Meson. Should not happen.
22438 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22439 IF(NERRPR.LT.5) THEN
22440 WRITE(MSTU(11),*) 'This should not have been possible!'
22447 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22448 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22449 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22450 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22451 IF (K(I2,2).NE.88) THEN
22452 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22454 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22455 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22456 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22457 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22459 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22465 C...Remove collapsed quarks and junctions from ER and update IMI.
22468 C...Also update beam remnant part of IMI.
22471 DO 850 I=MINT(53)+1,N
22472 IF (K(I,1).LE.0) GOTO 850
22473 C...Restore BR quark/diquark/baryon pointers in IMI.
22474 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22477 IMI(JS,NMI(JS),1)=I
22478 IMI(JS,NMI(JS),2)=0
22482 C...Restore companion information from collapsed gluons.
22483 DO 870 I=MINT(53)+1,N
22484 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22486 JCD=MOD(K(I,4),MSTU(5))
22487 JAD=MOD(K(I,5),MSTU(5))
22488 DO 860 IM=1,NMI(JS)
22489 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22490 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22492 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22493 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22497 C...Renumber colour lines (since some have disappeared)
22505 IF (MFOUND.EQ.0) JCD=JCD+1
22506 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22509 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22513 IF (I.LE.N) GOTO 890
22514 IF (JCT.LT.NCT) GOTO 880
22517 C...Reset hard interaction subsystems to their CM frames.
22518 IF (IBOOST.EQ.1) THEN
22519 DO 900 IM=1,MINT(31)
22520 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22521 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22523 C...Zero beam remnant longitudinal momenta and energies
22524 DO 910 I=MINT(53)+1,N
22530 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22531 C...Kill event and start another.
22538 C*********************************************************************
22541 C...Adapted from PYPREP.
22542 C...Assigns LHA1 colour tags to coloured partons based on
22543 C...K(I,4) and K(I,5) colour connection record.
22544 C...KCS negative signifies that a previous tracing should be continued.
22545 C...(in case the tag to be continued is empty, the routine exits)
22546 C...Starts at I and ends at I or IEND.
22547 C...Special considerations for systems with junctions.
22548 C...Special: if IEND=-1, means trace this parton to its color partner,
22549 C... then exit. If no partner found, exit with 0.
22551 SUBROUTINE PYCTTR(I,KCS,IEND)
22552 C...Double precision and integer declarations.
22553 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22554 INTEGER PYK,PYCHGE,PYCOMP
22556 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22559 COMMON/PYINT1/MINT(400),VINT(400)
22560 C...The common block of colour tags.
22561 COMMON/PYCTAG/NCT,MCT(4000,2)
22562 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
22566 C...Skip if parton not existing or does not have KCS
22567 IF (K(I,1).LE.0) GOTO 120
22569 IF (KC.EQ.0) GOTO 120
22571 IF (KQ.EQ.0) GOTO 120
22572 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
22577 C...Set colour tag of first parton.
22583 IF (NCS.EQ.0) GOTO 120
22589 IF(NSTP.GT.4*N) THEN
22590 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
22594 C...Finished if reached final-state triplet.
22595 IF(K(IA,1).EQ.3) THEN
22596 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
22599 C...Also finished if reached junction.
22600 IF(K(IA,1).EQ.42) THEN
22604 C...GOTO next parton in colour space.
22606 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22607 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
22609 IA=MOD(K(IB,KCS),MSTU(5))
22610 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
22613 C...If KCS mother traced or KCS mother nonexistent, switch colour.
22614 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
22615 & MSTU(5)).EQ.0) THEN
22619 C...Assign new colour tag on other side of old parton.
22622 C...Goto (new) KCS mother, set mother traced tag
22623 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
22624 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
22627 IF(IA.LE.0.OR.IA.GT.N) THEN
22628 IF (IEND.EQ.-1) THEN
22632 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
22633 IF(NERRPR.LT.5) THEN
22634 write(*,*) 'began at ',I
22635 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
22636 & ' NCS=',NCS,' MREV=',MREV
22643 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
22644 & MSTU(5)).EQ.IB) THEN
22645 IF(MREV.EQ.1) KCS=9-KCS
22646 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
22647 C...Set KSC mother traced tag for IA
22648 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
22650 IF(MREV.EQ.0) KCS=9-KCS
22651 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22652 C...Set KCS daughter traced tag for IA
22653 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22655 C...Assign new colour tag
22657 C...Finish if IEND=-1 and found final-state color partner
22658 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
22662 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
22667 *********************************************************************
22670 C...Collapse JCP1 and connecting tags to JCG1.
22671 C...Collapse JCP2 and connecting tags to JCG2.
22673 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22674 C...Double precision and integer declarations.
22675 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22676 IMPLICIT INTEGER(I-N)
22677 INTEGER PYK,PYCHGE,PYCOMP
22678 C...The event record
22679 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22681 COMMON/PYINT1/MINT(400),VINT(400)
22682 SAVE /PYJETS/,/PYINT1/
22683 C...Local variables
22684 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22685 COMMON /PYCTAG/NCT,MCT(4000,2)
22686 SAVE /PYCBLS/,/PYCTAG/
22688 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22689 C...in temporary tag collapse array JCCN. Only break up one connection.
22693 JCCN(ICC,1)=JCCO(ICC,1)
22694 JCCN(ICC,2)=JCCO(ICC,2)
22695 C...If there was a mother, it was previously connected to JCP1.
22696 C...Should be changed to JCP2.
22697 IF (MCLPS.EQ.0) THEN
22698 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22700 JCCN(ICC,1)=MAX(JCG2,JCP2)
22701 JCCN(ICC,2)=MIN(JCG2,JCP2)
22706 C...Also collapse colours on JCP1 side of JCG1
22707 IF (JCP1.NE.0) THEN
22708 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22709 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22711 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22712 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22715 C...Initialize event record colour tag array MCT array to MCO.
22716 DO 110 I=MINT(84)+1,N
22722 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22723 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22724 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22725 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22727 C...Skip if junction.
22728 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22729 C...Define starting point in tag space.
22730 C...JCA = previous tag
22731 C...JCO = present tag
22733 IF (MOD(IS,2).EQ.1) THEN
22737 ELSEIF (MOD(IS,2).EQ.0) THEN
22743 120 ITRACE=ITRACE+1
22744 IF (ITRACE.GT.1000) THEN
22745 C...NB: Proper error message should be defined here.
22747 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22748 MINT(57)=MINT(57)+1
22752 C...Collapse all JCN tags to JCALL
22753 DO 130 I=MINT(84)+1,N
22754 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22755 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22757 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22758 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22765 C...If possible, step from JCO to new tag JCN not equal to JCA.
22767 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22769 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22772 C...Iterate if new colour was arrived at, but don't go in circles.
22773 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22774 C...Change all JCN tags in MCO to JCALL in MCT.
22775 DO 150 I=MINT(84)+1,N
22776 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22777 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22778 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22779 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22784 DO 200 JCL=NCT,1,-1
22789 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22791 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22794 C...Overpaint all JCN with JCL
22795 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22796 DO 190 I=MINT(84)+1,N
22797 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22798 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22799 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22800 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22811 C*********************************************************************
22814 C...Picks primordial kT and shares longitudinal momentum among
22819 C...Double precision and integer declarations.
22820 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22821 IMPLICIT INTEGER(I-N)
22822 INTEGER PYK,PYCHGE,PYCOMP
22823 C...The event record
22824 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22827 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22828 COMMON/PYINT1/MINT(400),VINT(400)
22829 C...The common block of colour tags.
22830 COMMON/PYCTAG/NCT,MCT(4000,2)
22831 C...The common block of dangling ends
22832 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22833 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22834 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22835 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22836 C...Local variables
22837 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22838 C...W(I,J)| J=0 | 1 | 2 |
22839 C... I=0 | Wrem**2 | W+ | W- |
22840 C... 1 | W1**2 | W1+ | W1- |
22841 C... 2 | W2**2 | W2+ | W2- |
22843 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)
22844 C...Tentative parametrization of <kT> as a function of Q.
22845 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22846 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22847 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22848 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22849 C...Lambda kinematic function.
22850 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22852 C...Beginning and end of beam remnant partons
22856 C...Loopback point if kinematic choices gives impossible configuration.
22860 C...Assign kT values on each side separately.
22863 C...First zero all kT on this side. Skip if no kT to generate.
22864 DO 110 IM=1,NMI(JS)
22865 P(IMI(JS,IM,1),1)=0D0
22866 P(IMI(JS,IM,1),2)=0D0
22868 IF(MSTP(91).LE.0) GOTO 180
22870 C...Now assign kT to each (non-collapsed) parton in IMI.
22871 DO 170 IM=1,NMI(JS)
22873 C...Select kT according to truncated gaussian or 1/kt6 tails.
22874 C...For first interaction, either use rms width = PARP(91) or fitted.
22877 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22882 C...For subsequent interactions and BR partons use fragmentation width.
22887 IF(NTRY.LE.100) THEN
22888 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22892 ELSEIF (MSTP(91).EQ.2) THEN
22893 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22894 & 'available, using MSTP(91)=1.')
22895 CALL PYGIVE('MSTP(91)=1')
22897 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22898 C...Use distribution with kt**6 tails, rms width = PARP(91).
22899 EPS=SQRT(3D0/2D0)*SIGMA
22900 C...Generate PTX and PTY separately, each propto 1/KT**6
22902 C...Decide which interval to try
22903 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22904 IF (PYR(0).LT.P12) THEN
22905 C...Use flat approx with accept/reject up to EPS.
22907 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22908 IF (PYR(0).GT.WT) GOTO 112
22910 C...Above EPS, use 1/kt**6 approx with accept/reject.
22911 PT=EPS/(PYR(0)**(1D0/5D0))
22912 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22913 IF (PYR(0).GT.WT) GOTO 112
22916 IF (PYR(0).GT.0.5D0) MSIGN=-1
22917 IF (IXY.EQ.1) PTX=MSIGN*PT
22918 IF (IXY.EQ.2) PTY=MSIGN*PT
22920 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22921 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22922 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22924 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22925 PT=SQRT(PTX**2+PTY**2)
22927 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22928 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22931 PT=SQRT(PTX**2+PTY**2)
22937 C...Compensation kicks, with varying degree of local anticorrelations.
22939 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22940 PTCX=-PTX/(NMI(JS)-1)
22941 PTCY=-PTY/(NMI(JS)-1)
22942 IF(ISUB.EQ.95) THEN
22943 PTCX=-PTX/(NMI(JS)-2)
22944 PTCY=-PTY/(NMI(JS)-2)
22946 DO 120 IMC=1,NMI(JS)
22947 IF (IMC.EQ.IM) GOTO 120
22948 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22949 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22950 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22952 ELSEIF (MCORR.GE.1) THEN
22955 C...Count up # of neighbours on either side
22957 130 IMO=K(IMO,MSID)/MSTU(5)
22958 IF (IMO.EQ.0) GOTO 140
22959 NNXT(MSID-3)=NNXT(MSID-3)+1
22960 C...Stop at quarks and junctions
22961 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22963 C...How should compensation be shared when unequal numbers on the
22964 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22965 NSUM=NNXT(1)+NNXT(2)
22968 C...Total momentum to be compensated on this side
22969 IF (NNXT(MSID-3).EQ.0) GOTO 160
22970 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22971 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22972 C...RS: compensation supression factor as we go out from parton I.
22973 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22974 C...since (for now) MSTP(90) provides enough variability.
22976 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22979 IMO=K(IMO,MSID)/MSTU(5)
22980 IF (IMO.EQ.0) GOTO 160
22982 IF (K(IMO,2).NE.88) THEN
22983 P(IMO,1)=P(IMO,1)+FAC*PTCX
22984 P(IMO,2)=P(IMO,2)+FAC*PTCY
22985 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22986 C...If we reach junction, divide out the kT that would have been
22987 C...assigned to the junction on each of its other legs.
22989 L1=MOD(K(IMO,4),MSTU(5))
22990 L2=K(IMO,5)/MSTU(5)
22991 L3=MOD(K(IMO,5),MSTU(5))
22992 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22993 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22994 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22995 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22996 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22997 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22998 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22999 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
23005 C...End assignment of kT values to initiators and remnants.
23008 C...Check kinematics constraints for non-BR partons.
23009 DO 190 IM=1,MINT(31)
23010 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23011 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23012 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23013 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23014 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23015 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23016 IF(NTRY.GE.100) THEN
23017 C...Kill this event and start another.
23019 & '(PYMIRM:) No consistent (x,kT) sets found')
23027 C...Calculate W+ and W- available for combined remnant system.
23030 DO 200 IM=1,MINT(31)
23031 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23032 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23033 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23034 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23035 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23037 C...Also store Wrem**2 = W+ * W-
23038 W(0,0)=W(0,1)*W(0,2)
23040 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23041 IF(NTRY.GE.100) THEN
23042 C...Kill this event and start another.
23044 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23051 C...Assign unscaled x values to partons/hadrons in each of the
23052 C...beam remnants and calculate unscaled W+ and W- from them.
23058 DO 270 IM=MINT(31)+1,NMI(JS)
23064 C...Skip collapsed gluons and junctions. Reset.
23065 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23066 IF (KFA.EQ.88) GOTO 270
23073 C...If gluon then only beam remnant, so takes all.
23076 C...If valence quark then use parametrized valence distribution.
23077 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23079 C...If companion quark then derive from companion x.
23080 ELSEIF(KFA.LE.6) THEN
23082 C...If valence diquark then use two parametrized valence distributions.
23083 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23085 IVALQ(1)=ISIGN(KFA/1000,KF)
23086 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23087 C...If valence+sea diquark then combine valence + companion choices.
23088 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23089 & ICOMP.LT.MSTU(5)) THEN
23090 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23091 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23093 IVALQ(1)=ISIGN(KFA/1000,KF)
23096 C...Extra code: workaround for diquark made out of two sea
23097 C...quarks, but where not (yet) ICOMP > MSTU(5).
23098 DO 220 IM1=1,MINT(31)
23099 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23100 ICOMQ(2)=IMI(JS,IM1,1)
23104 C...If sea diquark then sum of two derived from companion x.
23105 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23106 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23107 ICOMQ(2)=ICOMP/MSTU(5)
23108 C...If meson or baryon then use fragmentation function.
23109 C...Somewhat arbitrary split into old and new flavour, but OK normally.
23111 KFL3=MOD(KFA/10,10)
23112 IF(MOD(KFA/1000,10).EQ.0) THEN
23113 KFL1=MOD(KFA/100,10)
23115 KFL1=MOD(KFA,10000)-10*KFL3-1
23116 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23117 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23119 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23120 CALL PYZDIS(KFL1,KFL3,PR,X)
23124 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23125 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23126 C...In other baryons combine u and d from proton appropriately.
23127 IF(IVALQ(IQ).NE.0) THEN
23129 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23130 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23131 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23133 IF(KFIVAL(JS,3).EQ.0) THEN
23135 C...Baryon with three identical quarks: mix u and d forms.
23136 ELSEIF(NVAL.EQ.3) THEN
23137 MDU=INT(PYR(0)+5D0/3D0)
23138 C...Baryon, one of two identical quarks: u form.
23139 ELSEIF(NVAL.EQ.2) THEN
23141 C...Baryon with two identical quarks, but not the one picked: d form.
23142 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23143 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23145 C...Baryon with three nonidentical quarks: mix u and d forms.
23147 MDU=INT(PYR(0)+5D0/3D0)
23150 IF(MDU.EQ.1) XPOW=3.5D0
23151 IF(MDU.EQ.2) XPOW=2D0
23153 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23157 C...Calculation of x of companion quark.
23158 IF(ICOMQ(IQ).NE.0) THEN
23160 DO 240 IM1=1,MINT(31)
23161 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23163 NPOW=MAX(0,MIN(4,MSTP(87)))
23164 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23165 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23166 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23167 IF(CORR.LT.PYR(0)) GOTO 250
23172 C...Optionally enchance x of composite systems (e.g. diquarks)
23173 IF (KFA.GT.100) X=PARP(79)*X
23175 C...Store x. Also calculate light cone energies of each system.
23177 W(JS,JS)=W(JS,JS)+X
23178 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23180 W(JS,JS)=W(JS,JS)*W(0,JS)
23181 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23182 W(JS,0)=W(JS,1)*W(JS,2)
23185 C...Check W1 W2 < Wrem (can be done before rescaling, since W
23186 C...insensitive to global rescalings of the BR x values).
23187 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23190 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23192 ELSEIF (NTRYX.GT.100) THEN
23193 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23194 MINT(57)=MINT(57)+1
23199 C...Compute x rescaling factors
23200 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23201 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23202 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23204 IF (R1.LT.0.OR.R2.LT.0) THEN
23205 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23206 MINT(57)=MINT(57)+1
23210 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23216 C...Rescale BR x values.
23217 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23218 XMI(1,IM)=XMI(1,IM)*R1
23219 XMI(2,IM)=XMI(2,IM)*R2
23222 C...Now we have a consistent set of x and kT values.
23223 C...First set up the initiators and their daughters correctly.
23224 DO 300 IM=1,MINT(31)
23227 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23228 & (P(I1,2)+P(I2,2))**2
23229 PT12=P(I1,1)**2+P(I1,2)**2
23230 PT22=P(I2,1)**2+P(I2,2)**2
23232 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23234 C...Energies (masses should be zero at this stage)
23235 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23236 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23238 C...Transverse 12 system initiator velocity:
23239 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23240 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23241 C...Boost to overall initiator system rest frame
23242 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23243 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23245 C...Compute phi,theta coordinates of I1 and rotate z axis.
23246 PHI=PYANGL(P(I1,1),P(I1,2))
23247 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23248 IMIN=IMISEP(IM-1)+1
23249 C...(include documentation lines if MI = 1)
23250 IF (IM.EQ.1) IMIN=MINT(83)+5
23252 C...Rotate entire system in phi
23253 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23254 C...Only rotate 12 system in theta
23255 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23256 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23258 C...Now boost entire system back to LAB
23259 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23260 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23261 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23266 C...For the beam remnant partons/hadrons, we only need to set pz and E.
23268 DO 310 IM=MINT(31)+1,NMI(JS)
23270 C...Skip collapsed gluons and junctions.
23271 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23272 IF (KFA.EQ.88) GOTO 310
23273 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23274 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23275 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23276 IF (JS.EQ.2) P(I,3)=-P(I,3)
23281 C...Documentation lines
23287 K(IN,3)=MINT(83)+JS
23294 MCT(IN,1)=MCT(IO,1)
23295 MCT(IN,2)=MCT(IO,2)
23298 C...Final state colour reconnections.
23299 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23301 C...Number of colour tags for which a recoupling will be tried.
23303 C...Number of recouplings to try
23311 IF (IITER.LE.PARP(78)*NTOT) THEN
23312 C...Select two colour tags at random
23313 C...NB: jj strings do not have colour tags assigned to them,
23314 C...thus they are as yet not affected by anything done here.
23316 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23321 C...Find final state partons with this (anti)colour
23322 DO 370 I=MINT(84)+1,N
23323 IF (K(I,1).EQ.3) THEN
23324 IF (MCT(I,1).EQ.JCT) IJ1=I
23325 IF (MCT(I,2).EQ.JCT) IJ2=I
23326 IF (MCT(I,1).EQ.KCT) IK1=I
23327 IF (MCT(I,2).EQ.KCT) IK2=I
23330 C...Only consider recouplings not involving junctions for now.
23331 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23333 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23334 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23335 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23338 C...Count up number of reconnections
23339 MINT(34)=MINT(34)+1
23341 IF (MINT(34).LE.1000) THEN
23344 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23348 IF (NRECP.LT.MINT(34)) GOTO 350
23350 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23356 C*********************************************************************
23359 C...Performs colour annealing.
23360 C...MSTP(95) : CR Type
23361 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23362 C... = 2 : Type I(no gg loops); hadron-hadron only
23363 C... = 3 : Type I(no gg loops); all beams
23364 C... = 4 : Type II(gg loops) ; hadron-hadron only
23365 C... = 5 : Type II(gg loops) ; all beams
23366 C... = 6 : Type S ; hadron-hadron only
23367 C... = 7 : Type S ; all beams
23368 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23369 C...Type S is driven by starting only from free triplets, not octets.
23370 C...A string piece remains unchanged with probability
23371 C... PKEEP = (1-PARP(78))**N
23372 C...This scaling corresponds to each string piece having to go through
23373 C...N other ones, each with probability PARP(78) for reconnection, where
23374 C...N is here chosen simply as the number of multiple interactions,
23375 C...for a rough scaling with the general level of activity.
23377 SUBROUTINE PYFSCR(IP)
23378 C...Double precision and integer declarations.
23379 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23380 INTEGER PYK,PYCHGE,PYCOMP
23382 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23383 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23384 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23385 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23386 COMMON/PYINT1/MINT(400),VINT(400)
23387 C...The common block of colour tags.
23388 COMMON/PYCTAG/NCT,MCT(4000,2)
23389 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23391 C...MCN: Temporary storage of new colour tags
23392 INTEGER MCN(4000,2)
23393 C...Arrays for storing color string lengths
23394 INTEGER ICR(4000),MSCR(4000)
23396 DOUBLE PRECISION RLOPTC(4000)
23398 C...Function to give four-product.
23399 FOUR(I,J)=P(I,4)*P(J,4)
23400 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23402 C...Check valid range of MSTP(95), local copy
23403 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23404 MSTP95=MOD(MSTP(95),10)
23405 C...Set whether CR allowed inside resonance systems or not
23406 C...(not implemented yet)
23408 C IF (MSTP(95).GE.10) MRESCR=0
23410 C...Check whether colour tags already defined
23411 IF (MINT(33).EQ.0) THEN
23412 C...Erase any existing colour tags for this event
23417 C...Create colour tags for this event
23419 IF (K(I,1).EQ.3) THEN
23422 IF (MCT(I,KCSIN-3).EQ.0) THEN
23423 CALL PYCTTR(I,KCSIN,I)
23428 C...Instruct PYPREP to use colour tags
23432 C...For MSTP(95) even, only apply to hadron-hadron
23435 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23437 C...Initialize new tag array (but do not delete old yet)
23439 DO 130 I=MAX(1,IP),N
23444 C...For each final-state dipole, check whether string should be
23453 DO 140 I=MAX(1,IP),N
23454 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23455 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23457 IF (IC.NE.0.AND.IA.NE.0) THEN
23459 C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23460 C...(so far ignores the possibility that the whole "muck" may be moving.)
23461 IF (PARP(77).GT.0D0) THEN
23462 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
23463 C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23464 IF (KA1.LT.100.AND.KA2.LT.100) THEN
23465 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
23467 P2STR = 3D0/2D0 * PT2STR
23469 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
23470 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
23471 C...Estimate number of particles ~ log(M2), cut off at 1.
23472 RLOGM2=MAX(1D0,LOG(RM2STR))
23474 C...Supress reconnection probability by 1/(1+P77*P2AVG)
23475 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
23477 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
23478 IF (PYR(0).LE.PKEEP) THEN
23483 C...Add coloured parton
23489 C...Add anti-coloured parton
23499 C...Skip if there is only one possibility
23504 C...Reorder, so ordered in I (in order to correspond to old algorithm)
23515 MSCR(IC1)=MSCR(IC1+1)
23521 C...Max do 1000 reordering loops
23522 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
23524 C...Loop over CR partons
23525 C...(Ignore junctions for now.)
23530 C...Loop over coloured partons
23532 C...Retrieve parton Event Record index and Colour Side
23535 C...Skip already connected partons
23536 IF (MCN(I,MSI).NE.0) GOTO 230
23537 C...Shorthand for colour charge
23538 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23539 C...For Seattle algorithm, only start from partons with one dangling
23541 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
23542 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
23544 C...Retrieve saved optimal partner
23547 C...Reject saved optimal partner if latter is now connected
23548 C...(Also reject if using model S1, since saved partner may
23549 C...now give rise to gg loop.)
23550 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
23556 C...Search for new optimal partner if necessary
23557 IF (IOPT(IC1).EQ.0) THEN
23561 C...Loop over partons you can connect to
23565 C...Skip if already connected
23566 IF (MCN(J,MSJ).NE.0) GOTO 210
23567 C...Skip if this not colour-anticolour pair
23568 IF (MSI.EQ.MSJ) GOTO 210
23569 C...And do not let gluons connect to themselves
23570 IF (I.EQ.J) GOTO 210
23571 C...Suppress direct connections between partons in same Beam Remnant
23573 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
23575 C...Shorthand for colour charge
23576 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
23577 C...Check for gluon loops
23579 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
23580 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
23581 & MCN(I,2).NE.0) MGGSTR=1
23583 C...Save connection with smallest lambda measure
23585 C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23586 IF (MSTP(95).GE.7.AND.MSTP(95).LE.8) THEN
23587 IF (K(I,2).EQ.21) RL=0.5D0*RL
23588 IF (K(J,2).EQ.21) RL=0.5D0*RL
23590 C...If best so far was a BR string and this is not, also save.
23591 C...If best so far was a gg string and this is not, also save.
23592 C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23593 C...string with a small Lambda measure as the last step, this connection
23594 C...will be saved regardless of whether other possibilities existed.
23595 C...I.e., there should really be a check whether another possibility has
23596 C...already been found, but since these models are now actively in use
23597 C...and uncertainties are anyway large, the algorithm is left as it is.
23598 C...(correction --> Pythia 8 ?)
23599 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
23600 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
23601 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
23610 IF (IOPT(IC1).NE.0) THEN
23611 C...Save pair with largest RLOPT so far
23612 IF (RLOPT.GE.RLMAX) THEN
23618 C...Save and iterate
23619 IF (ICRMAX.GT.0) THEN
23625 MCN(ILMAX,ICMAX)=LCT
23626 MCN(JLMAX,JCMAX)=LCT
23627 IF (NLOOP.LE.2*(N-IP)) THEN
23630 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
23634 C...Save and exit. First check for leftover gluon(s)
23635 DO 260 I=MAX(1,IP),N
23636 C...Check colour charge
23637 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23638 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
23639 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
23640 C...Decide where to put left-over gluon (minimal insertion)
23643 DO 250 KCT=NCT+1,LCT
23644 DO 240 IT=MAX(1,IP),N
23645 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
23646 IF (MCN(IT,1).EQ.KCT) IC=IT
23647 IF (MCN(IT,2).EQ.KCT) IA=IT
23649 RL=FOUR(IC,I)*FOUR(IA,I)
23650 IF (RL.LT.RLMAX) THEN
23657 MCN(I,1)=MCN(ICMAX,1)
23662 C...Here we need to loop over entire event.
23663 DO 270 IZ=MAX(1,IP),N
23664 C...Do not erase parton shower colour history
23665 IF (K(IZ,1).NE.3) GOTO 270
23666 C...Check colour charge
23667 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
23668 IF (MCI.EQ.0) GOTO 270
23669 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
23670 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
23677 C*********************************************************************
23680 C...Handles diffractive and elastic scattering.
23684 C...Double precision and integer declarations.
23685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23686 IMPLICIT INTEGER(I-N)
23687 INTEGER PYK,PYCHGE,PYCOMP
23689 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23691 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23692 COMMON/PYINT1/MINT(400),VINT(400)
23693 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
23695 C...Reset K, P and V vectors. Store incoming particles.
23696 DO 110 JT=1,MSTP(126)+10
23716 P(I,J)=VINT(285+5*JT+J)
23721 C...Subprocess; kinematics.
23722 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23723 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23726 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23729 C...Elastically scattered particle. (Except elastic GVMD states.)
23730 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23731 & MINT(106+JT).NE.3)) THEN
23736 P(N,3)=PZ*(-1)**(JT+1)
23738 P(N,5)=SQRT(VINT(62+JT))
23740 C...Decay rho from elastic scattering of gamma with sin**2(theta)
23741 C...distribution of decay products (in rho rest frame).
23742 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23744 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23748 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23749 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23750 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23751 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23752 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23753 140 CTHE=2D0*PYR(0)-1D0
23754 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23755 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23757 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23760 C...Diffracted particle: low-mass system to two particles.
23761 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23767 PMMAS=SQRT(VINT(62+JT))
23770 IF(NTRY.LT.20) THEN
23771 MINT(105)=MINT(102+JT)
23772 MINT(109)=MINT(106+JT)
23773 CALL PYSPLI(KFH,21,KFL1,KFL2)
23774 CALL PYKFDI(KFL1,0,KFL3,KF1)
23775 IF(KF1.EQ.0) GOTO 150
23776 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23777 IF(KF2.EQ.0) GOTO 150
23784 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23789 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23790 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23793 P(N-1,4)=SQRT(PM1**2+PZP**2)
23794 P(N,4)=SQRT(PM2**2+PZP**2)
23795 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23797 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23798 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23800 C...Diffracted particle: valence quark kicked out.
23801 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23808 MINT(105)=MINT(102+JT)
23809 MINT(109)=MINT(106+JT)
23810 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23811 P(N-1,5)=PYMASS(K(N-1,2))
23812 P(N,5)=PYMASS(K(N,2))
23813 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23814 & 4D0*P(N-1,5)**2*P(N,5)**2
23815 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23816 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23817 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23818 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23819 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23821 C...Diffracted particle: gluon kicked out.
23830 MINT(105)=MINT(102+JT)
23831 MINT(109)=MINT(106+JT)
23832 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23834 P(N-2,5)=PYMASS(K(N-2,2))
23836 P(N,5)=PYMASS(K(N,2))
23837 C...Energy distribution for particle into two jets.
23839 IF(MOD(KFH/1000,10).NE.0) IMB=2
23840 CHIK=PARP(92+2*IMB)
23841 IF(MSTP(92).LE.1) THEN
23842 IF(IMB.EQ.1) CHI=PYR(0)
23843 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23844 ELSEIF(MSTP(92).EQ.2) THEN
23845 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23846 ELSEIF(MSTP(92).EQ.3) THEN
23847 CUT=2D0*0.3D0/VINT(1)
23849 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23851 ELSEIF(MSTP(92).EQ.4) THEN
23852 CUT=2D0*0.3D0/VINT(1)
23853 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23854 180 CHIR=CUT*CUTR**PYR(0)
23855 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23856 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23858 CUT=2D0*0.3D0/VINT(1)
23859 CUTA=CUT**(1D0-PARP(98))
23860 CUTB=(1D0+CUT)**(1D0-PARP(98))
23861 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23862 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23863 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23865 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23866 & VINT(62+JT)) GOTO 160
23867 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23868 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23869 & (2D0*VINT(62+JT))
23870 PEI=SQRT(PZI**2+SQM)
23871 PQQP=(1D0-CHI)*(PEI+PZI)
23872 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23873 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23874 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23875 P(N-1,3)=P(N-1,4)*(-1)**JT
23876 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23877 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23880 C...Documentation lines.
23882 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23883 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23884 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23886 P(I+2,3)=PZ*(-1)**(JT+1)
23888 P(I+2,5)=SQRT(VINT(62+JT))
23891 C...Rotate outgoing partons/particles using cos(theta).
23892 IF(VINT(23).LT.0.9D0) THEN
23893 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23895 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23901 C*********************************************************************
23904 C...Set up a DIS process as gamma* + f -> f, with beam remnant
23905 C...and showering added consecutively. Photon flux by the PYGAGA
23906 C...routine (if at all).
23910 C...Double precision and integer declarations.
23911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23912 IMPLICIT INTEGER(I-N)
23913 INTEGER PYK,PYCHGE,PYCOMP
23914 C...Parameter statement to help give large particle numbers.
23915 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23916 &KEXCIT=4000000,KDIMEN=5000000)
23918 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23919 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23920 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23921 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23922 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23923 COMMON/PYINT1/MINT(400),VINT(400)
23924 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23928 C...Choice of subprocess, number of documentation lines
23936 IF(MINT(107).EQ.4) ISIDE=2
23938 C...Reset K, P and V vectors. Store incoming particles
23939 DO 110 JT=1,MSTP(126)+20
23952 P(I,J)=VINT(285+5*JT+J)
23957 C...Store incoming partons in hadronic CM-frame
23962 K(I,3)=MINT(83)+2+JT
23964 IF(MINT(15).EQ.22) THEN
23965 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23966 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23967 P(MINT(84)+1,5)=-SQRT(VINT(307))
23968 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23969 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23973 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23974 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23975 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23976 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23977 P(MINT(84)+1,5)=-SQRT(VINT(308))
23981 SIDESG=(-1D0)**(ISIDE-1)
23983 C...Copy incoming partons to documentation lines.
23994 C...Second copy for partons before ISR shower, since no such.
24004 C...Define initial partons.
24007 IF(NTRY.GT.100) THEN
24012 C...Scattered quark in hadronic CM frame.
24017 P(IPU3,5)=PYMASS(KFRES)
24018 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24019 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24023 K(I,3)=MINT(83)+4+ISIDE
24031 C...No primordial kT, or chosen according to truncated Gaussian or
24032 C...exponential, or (for photon) predetermined or power law.
24033 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24034 IF(MSTP(91).LE.0) THEN
24036 ELSEIF(MSTP(91).EQ.1) THEN
24037 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24041 PT=-PARP(92)*LOG(RPT1*RPT2)
24043 IF(PT.GT.PARP(93)) GOTO 190
24044 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24045 PTA=SQRT(VINT(282+ISIDE))
24047 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24048 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24049 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24052 PTB=-PARP(99)*LOG(RPT1*RPT2)
24054 IF(PTB.GT.PARP(100)) GOTO 190
24055 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24056 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24057 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24058 IF(MSTP(93).LE.0) THEN
24060 ELSEIF(MSTP(93).EQ.1) THEN
24061 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24062 ELSEIF(MSTP(93).EQ.2) THEN
24065 PT=-PARP(99)*LOG(RPT1*RPT2)
24066 ELSEIF(MSTP(93).EQ.3) THEN
24069 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24073 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24074 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24076 IF(PT.GT.PARP(100)) GOTO 190
24082 P(IPU3,1)=PT*COS(PHI)
24083 P(IPU3,2)=PT*SIN(PHI)
24084 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24085 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24086 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24088 C...Find one or two beam remnants.
24089 MINT(105)=MINT(102+ISIDE)
24090 MINT(109)=MINT(106+ISIDE)
24091 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24092 IF(MINT(51).NE.0) THEN
24097 C...Store first remnant parton, with colour info and kinematics.
24101 K(I,3)=MINT(83)+ISIDE
24102 P(I,5)=PYMASS(K(I,2))
24103 KCOL=KCHG(PYCOMP(KFLSP),2)
24106 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24107 K(I,KFLS+3)=MSTU(5)*IPU3
24108 K(IPU3,6-KFLS)=MSTU(5)*I
24111 IF(KFLCH.EQ.0) THEN
24114 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24116 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24117 PRP=P(I,4)+ABS(P(I,3))
24119 C...When extra remnant parton or hadron: store extra remnant.
24124 K(I,3)=MINT(83)+ISIDE
24125 P(I,5)=PYMASS(K(I,2))
24126 KCOL=KCHG(PYCOMP(KFLCH),2)
24129 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24130 K(I,KFLS+3)=MSTU(5)*IPU3
24131 K(IPU3,6-KFLS)=MSTU(5)*I
24135 C...Relative transverse momentum when two remnants.
24138 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24139 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24140 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24141 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24142 P(I,1)=-P(IPU3,1)-P(I-1,1)
24143 P(I,2)=-P(IPU3,2)-P(I-1,2)
24144 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24146 C...Relative distribution of energy for particle into jet plus particle.
24148 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24149 IF(MSTP(94).LE.1) THEN
24150 IF(IMB.EQ.1) CHI=PYR(0)
24151 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24152 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24153 ELSEIF(MSTP(94).EQ.2) THEN
24154 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24155 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24156 ELSEIF(MSTP(94).EQ.3) THEN
24157 CALL PYZDIS(1,0,PMS(4),ZZ)
24160 CALL PYZDIS(1000,0,PMS(4),ZZ)
24164 C...Construct total transverse mass; reject if too large.
24165 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24166 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24167 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24168 IF(LOOP.LT.10) GOTO 200
24171 VINT(158+ISIDE)=CHI
24173 C...Subdivide longitudinal momentum according to value selected above.
24174 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24176 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24177 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24179 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24180 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24184 C...Boost current and remnant systems to correct frame.
24185 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24186 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24187 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24189 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24191 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24192 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24193 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24194 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24196 C...Let current quark shower; recoil but no showering by colour partner.
24197 QMAX=2D0*SQRT(VINT(309-ISIDE))
24202 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24209 C*********************************************************************
24212 C...Handles the documentation of the process in MSTI and PARI,
24213 C...and also computes cross-sections based on accumulated statistics.
24217 C...Double precision and integer declarations.
24218 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24219 IMPLICIT INTEGER(I-N)
24220 INTEGER PYK,PYCHGE,PYCOMP
24222 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24223 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24224 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24225 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24226 COMMON/PYINT1/MINT(400),VINT(400)
24227 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24228 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24229 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24232 C...Calculate Monte Carlo estimates of cross-sections.
24234 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24235 NGEN(0,3)=NGEN(0,3)+1
24238 IF(I.EQ.96.OR.I.EQ.97) THEN
24240 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24241 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24242 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24243 & DBLE(NGEN(96,2)))
24244 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24245 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24246 & DBLE(NGEN(96,2)))
24247 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24249 ELSEIF(NGEN(I,2).EQ.0) THEN
24250 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24253 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24256 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24259 C...Rescale to known low-pT cross-section for standard QCD processes.
24260 IF(MSUB(95).EQ.1) THEN
24261 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24262 & XSEC(68,3)+XSEC(95,3)
24263 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24264 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24266 XSEC(11,3)=FAC*XSEC(11,3)
24267 XSEC(12,3)=FAC*XSEC(12,3)
24268 XSEC(13,3)=FAC*XSEC(13,3)
24269 XSEC(28,3)=FAC*XSEC(28,3)
24270 XSEC(53,3)=FAC*XSEC(53,3)
24271 XSEC(68,3)=FAC*XSEC(68,3)
24272 XSEC(95,3)=FAC*XSEC(95,3)
24273 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24277 C...Save information for gamma-p and gamma-gamma.
24278 IF(MINT(121).GT.1) THEN
24284 C...Reset information on hard interaction.
24290 C...Copy integer valued information from MINT into MSTI.
24294 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24296 C...Store cross-section variables in PARI.
24298 PARI(2)=XSEC(0,3)/MINT(5)
24302 VINT(98)=VINT(98)+VINT(100)
24303 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24305 C...Store kinematics variables in PARI.
24308 IF(ISUB.NE.95) THEN
24318 PARI(35)=PARI(33)-PARI(34)
24325 PARI(42)=2D0*VINT(47)/VINT(1)
24328 C...Store information on scattered partons in PARI.
24329 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24332 PARI(36+IS)=P(I,3)/VINT(1)
24333 PARI(38+IS)=P(I,4)/VINT(1)
24334 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24335 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24336 & SQRT(PR),1D20)),P(I,3))
24337 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24338 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24339 & SQRT(PR),1D20)),P(I,3))
24340 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24341 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24342 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24346 C...Store sum up transverse and longitudinal momenta.
24347 PARI(65)=2D0*PARI(17)
24348 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24349 DO 150 I=MSTP(126)+1,N
24350 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24351 PT=SQRT(P(I,1)**2+P(I,2)**2)
24352 PARI(69)=PARI(69)+PT
24353 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24354 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24366 C...Store various other pieces of information into PARI.
24374 C...Store information on lepton -> lepton + gamma in PYGAGA.
24377 PARI(101)=VINT(301)
24378 PARI(102)=VINT(302)
24380 PARI(I)=VINT(I+202)
24383 C...Set information for PYTABU.
24384 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
24387 ELSEIF(ISET(ISUB).EQ.5) THEN
24398 C*********************************************************************
24401 C...Performs transformations between different coordinate frames.
24403 SUBROUTINE PYFRAM(IFRAME)
24405 C...Double precision and integer declarations.
24406 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24407 IMPLICIT INTEGER(I-N)
24408 INTEGER PYK,PYCHGE,PYCOMP
24410 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24411 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24412 COMMON/PYINT1/MINT(400),VINT(400)
24413 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
24415 C...Check that transformation can and should be done.
24416 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
24417 &MINT(91).EQ.1)) THEN
24418 IF(IFRAME.EQ.MINT(6)) RETURN
24420 WRITE(MSTU(11),5000) IFRAME,MINT(6)
24424 IF(MINT(6).EQ.1) THEN
24425 C...Transform from fixed target or user specified frame to
24426 C...overall CM frame.
24427 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
24428 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
24429 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
24430 ELSEIF(MINT(6).EQ.3) THEN
24431 C...Transform from hadronic CM frame in DIS to overall CM frame.
24432 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
24436 IF(IFRAME.EQ.1) THEN
24437 C...Transform from overall CM frame to fixed target or user specified
24439 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
24440 ELSEIF(IFRAME.EQ.3) THEN
24441 C...Transform from overall CM frame to hadronic CM frame in DIS.
24442 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
24443 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
24444 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
24447 C...Set information about new frame.
24451 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
24452 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
24458 C*********************************************************************
24461 C...Calculates full and partial widths of resonances.
24463 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
24465 C...Double precision and integer declarations.
24466 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24467 IMPLICIT INTEGER(I-N)
24468 INTEGER PYK,PYCHGE,PYCOMP
24469 C...Parameter statement to help give large particle numbers.
24470 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24471 &KEXCIT=4000000,KDIMEN=5000000)
24473 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24474 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24475 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
24476 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24477 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24478 COMMON/PYINT1/MINT(400),VINT(400)
24479 COMMON/PYINT4/MWID(500),WIDS(500,5)
24480 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24481 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24482 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24483 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
24484 COMMON/PYPUED/IUED(0:99),RUED(0:99)
24485 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
24486 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
24487 C...Local arrays and saved variables.
24488 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24489 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
24490 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
24491 C...UED: equivalences between ordered particles (451->475)
24492 C...and UED particle code (5 000 000 + id)
24493 PARAMETER(KKFLMI=451,KKFLMA=475)
24494 DIMENSION CHIDEL(3), IUEDPR(25)
24495 DIMENSION IUEDEQ(KKFLMA),MUED(2)
24496 COMMON/SW1/SW21,CW21
24497 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
24498 & 6100001,6100002,6100003,6100004,6100005,6100006,
24499 & 5100001,5100002,5100003,5100004,5100005,5100006,
24500 & 6100011,6100013,6100015,
24501 & 5100012,5100011,5100014,5100013,5100016,5100015,
24502 & 5100021,5100022,5100023,5100024/
24503 C...Save local variables
24504 SAVE MOFSV,WIDWSV,WID2SV
24506 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
24507 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
24509 C...UED: inline functions used in kk width calculus
24510 FKAC1(X,Y)=1.-X**2/Y**2
24511 FKAC2(X,Y)=2.+X**2/Y**2
24513 C...Compressed code and sign; mass.
24520 C...Reset width information.
24521 DO 110 I=0,MDCY(KC,3)
24528 C...Allow for fudge factor to rescale resonance width.
24530 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
24531 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
24532 IF(MSTP(110).EQ.KFLA) THEN
24534 ELSEIF(MSTP(110).EQ.-1) THEN
24535 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
24536 ELSEIF(MSTP(110).EQ.-2) THEN
24541 C...Not to be treated as a resonance: return.
24542 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
24551 C...Treatment as a resonance based on tabulated branching ratios.
24552 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
24553 C...Loop over possible decay channels; skip irrelevant ones.
24554 DO 120 I=1,MDCY(KC,3)
24556 IF(MDME(IDC,1).LT.0) GOTO 120
24558 C...Read out decay products and nominal masses.
24561 C...Skip dummy modes or unrecognized particles
24562 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
24563 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
24567 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
24573 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
24577 C...Naive partial width and alternative threshold factors.
24578 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
24579 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
24580 & PM1+PM2+PM3.GE.SHR) THEN
24582 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
24583 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
24584 & 4D0*PM1**2*PM2**2))/SH
24585 ELSEIF(MDME(IDC,2).EQ.52) THEN
24586 PMA=MAX(PM1,PM2,PM3)
24587 PMC=MIN(PM1,PM2,PM3)
24588 PMB=PM1+PM2+PM3-PMA-PMC
24589 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
24594 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
24595 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24596 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24597 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24598 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24599 & ((1D0-PMBCN)*PMBCN*SH)
24600 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
24601 WDTP(I)=WDTP(I)*SQRT(
24602 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
24603 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
24604 ELSEIF(MDME(IDC,2).EQ.53) THEN
24605 PMA=MAX(PM1,PM2,PM3)
24606 PMC=MIN(PM1,PM2,PM3)
24607 PMB=PM1+PM2+PM3-PMA-PMC
24608 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
24613 FACACT=SQRT(MAX(0D0,
24614 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24615 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24616 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24617 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24618 & ((1D0-PMBCN)*PMBCN*SH)
24619 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
24623 PMBCN=PMBC**2/PMR**2
24624 FACNOM=SQRT(MAX(0D0,
24625 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24626 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24627 & ((PMR-PMA)**2-(PMB+PMC)**2)*
24628 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
24629 & ((1D0-PMBCN)*PMBCN*PMR**2)
24630 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
24632 WDTP(I)=FUDGE*WDTP(I)
24633 WDTP(0)=WDTP(0)+WDTP(I)
24635 C...Calculate secondary width (at most two identical/opposite).
24637 IF(MDME(IDC,1).GT.0) THEN
24638 IF(KFD2.EQ.KFD1) THEN
24639 IF(KCHG(KFC1,3).EQ.0) THEN
24641 ELSEIF(KFD1.GT.0) THEN
24647 WID2=WID2*WIDS(KFC3,2)
24648 ELSEIF(KFD3.LT.0) THEN
24649 WID2=WID2*WIDS(KFC3,3)
24651 ELSEIF(KFD2.EQ.-KFD1) THEN
24654 WID2=WID2*WIDS(KFC3,2)
24655 ELSEIF(KFD3.LT.0) THEN
24656 WID2=WID2*WIDS(KFC3,3)
24658 ELSEIF(KFD3.EQ.KFD1) THEN
24659 IF(KCHG(KFC1,3).EQ.0) THEN
24661 ELSEIF(KFD1.GT.0) THEN
24667 WID2=WID2*WIDS(KFC2,2)
24668 ELSEIF(KFD2.LT.0) THEN
24669 WID2=WID2*WIDS(KFC2,3)
24671 ELSEIF(KFD3.EQ.-KFD1) THEN
24674 WID2=WID2*WIDS(KFC2,2)
24675 ELSEIF(KFD2.LT.0) THEN
24676 WID2=WID2*WIDS(KFC2,3)
24678 ELSEIF(KFD3.EQ.KFD2) THEN
24679 IF(KCHG(KFC2,3).EQ.0) THEN
24681 ELSEIF(KFD2.GT.0) THEN
24687 WID2=WID2*WIDS(KFC1,2)
24688 ELSEIF(KFD1.LT.0) THEN
24689 WID2=WID2*WIDS(KFC1,3)
24691 ELSEIF(KFD3.EQ.-KFD2) THEN
24694 WID2=WID2*WIDS(KFC1,2)
24695 ELSEIF(KFD1.LT.0) THEN
24696 WID2=WID2*WIDS(KFC1,3)
24705 WID2=WID2*WIDS(KFC2,2)
24707 WID2=WID2*WIDS(KFC2,3)
24710 WID2=WID2*WIDS(KFC3,2)
24711 ELSEIF(KFD3.LT.0) THEN
24712 WID2=WID2*WIDS(KFC3,3)
24716 C...Store effective widths according to case.
24717 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24718 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24719 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24720 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24730 C...Here begins detailed dynamical calculation of resonance widths.
24731 C...Shared treatment of Higgs states.
24734 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24739 C...Common electroweak and strong constants.
24742 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24745 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24747 RADC=1D0+AS/PARU(1)
24751 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24752 RADCT=1D0-2.5D0*AS/PARU(1)
24753 DO 140 I=1,MDCY(KC,3)
24755 IF(MDME(IDC,1).LT.0) GOTO 140
24756 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24757 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24758 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24760 IF(I.GE.4.AND.I.LE.7) THEN
24761 C...t -> W + q; including approximate QCD correction factor.
24762 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24763 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24764 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24767 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24770 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24772 ELSEIF(I.EQ.9) THEN
24774 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24775 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24776 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24777 & 4D0*SQRT(RM2R*RM2))
24779 IF(KFLR.LT.0) WID2=WIDS(37,3)
24781 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24782 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24785 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24788 KFC1=PYCOMP(KFDP(IDC,1))
24789 KFC2=PYCOMP(KFDP(IDC,2))
24790 PMNCHI=PMAS(KFC1,1)
24791 PMSTOP=PMAS(KFC2,1)
24792 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24795 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24797 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24798 AR=-ET*ZMIXC(IZ,1)*TANW
24799 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24801 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24802 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24803 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24804 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24805 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24806 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24807 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24809 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24811 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24814 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24816 KFC1=PYCOMP(KFDP(IDC,1))
24817 KFC2=PYCOMP(KFDP(IDC,2))
24818 PMNCHI=PMAS(KFC1,1)
24819 PMSTOP=PMAS(KFC2,1)
24820 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24823 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24824 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24825 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24826 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24828 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24830 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24833 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24834 C...t -> ~gravitino + ~t
24836 KFC1=PYCOMP(KFDP(IDC,1))
24837 XMGR2=PMAS(KFC1,1)**2
24838 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24839 KFC2=PYCOMP(KFDP(IDC,2))
24841 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24844 WDTP(I)=FUDGE*WDTP(I)
24845 WDTP(0)=WDTP(0)+WDTP(I)
24846 IF(MDME(IDC,1).GT.0) THEN
24847 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24848 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24849 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24850 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24854 ELSEIF(KFLA.EQ.7) THEN
24856 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24857 DO 150 I=1,MDCY(KC,3)
24859 IF(MDME(IDC,1).LT.0) GOTO 150
24860 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24861 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24862 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24864 IF(I.GE.4.AND.I.LE.7) THEN
24866 WDTP(I)=FAC*VCKM(I-3,4)*
24867 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24868 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24871 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24872 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24875 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24876 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24879 IF(KFLR.LT.0) WID2=WIDS(24,2)
24880 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24882 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24883 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24886 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24889 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24892 WDTP(I)=FUDGE*WDTP(I)
24893 WDTP(0)=WDTP(0)+WDTP(I)
24894 IF(MDME(IDC,1).GT.0) THEN
24895 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24896 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24897 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24898 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24902 ELSEIF(KFLA.EQ.8) THEN
24904 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24905 DO 160 I=1,MDCY(KC,3)
24907 IF(MDME(IDC,1).LT.0) GOTO 160
24908 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24909 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24910 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24912 IF(I.GE.4.AND.I.LE.7) THEN
24914 WDTP(I)=FAC*VCKM(4,I-3)*
24915 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24916 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24919 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24922 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24924 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24926 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24927 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24930 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24933 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24936 WDTP(I)=FUDGE*WDTP(I)
24937 WDTP(0)=WDTP(0)+WDTP(I)
24938 IF(MDME(IDC,1).GT.0) THEN
24939 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24940 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24941 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24942 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24946 ELSEIF(KFLA.EQ.17) THEN
24948 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24949 DO 170 I=1,MDCY(KC,3)
24951 IF(MDME(IDC,1).LT.0) GOTO 170
24952 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24953 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24954 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24957 C...tau' -> W + nu'_tau.
24958 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24959 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24962 WID2=WID2*WIDS(18,2)
24965 WID2=WID2*WIDS(18,3)
24967 ELSEIF(I.EQ.5) THEN
24968 C...tau' -> H + nu'_tau.
24969 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24970 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24973 WID2=WID2*WIDS(18,2)
24976 WID2=WID2*WIDS(18,3)
24979 WDTP(I)=FUDGE*WDTP(I)
24980 WDTP(0)=WDTP(0)+WDTP(I)
24981 IF(MDME(IDC,1).GT.0) THEN
24982 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24983 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24984 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24985 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24989 ELSEIF(KFLA.EQ.18) THEN
24990 C...nu'_tau neutrino.
24991 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24992 DO 180 I=1,MDCY(KC,3)
24994 IF(MDME(IDC,1).LT.0) GOTO 180
24995 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24996 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24997 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
25000 C...nu'_tau -> W + tau'.
25001 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25002 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25005 WID2=WID2*WIDS(17,2)
25008 WID2=WID2*WIDS(17,3)
25010 ELSEIF(I.EQ.3) THEN
25011 C...nu'_tau -> H + tau'.
25012 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25013 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25016 WID2=WID2*WIDS(17,2)
25019 WID2=WID2*WIDS(17,3)
25022 WDTP(I)=FUDGE*WDTP(I)
25023 WDTP(0)=WDTP(0)+WDTP(I)
25024 IF(MDME(IDC,1).GT.0) THEN
25025 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25026 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25027 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25028 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25032 ELSEIF(KFLA.EQ.21) THEN
25034 C***Note that widths are not given in dimensional quantities here.
25035 DO 190 I=1,MDCY(KC,3)
25037 IF(MDME(IDC,1).LT.0) GOTO 190
25038 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25039 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25040 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25043 C...QCD -> q + qbar
25044 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25045 IF(I.EQ.6) WID2=WIDS(6,1)
25046 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25048 WDTP(I)=FUDGE*WDTP(I)
25049 WDTP(0)=WDTP(0)+WDTP(I)
25050 IF(MDME(IDC,1).GT.0) THEN
25051 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25052 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25053 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25054 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25058 ELSEIF(KFLA.EQ.22) THEN
25060 C***Note that widths are not given in dimensional quantities here.
25061 DO 200 I=1,MDCY(KC,3)
25063 IF(MDME(IDC,1).LT.0) GOTO 200
25064 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25065 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25066 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25069 C...QED -> q + qbar.
25072 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25073 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25074 IF(I.EQ.6) WID2=WIDS(6,1)
25075 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25076 ELSEIF(I.LE.12) THEN
25077 C...QED -> l+ + l-.
25078 EF=KCHG(9+2*(I-8),1)/3D0
25079 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25080 IF(I.EQ.12) WID2=WIDS(17,1)
25082 WDTP(I)=FUDGE*WDTP(I)
25083 WDTP(0)=WDTP(0)+WDTP(I)
25084 IF(MDME(IDC,1).GT.0) THEN
25085 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25086 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25087 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25088 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25092 ELSEIF(KFLA.EQ.23) THEN
25095 XWC=1D0/(16D0*XW*XW1)
25096 FAC=(AEM*XWC/3D0)*SHR
25098 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25103 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25105 IF(KFI.GT.20) KFI=IABS(MINT(16))
25111 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25112 IF(MSTP(43).EQ.3) VINT(112)=
25113 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25114 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25115 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25117 DO 220 I=1,MDCY(KC,3)
25119 IF(MDME(IDC,1).LT.0) GOTO 220
25120 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25121 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25122 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25127 AF=SIGN(1D0,EF+0.1D0)
25130 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25131 IF(I.EQ.6) WID2=WIDS(6,1)
25132 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25133 ELSEIF(I.LE.16) THEN
25134 C...Z0 -> l+ + l-, nu + nubar
25136 AF=SIGN(1D0,EF+0.1D0)
25139 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25141 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25142 IF(ICASE.EQ.1) THEN
25143 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25145 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25146 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25147 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25148 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25149 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25150 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25151 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25152 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25154 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25155 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25156 IF(MDME(IDC,1).GT.0) THEN
25157 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25158 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25159 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25160 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25161 & WDTE(I,MDME(IDC,1))
25162 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25163 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25165 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25166 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25167 & VINT(111)+FGGF*WID2
25168 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25169 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25170 & VINT(114)+FZZF*WID2
25174 IF(MINT(61).GE.1) ICASE=3-ICASE
25175 IF(ICASE.EQ.2) GOTO 210
25177 ELSEIF(KFLA.EQ.24) THEN
25179 FAC=(AEM/(24D0*XW))*SHR
25180 DO 230 I=1,MDCY(KC,3)
25182 IF(MDME(IDC,1).LT.0) GOTO 230
25183 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25184 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25185 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25188 C...W+/- -> q + qbar'
25189 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25191 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25192 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25193 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25195 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25196 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25197 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25199 ELSEIF(I.LE.20) THEN
25200 C...W+/- -> l+/- + nu
25203 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25205 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25208 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25209 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25210 WDTP(I)=FUDGE*WDTP(I)
25211 WDTP(0)=WDTP(0)+WDTP(I)
25212 IF(MDME(IDC,1).GT.0) THEN
25213 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25214 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25215 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25216 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25220 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25221 C...h0 (or H0, or A0):
25223 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25224 DO 270 I=1,MDCY(KFHIGG,3)
25225 IDC=I+MDCY(KFHIGG,2)-1
25226 IF(MDME(IDC,1).LT.0) GOTO 270
25227 KFC1=PYCOMP(KFDP(IDC,1))
25228 KFC2=PYCOMP(KFDP(IDC,2))
25229 RM1=PMAS(KFC1,1)**2/SH
25230 RM2=PMAS(KFC2,1)**2/SH
25231 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25237 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25238 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25239 C...A0 behaves like beta, ho and H0 like beta**3.
25240 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25241 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25242 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25243 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25244 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25245 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25246 IF(IHIGG.NE.3) THEN
25247 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25248 & PARU(151+10*IHIGG))**2
25252 IF(I.EQ.6) WID2=WIDS(6,1)
25253 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25254 ELSEIF(I.LE.12) THEN
25256 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25257 C...A0 behaves like beta, ho and H0 like beta**3.
25258 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25259 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25260 & PARU(153+10*IHIGG)**2
25261 IF(I.EQ.12) WID2=WIDS(17,1)
25263 ELSEIF(I.EQ.13) THEN
25264 C...h0 -> g + g; quark loop contribution only
25267 DO 240 J=1,2*MSTP(1)
25268 EPS=(2D0*PMAS(J,1))**2/SH
25269 C...Loop integral; function of eps=4m^2/shat; different for A0.
25270 IF(EPS.LE.1D0) THEN
25271 IF(EPS.GT.1D-4) THEN
25273 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25275 RLN=LOG(4D0/EPS-2D0)
25277 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25278 PHIIM=0.5D0*PARU(1)*RLN
25280 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25283 IF(IHIGG.LE.2) THEN
25284 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25285 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25287 ETAREJ=-0.5D0*EPS*PHIRE
25288 ETAIMJ=-0.5D0*EPS*PHIIM
25290 C...Couplings (=1 for standard model Higgs).
25291 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25292 IF(MOD(J,2).EQ.1) THEN
25293 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25294 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25296 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25297 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25303 ETA2=ETARE**2+ETAIM**2
25304 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25306 ELSEIF(I.EQ.14) THEN
25307 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25311 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25313 IF(J.LE.2*MSTP(1)) THEN
25315 EPS=(2D0*PMAS(J,1))**2/SH
25316 ELSEIF(J.LE.3*MSTP(1)) THEN
25317 JL=2*(J-2*MSTP(1))-1
25318 EJ=KCHG(10+JL,1)/3D0
25319 EPS=(2D0*PMAS(10+JL,1))**2/SH
25320 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25321 EPS=(2D0*PMAS(24,1))**2/SH
25323 EPS=(2D0*PMAS(37,1))**2/SH
25325 C...Loop integral; function of eps=4m^2/shat.
25326 IF(EPS.LE.1D0) THEN
25327 IF(EPS.GT.1D-4) THEN
25329 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25331 RLN=LOG(4D0/EPS-2D0)
25333 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25334 PHIIM=0.5D0*PARU(1)*RLN
25336 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25339 IF(J.LE.3*MSTP(1)) THEN
25340 C...Fermion loops: loop integral different for A0; charges.
25341 IF(IHIGG.LE.2) THEN
25342 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25343 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25345 PHIPRE=-0.5D0*EPS*PHIRE
25346 PHIPIM=-0.5D0*EPS*PHIIM
25348 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25350 EJH=PARU(151+10*IHIGG)
25351 ELSEIF(J.LE.2*MSTP(1)) THEN
25353 EJH=PARU(152+10*IHIGG)
25356 EJH=PARU(153+10*IHIGG)
25358 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25359 ETAREJ=EJC*EJH*PHIPRE
25360 ETAIMJ=EJC*EJH*PHIPIM
25361 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25362 C...W loops: loop integral and charges.
25363 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
25364 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
25365 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25366 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25367 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25370 C...Charged H loops: loop integral and charges.
25371 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
25372 & PARU(158+10*IHIGG+2*(IHIGG/3))
25373 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
25374 ETAIMJ=-EPS**2*PHIIM*FACHHH
25379 ETA2=ETARE**2+ETAIM**2
25380 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
25382 ELSEIF(I.EQ.15) THEN
25383 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25387 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25389 IF(J.LE.2*MSTP(1)) THEN
25391 AJ=SIGN(1D0,EJ+0.1D0)
25393 EPS=(2D0*PMAS(J,1))**2/SH
25394 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
25395 ELSEIF(J.LE.3*MSTP(1)) THEN
25396 JL=2*(J-2*MSTP(1))-1
25397 EJ=KCHG(10+JL,1)/3D0
25398 AJ=SIGN(1D0,EJ+0.1D0)
25400 EPS=(2D0*PMAS(10+JL,1))**2/SH
25401 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
25403 EPS=(2D0*PMAS(24,1))**2/SH
25404 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
25406 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25407 IF(EPS.LE.1D0) THEN
25409 IF(EPS.GT.1D-4) THEN
25410 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25412 RLN=LOG(4D0/EPS-2D0)
25414 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25415 PHIIM=0.5D0*PARU(1)*RLN
25416 PSIRE=0.5D0*ROOT*RLN
25417 PSIIM=-0.5D0*ROOT*PARU(1)
25419 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25421 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
25424 IF(EPSP.LE.1D0) THEN
25425 ROOT=SQRT(1D0-EPSP)
25426 IF(EPSP.GT.1D-4) THEN
25427 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25429 RLN=LOG(4D0/EPSP-2D0)
25431 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
25432 PHIIMP=0.5D0*PARU(1)*RLN
25433 PSIREP=0.5D0*ROOT*RLN
25434 PSIIMP=-0.5D0*ROOT*PARU(1)
25436 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
25438 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
25441 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
25442 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
25443 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
25444 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
25445 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
25446 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
25447 IF(J.LE.3*MSTP(1)) THEN
25448 C...Fermion loops: loop integral different for A0; charges.
25449 IF(IHIGG.EQ.3) FXYRE=0D0
25450 IF(IHIGG.EQ.3) FXYIM=0D0
25451 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25453 EJH=PARU(151+10*IHIGG)
25454 ELSEIF(J.LE.2*MSTP(1)) THEN
25456 EJH=PARU(152+10*IHIGG)
25459 EJH=PARU(153+10*IHIGG)
25461 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25462 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
25463 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
25464 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25465 C...W loops: loop integral and charges.
25466 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
25467 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
25468 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
25469 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25470 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25471 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25474 C...Charged H loops: loop integral and charges.
25475 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
25476 & PARU(158+10*IHIGG+2*(IHIGG/3))
25477 ETAREJ=FACHHH*FXYRE
25478 ETAIMJ=FACHHH*FXYIM
25483 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
25484 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
25487 ELSEIF(I.LE.17) THEN
25488 C...h0 -> Z0 + Z0, W+ + W-
25489 PM1=PMAS(IABS(KFDP(IDC,1)),1)
25490 PG1=PMAS(IABS(KFDP(IDC,1)),2)
25491 IF(MINT(62).GE.1) THEN
25492 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
25493 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
25494 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
25495 MOFSV(IHIGG,I-15)=0
25496 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25500 MOFSV(IHIGG,I-15)=1
25501 RMAS=SQRT(MAX(0D0,SH))
25502 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
25504 WIDWSV(IHIGG,I-15)=WIDW
25505 WID2SV(IHIGG,I-15)=WID2
25508 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
25509 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25513 WIDW=WIDWSV(IHIGG,I-15)
25514 WID2=WID2SV(IHIGG,I-15)
25517 WDTP(I)=FAC*WIDW/(2D0*(18-I))
25518 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
25519 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25520 & PARU(138+I+10*IHIGG)**2
25521 WID2=WID2*WIDS(7+I,1)
25523 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
25524 C...H0 -> Z0 + h0, A0-> Z0 + h0
25525 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25526 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25527 IF(IHIGG.EQ.2) THEN
25528 WDTP(I)=WDTP(I)*PARU(179)**2
25529 ELSEIF(IHIGG.EQ.3) THEN
25530 WDTP(I)=WDTP(I)*PARU(186)**2
25532 WID2=WIDS(23,2)*WIDS(25,2)
25534 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
25535 C...H0 -> h0 + h0, A0-> h0 + h0
25536 WDTP(I)=FAC*0.25D0*
25537 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25538 IF(IHIGG.EQ.2) THEN
25539 WDTP(I)=WDTP(I)*PARU(176)**2
25540 ELSEIF(IHIGG.EQ.3) THEN
25541 WDTP(I)=WDTP(I)*PARU(169)**2
25544 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
25545 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25546 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25547 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25548 & *PARU(195+IHIGG)**2
25550 WID2=WIDS(24,2)*WIDS(37,3)
25551 ELSEIF(I.EQ.21) THEN
25552 WID2=WIDS(24,3)*WIDS(37,2)
25555 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
25557 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
25558 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25559 WID2=WIDS(36,2)*WIDS(23,2)
25561 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
25563 WDTP(I)=FAC*0.5D0*PARU(180)**2*
25564 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25565 WID2=WIDS(25,2)*WIDS(36,2)
25567 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
25569 WDTP(I)=FAC*0.25D0*PARU(177)**2*
25570 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25575 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25578 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25579 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25580 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25585 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25587 IF(KFC2.EQ.KFC1) THEN
25591 IF(KFDP(IDC,1).LT.0) KSGN1=3
25593 IF(KFDP(IDC,2).LT.0) KSGN2=3
25594 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25597 WDTP(I)=FUDGE*WDTP(I)
25598 WDTP(0)=WDTP(0)+WDTP(I)
25599 IF(MDME(IDC,1).GT.0) THEN
25600 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25601 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25602 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25603 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25607 ELSEIF(KFLA.EQ.32) THEN
25610 XWC=1D0/(16D0*XW*XW1)
25611 FAC=(AEM*XWC/3D0)*SHR
25614 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25622 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25623 KFAI=IABS(MINT(15))
25624 EI=KCHG(KFAI,1)/3D0
25625 AI=SIGN(1D0,EI+0.1D0)
25628 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
25629 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
25630 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
25631 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
25632 VPI=PARU(119+2*KFAIC)
25633 API=PARU(120+2*KFAIC)
25634 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
25635 VPI=PARJ(178+2*KFAIC)
25636 API=PARJ(179+2*KFAIC)
25638 VPI=PARJ(186+2*KFAIC)
25639 API=PARJ(187+2*KFAIC)
25643 SQMZP=PMAS(32,1)**2
25645 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25646 & MSTP(44).EQ.7) VINT(111)=1D0
25647 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
25648 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25649 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
25650 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
25651 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25652 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25653 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
25654 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
25655 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
25656 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25657 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
25659 DO 290 I=1,MDCY(KC,3)
25661 IF(MDME(IDC,1).LT.0) GOTO 290
25662 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25663 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25664 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
25668 C...Z'0 -> q + qbar
25670 AF=SIGN(1D0,EF+0.1D0)
25673 VPF=PARU(123-2*MOD(I,2))
25674 APF=PARU(124-2*MOD(I,2))
25675 ELSEIF(I.LE.4) THEN
25676 VPF=PARJ(182-2*MOD(I,2))
25677 APF=PARJ(183-2*MOD(I,2))
25679 VPF=PARJ(190-2*MOD(I,2))
25680 APF=PARJ(191-2*MOD(I,2))
25683 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25684 & PYHFTH(SH,SH*RM1,1D0)
25685 IF(I.EQ.6) WID2=WIDS(6,1)
25686 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25687 ELSEIF(I.LE.16) THEN
25688 C...Z'0 -> l+ + l-, nu + nubar
25690 AF=SIGN(1D0,EF+0.1D0)
25693 VPF=PARU(127-2*MOD(I,2))
25694 APF=PARU(128-2*MOD(I,2))
25695 ELSEIF(I.LE.12) THEN
25696 VPF=PARJ(186-2*MOD(I,2))
25697 APF=PARJ(187-2*MOD(I,2))
25699 VPF=PARJ(194-2*MOD(I,2))
25700 APF=PARJ(195-2*MOD(I,2))
25703 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25705 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25706 IF(ICASE.EQ.1) THEN
25707 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25708 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
25709 & APF**2*(1D0-4D0*RM1))*BE34
25710 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25711 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25712 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
25713 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
25714 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
25715 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
25716 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
25717 ELSEIF(MINT(61).EQ.2) THEN
25718 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25719 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25720 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
25721 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25722 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
25724 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
25727 ELSEIF(I.EQ.17) THEN
25729 WDTPZP=PARU(129)**2*XW1**2*
25730 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25731 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25732 IF(ICASE.EQ.1) THEN
25735 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25736 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25737 ELSEIF(MINT(61).EQ.2) THEN
25746 ELSEIF(I.EQ.18) THEN
25748 CZC=2D0*(1D0-2D0*XW)
25749 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25750 IF(ICASE.EQ.1) THEN
25751 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25752 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25753 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25754 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25755 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25756 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25757 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25758 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25759 ELSEIF(MINT(61).EQ.2) THEN
25761 FGZF=0.25D0*PARU(142)*CZC*BE34C
25762 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25763 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25764 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25765 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25768 ELSEIF(I.EQ.19) THEN
25769 C...Z'0 -> Z0 + gamma.
25770 ELSEIF(I.EQ.20) THEN
25772 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25773 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25774 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25775 IF(ICASE.EQ.1) THEN
25778 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25779 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25780 ELSEIF(MINT(61).EQ.2) THEN
25788 WID2=WIDS(23,2)*WIDS(25,2)
25789 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25790 C...Z' -> h0 + A0 or H0 + A0.
25791 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25799 IF(ICASE.EQ.1) THEN
25800 WDTPZ=CZAH**2*BE34C
25801 WDTP(I)=FAC*CZPAH**2*BE34C
25802 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25803 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25804 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25806 ELSEIF(MINT(61).EQ.2) THEN
25811 FZZPF=CZAH*CZPAH*BE34C
25812 FZPZPF=CZPAH**2*BE34C
25814 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25815 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25817 IF(ICASE.EQ.1) THEN
25818 VINT(117)=VINT(117)+FAC*WDTPZ
25819 WDTP(I)=FUDGE*WDTP(I)
25820 WDTP(0)=WDTP(0)+WDTP(I)
25822 IF(MDME(IDC,1).GT.0) THEN
25823 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25824 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25825 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25826 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25827 & WDTE(I,MDME(IDC,1))
25828 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25829 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25831 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25832 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25833 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25834 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25836 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25838 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25839 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25840 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25842 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25843 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25847 IF(MINT(61).GE.1) ICASE=3-ICASE
25848 IF(ICASE.EQ.2) GOTO 280
25850 ELSEIF(KFLA.EQ.34) THEN
25852 FAC=(AEM/(24D0*XW))*SHR
25853 DO 300 I=1,MDCY(KC,3)
25855 IF(MDME(IDC,1).LT.0) GOTO 300
25856 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25857 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25858 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25862 C...W'+/- -> q + qbar'
25863 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25864 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25866 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25867 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25868 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25870 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25871 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25872 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25874 ELSEIF(I.LE.20) THEN
25875 C...W'+/- -> l+/- + nu
25876 FCOF=PARU(133)**2+PARU(134)**2
25878 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25880 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25883 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25884 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25885 ELSEIF(I.EQ.21) THEN
25886 C...W'+/- -> W+/- + Z0
25887 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25888 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25889 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25890 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25891 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25892 ELSEIF(I.EQ.23) THEN
25893 C...W'+/- -> W+/- + h0
25894 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25895 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25896 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25897 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25899 WDTP(I)=FUDGE*WDTP(I)
25900 WDTP(0)=WDTP(0)+WDTP(I)
25901 IF(MDME(IDC,1).GT.0) THEN
25902 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25903 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25904 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25905 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25909 ELSEIF(KFLA.EQ.37) THEN
25911 C IF(MSTP(49).EQ.0) THEN
25914 C SHFS=PMAS(37,1)**2
25916 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25917 DO 310 I=1,MDCY(KC,3)
25919 IF(MDME(IDC,1).LT.0) GOTO 310
25920 KFC1=PYCOMP(KFDP(IDC,1))
25921 KFC2=PYCOMP(KFDP(IDC,2))
25922 RM1=PMAS(KFC1,1)**2/SH
25923 RM2=PMAS(KFC2,1)**2/SH
25924 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25927 C...H+/- -> q + qbar'
25928 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25929 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25930 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25931 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25932 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25934 IF(I.EQ.3) WID2=WIDS(6,2)
25935 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25937 IF(I.EQ.3) WID2=WIDS(6,3)
25938 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25940 ELSEIF(I.LE.8) THEN
25941 C...H+/- -> l+/- + nu
25942 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25943 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25944 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25946 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25948 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25950 ELSEIF(I.EQ.9) THEN
25951 C...H+/- -> W+/- + h0.
25952 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25953 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25954 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25955 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25959 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25962 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25963 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25964 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25969 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25972 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25974 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25975 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25977 WDTP(I)=FUDGE*WDTP(I)
25978 WDTP(0)=WDTP(0)+WDTP(I)
25979 IF(MDME(IDC,1).GT.0) THEN
25980 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25981 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25982 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25983 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25987 ELSEIF(KFLA.EQ.41) THEN
25989 FAC=(AEM/(12D0*XW))*SHR
25990 DO 320 I=1,MDCY(KC,3)
25992 IF(MDME(IDC,1).LT.0) GOTO 320
25993 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25994 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25995 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
26000 ELSEIF(I.LE.9) THEN
26004 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26005 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26007 IF(I.EQ.4) WID2=WIDS(6,3)
26008 IF(I.EQ.5) WID2=WIDS(7,3)
26009 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26010 IF(I.EQ.9) WID2=WIDS(17,3)
26012 IF(I.EQ.4) WID2=WIDS(6,2)
26013 IF(I.EQ.5) WID2=WIDS(7,2)
26014 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26015 IF(I.EQ.9) WID2=WIDS(17,2)
26017 WDTP(I)=FUDGE*WDTP(I)
26018 WDTP(0)=WDTP(0)+WDTP(I)
26019 IF(MDME(IDC,1).GT.0) THEN
26020 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26021 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26022 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26023 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26027 ELSEIF(KFLA.EQ.42) THEN
26028 C...LQ (leptoquark).
26029 FAC=(AEM/4D0)*PARU(151)*SHR
26030 DO 330 I=1,MDCY(KC,3)
26032 IF(MDME(IDC,1).LT.0) GOTO 330
26033 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26034 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26035 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26036 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26038 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26039 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26040 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26041 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26042 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26043 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26044 WDTP(I)=FUDGE*WDTP(I)
26045 WDTP(0)=WDTP(0)+WDTP(I)
26046 IF(MDME(IDC,1).GT.0) THEN
26047 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26048 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26049 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26050 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26054 C...UED: kk state width decays : flav: 451 476
26055 ELSEIF(IUED(1).EQ.1.AND.
26056 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26057 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26059 C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26060 RMFLAS=PMAS(KCLA,1)
26061 FACSH=SH/PMAS(KCLA,1)**2
26062 ALPHEM=PYALEM(RMFLAS**2)
26063 ALPHS=PYALPS(RMFLAS**2)
26065 C...uedcor parameters (alpha_s is calculated at mkk scale)
26066 C...alpha_em is calculated at z pole !
26070 DO 1070 I=1,MDCY(KCLA,3)
26071 IDC=I+MDCY(KCLA,2)-1
26073 IF(MDME(IDC,1).LT.0) GOTO 1070
26074 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26075 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26076 RM1=PMAS(KFC1,1)**2/SH
26077 RM2=PMAS(KFC2,1)**2/SH
26078 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26082 C...N.B. RINV=RUED(1)
26088 KKCLA=KCLA-KKFLMI+1
26089 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26090 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26091 IF(KKCLA.LE.6) THEN
26092 C...q*_S -> q + gamma* (in first time sw21=0)
26093 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26094 C...Eventually change the following by enabling a choice of open or closed.
26095 C...Only the gamma_kk channel is open.
26097 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26098 WDTP(I)=FACSH*WDTP(I)
26100 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26101 C...q*_D -> q + Z*/W*
26102 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26103 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26113 WDTP(I)=FACSH*WDTP(I)
26114 C...q*_D -> q + gamma* is closed
26115 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26116 C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26117 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26119 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26120 + FKAC1(RMGAKK,RMFLAS)**2
26121 WDTP(I)=FACSH*WDTP(I)
26123 ELSEIF(KKCLA.EQ.22)THEN
26124 RMQST=PMAS(KKPART,1)
26125 WID2=WIDS(KKPART,2)
26126 C...g* -> q*_S/q*_D + q
26127 FAC=10.*ALPHS/12.*RMFLAS
26128 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26129 WDTP(I)=FACSH*WDTP(I)
26130 ELSEIF(KKCLA.EQ.23)THEN
26131 C...gamma* decays to graviton + gamma : initial value is used
26133 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26135 ELSEIF(KKCLA.EQ.24)THEN
26136 C...Z* -> l*_S + l is closed
26137 C... Z* -> l*_D + l
26138 IF(I.LE.3)GOTO 1070
26139 c... After closing the channels for a Z* decaying into positively charged
26140 C... KK lepton singlets, close the channels for a Z* decaying into negatively
26141 C... charged KK lepton singlets + positively charged SM particles
26142 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26143 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26144 RMLST=PMAS(KKPART,1)
26145 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26146 WDTP(I)=FACSH*WDTP(I)
26147 WID2=WIDS(KKPART,2)
26148 ELSEIF(KKCLA.EQ.25)THEN
26149 C...W* -> l*_D lbar
26150 FAC=3.*ALPHEM/12./SW2*RMWKK
26151 RMLST=PMAS(KKPART,1)
26152 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26153 WDTP(I)=FACSH*WDTP(I)
26154 WID2=WIDS(KKPART,2)
26156 WDTP(0)=WDTP(0)+WDTP(I)
26157 IF(MDME(IDC,1).GT.0) THEN
26158 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26159 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26160 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26161 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26166 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26167 C...Techni-pi0 and techni-pi0':
26168 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26169 DO 340 I=1,MDCY(KC,3)
26171 IF(MDME(IDC,1).LT.0) GOTO 340
26172 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26173 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26176 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26180 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26181 & /(8D0*PARU(1))*SH*SHR
26182 IF(KFLA.EQ.KTECHN+111) THEN
26189 C...pi_tc -> f + fbar.
26191 IKA=IABS(KFDP(IDC,1))
26192 IF(IKA.LT.10) FCOF=3D0*RADC
26195 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26196 FCOF=FCOF*RTCM(1+IKA)**2
26197 HM1=PYMRUN(KFDP(IDC,1),SH)
26198 HM2=PYMRUN(KFDP(IDC,2),SH)
26199 ELSEIF(IKA.EQ.15) THEN
26200 FCOF=FCOF*RTCM(8)**2
26202 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26203 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26205 WDTP(I)=FUDGE*WDTP(I)
26206 WDTP(0)=WDTP(0)+WDTP(I)
26207 IF(MDME(IDC,1).GT.0) THEN
26208 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26209 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26210 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26211 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26215 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26217 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26218 DO 350 I=1,MDCY(KC,3)
26220 IF(MDME(IDC,1).LT.0) GOTO 350
26221 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26222 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26224 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26228 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26230 C...pi_tc -> f + f'.
26232 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26233 C...pi_tc+ -> W b b~
26234 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26236 XMT2=PMAS(6,1)**2/SH
26237 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26238 KFC3=PYCOMP(KFDP(IDC,3))
26239 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26241 T0 = (1D0-CHECK**2)*
26242 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26243 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26244 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26245 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26246 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26247 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26256 IKA=IABS(KFDP(IDC,1))
26257 IF(IKA.LT.10) FCOF=3D0*RADC
26260 IF(I.GE.1.AND.I.LE.5) THEN
26262 FCOF=FCOF*RTCM(5)**2
26263 ELSEIF(I.LE.4) THEN
26264 FCOF=FCOF*RTCM(6)**2
26265 ELSEIF(I.EQ.5) THEN
26266 FCOF=FCOF*RTCM(7)**2
26268 HM1=PYMRUN(KFDP(IDC,1),SH)
26269 HM2=PYMRUN(KFDP(IDC,2),SH)
26270 ELSEIF(I.EQ.8) THEN
26271 FCOF=FCOF*RTCM(8)**2
26273 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26274 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26276 WDTP(I)=FUDGE*WDTP(I)
26277 WDTP(0)=WDTP(0)+WDTP(I)
26278 IF(MDME(IDC,1).GT.0) THEN
26279 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26280 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26281 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26282 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26286 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26288 FAC=(SH/PARP(46)**2)*SHR
26289 DO 360 I=1,MDCY(KC,3)
26291 IF(MDME(IDC,1).LT.0) GOTO 360
26292 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26293 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26294 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26297 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26298 IF(I.EQ.2) WID2=WIDS(6,1)
26300 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26302 WDTP(I)=FUDGE*WDTP(I)
26303 WDTP(0)=WDTP(0)+WDTP(I)
26304 IF(MDME(IDC,1).GT.0) THEN
26305 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26306 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26307 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26308 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26312 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26314 ALPRHT=2.16D0*(3D0/ITCM(1))
26315 FAC=(ALPRHT/12D0)*SHR
26316 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26320 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26322 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26323 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26324 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26325 DO 370 I=1,MDCY(KC,3)
26327 IF(MDME(IDC,1).LT.0) GOTO 370
26328 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26329 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26330 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26333 C...rho_tc0 -> W+ + W-.
26334 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26335 WDTP(I)=FAC*RTCM(3)**4*
26336 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26337 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26338 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26339 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26341 ELSEIF(I.EQ.2) THEN
26342 C...rho_tc0 -> W+ + pi_tc-.
26343 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26344 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26345 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26346 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26347 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26348 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26349 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26350 ELSEIF(I.EQ.3) THEN
26351 C...rho_tc0 -> pi_tc+ + W-.
26352 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26353 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26354 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26355 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
26356 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26357 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
26358 ELSEIF(I.EQ.4) THEN
26359 C...rho_tc0 -> pi_tc+ + pi_tc-.
26360 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26361 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26362 WID2=WIDS(PYCOMP(KTECHN+211),1)
26363 ELSEIF(I.EQ.5) THEN
26364 C...rho_tc0 -> gamma + pi_tc0
26365 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26366 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26368 WID2=WIDS(PYCOMP(KTECHN+111),2)
26369 ELSEIF(I.EQ.6) THEN
26370 C...rho_tc0 -> gamma + pi_tc0'
26371 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26372 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
26373 WID2=WIDS(PYCOMP(KTECHN+221),2)
26374 ELSEIF(I.EQ.7) THEN
26375 C...rho_tc0 -> Z0 + pi_tc0
26376 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26377 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26379 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26380 ELSEIF(I.EQ.8) THEN
26381 C...rho_tc0 -> Z0 + pi_tc0'
26382 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26383 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26385 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26386 ELSEIF(I.EQ.9) THEN
26387 C...rho_tc0 -> gamma + Z0
26388 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26389 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26391 ELSEIF(I.EQ.10) THEN
26392 C...rho_tc0 -> Z0 + Z0
26393 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26394 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
26398 C...rho_tc0 -> f + fbar.
26403 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26407 IF(IA.GE.17) WID2=WIDS(IA,1)
26410 AI=SIGN(1D0,EI+0.1D0)
26414 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26415 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26416 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26417 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26419 WDTP(I)=FUDGE*WDTP(I)
26420 WDTP(0)=WDTP(0)+WDTP(I)
26421 IF(MDME(IDC,1).GT.0) THEN
26422 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26423 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26424 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26425 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26429 ELSEIF(KFLA.EQ.KTECHN+213) THEN
26431 ALPRHT=2.16D0*(3D0/ITCM(1))
26432 FAC=(ALPRHT/12D0)*SHR
26436 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26438 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26439 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26440 DO 380 I=1,MDCY(KC,3)
26442 IF(MDME(IDC,1).LT.0) GOTO 380
26443 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26444 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26445 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
26447 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26448 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26451 C...rho_tc+ -> W+ + Z0.
26453 WDTP(I)=FAC*RTCM(3)**4*
26454 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26455 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
26456 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
26458 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
26461 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
26463 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26466 WID2=WIDS(24,2)*WIDS(23,2)
26468 WID2=WIDS(24,3)*WIDS(23,2)
26470 ELSEIF(I.EQ.2) THEN
26471 C...rho_tc+ -> W+ + pi_tc0.
26472 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26473 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26474 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26475 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26476 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26478 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
26480 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
26482 ELSEIF(I.EQ.3) THEN
26483 C...rho_tc+ -> pi_tc+ + Z0.
26484 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26485 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26486 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26487 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
26488 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
26489 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26490 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26493 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
26495 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
26497 ELSEIF(I.EQ.4) THEN
26498 C...rho_tc+ -> pi_tc+ + pi_tc0.
26499 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26500 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26502 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
26504 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
26506 ELSEIF(I.EQ.5) THEN
26507 C...rho_tc+ -> pi_tc+ + gamma
26508 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26509 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26512 WID2=WIDS(PYCOMP(KTECHN+211),2)
26514 WID2=WIDS(PYCOMP(KTECHN+211),3)
26516 ELSEIF(I.EQ.6) THEN
26517 C...rho_tc+ -> W+ + pi_tc0'
26518 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26519 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
26521 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
26523 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
26525 ELSEIF(I.EQ.7) THEN
26526 C...rho_tc+ -> W+ + gamma
26527 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26528 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26535 C...rho_tc+ -> f + fbar'.
26539 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26541 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26542 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26543 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26545 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26546 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26547 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26552 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26554 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26557 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26558 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26560 WDTP(I)=FUDGE*WDTP(I)
26561 WDTP(0)=WDTP(0)+WDTP(I)
26562 IF(MDME(IDC,1).GT.0) THEN
26563 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26564 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26565 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26566 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26570 ELSEIF(KFLA.EQ.KTECHN+223) THEN
26572 ALPRHT=2.16D0*(3D0/ITCM(1))
26573 FAC=(ALPRHT/12D0)*SHR
26574 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
26577 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26579 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26580 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26581 DO 390 I=1,MDCY(KC,3)
26583 IF(MDME(IDC,1).LT.0) GOTO 390
26584 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26585 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26586 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
26589 C...omega_tc0 -> gamma + pi_tc0.
26590 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
26591 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
26592 WID2=WIDS(PYCOMP(KTECHN+111),2)
26593 ELSEIF(I.EQ.2) THEN
26594 C...omega_tc0 -> Z0 + pi_tc0
26595 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26596 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26598 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26599 ELSEIF(I.EQ.3) THEN
26600 C...omega_tc0 -> gamma + pi_tc0'
26601 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26602 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26604 WID2=WIDS(PYCOMP(KTECHN+221),2)
26605 ELSEIF(I.EQ.4) THEN
26606 C...omega_tc0 -> Z0 + pi_tc0'
26607 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26608 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26610 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26611 ELSEIF(I.EQ.5) THEN
26612 C...omega_tc0 -> W+ + pi_tc-
26613 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26614 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26615 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26616 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26617 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26618 ELSEIF(I.EQ.6) THEN
26619 C...omega_tc0 -> pi_tc+ + W-
26620 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26621 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26622 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26623 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26624 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26625 ELSEIF(I.EQ.7) THEN
26626 C...omega_tc0 -> W+ + W-.
26627 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26628 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
26629 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26630 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26631 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
26633 ELSEIF(I.EQ.8) THEN
26634 C...omega_tc0 -> pi_tc+ + pi_tc-.
26635 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
26636 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26637 WID2=WIDS(PYCOMP(KTECHN+211),1)
26638 C...omega_tc0 -> gamma + Z0
26639 ELSEIF(I.EQ.9) THEN
26640 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26641 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26643 C...omega_tc0 -> Z0 + Z0
26644 ELSEIF(I.EQ.10) THEN
26645 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26646 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
26647 & /24D0/RTCM(12)**2*SHR**3
26650 C...omega_tc0 -> f + fbar.
26655 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26659 IF(IA.GE.17) WID2=WIDS(IA,1)
26662 AI=SIGN(1D0,EI+0.1D0)
26664 VALI=-0.5D0*(VI+AI)
26665 VARI=-0.5D0*(VI-AI)
26666 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26667 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26668 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26669 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26671 WDTP(I)=FUDGE*WDTP(I)
26672 WDTP(0)=WDTP(0)+WDTP(I)
26673 IF(MDME(IDC,1).GT.0) THEN
26674 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26675 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26676 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26677 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26681 C.....V8 -> quark anti-quark
26682 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
26685 IF(ITCM(2).EQ.0) THEN
26687 ELSEIF(ITCM(2).EQ.1) THEN
26690 DO 400 I=1,MDCY(KC,3)
26692 IF(MDME(IDC,1).LT.0) GOTO 400
26693 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26695 IF(RM1.GT.0.25D0) GOTO 400
26697 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26702 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
26703 IF(I.EQ.6) WID2=WIDS(6,1)
26704 WDTP(I)=FUDGE*WDTP(I)
26705 WDTP(0)=WDTP(0)+WDTP(I)
26706 IF(MDME(IDC,1).GT.0) THEN
26707 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26708 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26709 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26710 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26714 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
26715 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
26717 DO 410 I=1,MDCY(KC,3)
26719 IF(MDME(IDC,1).LT.0) GOTO 410
26720 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26721 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26722 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
26726 IF(KFLA.EQ.KTECHN+100111) THEN
26731 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
26732 & /(2D0*PARU(1))*SH*SHR*CLEBG
26735 C...pi_tc -> f + fbar.
26736 IF(I.EQ.6) WID2=WIDS(6,1)
26738 IKA=IABS(KFDP(IDC,1))
26739 IF(IKA.LT.10) FCOF=3D0*RADC
26740 HM1=PYMRUN(KFDP(IDC,1),SH)
26741 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
26742 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26744 WDTP(I)=FUDGE*WDTP(I)
26745 WDTP(0)=WDTP(0)+WDTP(I)
26746 IF(MDME(IDC,1).GT.0) THEN
26747 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26748 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26749 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26750 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26754 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
26756 ALPRHT=2.16D0*(3D0/ITCM(1))
26758 SIN2T=2D0*TANT3/(TANT3**2+1D0)
26759 SINT3=TANT3/SQRT(TANT3**2+1D0)
26762 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
26763 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
26764 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
26765 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
26766 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
26768 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
26770 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
26772 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
26774 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
26775 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
26776 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
26777 IF(ITCM(2).EQ.0) THEN
26782 DO 420 I=1,MDCY(KC,3)
26783 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
26784 & KFLA.EQ.KTECHN+300113)) GOTO 420
26786 IF(MDME(IDC,1).LT.0) GOTO 420
26787 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26788 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26789 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
26792 IF(I.EQ.6) WID2=WIDS(6,1)
26794 IF(KFLA.EQ.KTECHN+200113) THEN
26797 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
26800 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
26805 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26806 FMIX=1D0/TANT3/SIN2T
26810 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
26811 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
26812 ELSEIF(I.EQ.7) THEN
26813 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
26814 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
26815 PSH=SHR*(1D0-RM1)/2D0
26816 WDTP(I)=AS/9D0*PSH**3/RM82
26818 WDTP(I)=2D0*WDTP(I)*CSXPP**2
26819 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26821 WDTP(I)=5D0*WDTP(I)
26822 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26825 WDTP(I)=FUDGE*WDTP(I)
26826 WDTP(0)=WDTP(0)+WDTP(I)
26827 IF(MDME(IDC,1).GT.0) THEN
26828 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26829 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26830 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26831 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26835 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
26836 C...d* excited quark.
26837 FAC=(SH/RTCM(41)**2)*SHR
26838 DO 430 I=1,MDCY(KC,3)
26840 IF(MDME(IDC,1).LT.0) GOTO 430
26841 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26842 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26843 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
26847 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26849 ELSEIF(I.EQ.2) THEN
26850 C...d* -> gamma + d.
26851 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26852 WDTP(I)=FAC*AEM*QF**2/4D0
26854 ELSEIF(I.EQ.3) THEN
26856 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26857 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26858 & (1D0-RM1)**2*(2D0+RM1)
26860 ELSEIF(I.EQ.4) THEN
26862 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26863 & (1D0-RM1)**2*(2D0+RM1)
26864 IF(KFLR.GT.0) WID2=WIDS(24,3)
26865 IF(KFLR.LT.0) WID2=WIDS(24,2)
26867 WDTP(I)=FUDGE*WDTP(I)
26868 WDTP(0)=WDTP(0)+WDTP(I)
26869 IF(MDME(IDC,1).GT.0) THEN
26870 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26871 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26872 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26873 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26877 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26878 C...u* excited quark.
26879 FAC=(SH/RTCM(41)**2)*SHR
26880 DO 440 I=1,MDCY(KC,3)
26882 IF(MDME(IDC,1).LT.0) GOTO 440
26883 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26884 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26885 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26889 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26891 ELSEIF(I.EQ.2) THEN
26892 C...u* -> gamma + u.
26893 QF=RTCM(43)/2D0+RTCM(44)/6D0
26894 WDTP(I)=FAC*AEM*QF**2/4D0
26896 ELSEIF(I.EQ.3) THEN
26898 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26899 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26900 & (1D0-RM1)**2*(2D0+RM1)
26902 ELSEIF(I.EQ.4) THEN
26904 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26905 & (1D0-RM1)**2*(2D0+RM1)
26906 IF(KFLR.GT.0) WID2=WIDS(24,2)
26907 IF(KFLR.LT.0) WID2=WIDS(24,3)
26909 WDTP(I)=FUDGE*WDTP(I)
26910 WDTP(0)=WDTP(0)+WDTP(I)
26911 IF(MDME(IDC,1).GT.0) THEN
26912 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26913 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26914 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26915 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26919 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26920 C...e* excited lepton.
26921 FAC=(SH/RTCM(41)**2)*SHR
26922 DO 450 I=1,MDCY(KC,3)
26924 IF(MDME(IDC,1).LT.0) GOTO 450
26925 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26926 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26927 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26930 C...e* -> gamma + e.
26931 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26932 WDTP(I)=FAC*AEM*QF**2/4D0
26934 ELSEIF(I.EQ.2) THEN
26936 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26937 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26938 & (1D0-RM1)**2*(2D0+RM1)
26940 ELSEIF(I.EQ.3) THEN
26942 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26943 & (1D0-RM1)**2*(2D0+RM1)
26944 IF(KFLR.GT.0) WID2=WIDS(24,3)
26945 IF(KFLR.LT.0) WID2=WIDS(24,2)
26947 WDTP(I)=FUDGE*WDTP(I)
26948 WDTP(0)=WDTP(0)+WDTP(I)
26949 IF(MDME(IDC,1).GT.0) THEN
26950 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26951 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26952 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26953 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26957 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26958 C...nu*_e excited neutrino.
26959 FAC=(SH/RTCM(41)**2)*SHR
26960 DO 460 I=1,MDCY(KC,3)
26962 IF(MDME(IDC,1).LT.0) GOTO 460
26963 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26964 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26965 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26968 C...nu*_e -> Z0 + nu*_e.
26969 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26970 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26971 & (1D0-RM1)**2*(2D0+RM1)
26973 ELSEIF(I.EQ.2) THEN
26974 C...nu*_e -> W+ + e.
26975 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26976 & (1D0-RM1)**2*(2D0+RM1)
26977 IF(KFLR.GT.0) WID2=WIDS(24,2)
26978 IF(KFLR.LT.0) WID2=WIDS(24,3)
26980 WDTP(I)=FUDGE*WDTP(I)
26981 WDTP(0)=WDTP(0)+WDTP(I)
26982 IF(MDME(IDC,1).GT.0) THEN
26983 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26984 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26985 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26986 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26990 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26991 C...G* (graviton resonance):
26992 FAC=(PARP(50)**2/PARU(1))*SHR
26993 DO 470 I=1,MDCY(KC,3)
26995 IF(MDME(IDC,1).LT.0) GOTO 470
26996 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26997 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26998 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
27003 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
27004 & PYHFTH(SH,SH*RM1,1D0)
27005 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27006 & (1D0+8D0*RM1/3D0)/320D0
27007 IF(I.EQ.6) WID2=WIDS(6,1)
27008 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27009 ELSEIF(I.LE.16) THEN
27010 C...G* -> l+ + l-, nu + nubar
27012 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27013 & (1D0+8D0*RM1/3D0)/320D0
27014 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27015 ELSEIF(I.EQ.17) THEN
27018 ELSEIF(I.EQ.18) THEN
27019 C...G* -> gamma + gamma.
27021 ELSEIF(I.EQ.19) THEN
27023 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27024 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27026 ELSEIF(I.EQ.20) THEN
27028 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27029 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27032 WDTP(I)=FUDGE*WDTP(I)
27033 WDTP(0)=WDTP(0)+WDTP(I)
27034 IF(MDME(IDC,1).GT.0) THEN
27035 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27036 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27037 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27038 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27042 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27043 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27044 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27045 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27046 DO 480 I=1,MDCY(KC,3)
27048 IF(MDME(IDC,1).LT.0) GOTO 480
27049 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27050 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27051 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27052 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27055 C...nu_lR -> l- qbar q'
27056 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27057 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27058 ELSEIF(I.LE.18) THEN
27059 C...nu_lR -> l+ q qbar'
27060 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27061 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27063 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27065 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27067 X=(PM1+PM2+PM3)/SHR
27068 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27070 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27071 WDTP(I)=FAC*FCOF*FX*FY
27072 WDTP(I)=FUDGE*WDTP(I)
27073 WDTP(0)=WDTP(0)+WDTP(I)
27074 IF(MDME(IDC,1).GT.0) THEN
27075 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27076 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27077 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27078 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27082 ELSEIF(KFLA.EQ.9900023) THEN
27084 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27085 DO 490 I=1,MDCY(KC,3)
27087 IF(MDME(IDC,1).LT.0) GOTO 490
27088 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27089 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27090 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27094 C...Z_R0 -> q + qbar
27096 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27097 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27099 IF(I.EQ.6) WID2=WIDS(6,1)
27100 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27101 C...Z_R0 -> l+ + l-
27105 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27106 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27111 ELSEIF(I.LE.15) THEN
27112 C...Z0 -> nu_R + nu_R, assumed Majorana.
27116 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27119 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27120 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27121 WDTP(I)=FUDGE*WDTP(I)
27122 WDTP(0)=WDTP(0)+WDTP(I)
27123 IF(MDME(IDC,1).GT.0) THEN
27124 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27125 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27126 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27127 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27131 ELSEIF(KFLA.EQ.9900024) THEN
27133 FAC=(AEM/(24D0*XW))*SHR
27134 DO 500 I=1,MDCY(KC,3)
27136 IF(MDME(IDC,1).LT.0) GOTO 500
27137 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27138 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27139 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27142 C...W_R+/- -> q + qbar'
27143 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27145 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27147 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27149 ELSEIF(I.LE.12) THEN
27150 C...W_R+/- -> l+/- + nu_R
27153 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27154 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27155 WDTP(I)=FUDGE*WDTP(I)
27156 WDTP(0)=WDTP(0)+WDTP(I)
27157 IF(MDME(IDC,1).GT.0) THEN
27158 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27159 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27160 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27161 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27165 ELSEIF(KFLA.EQ.9900041) THEN
27167 FAC=(1D0/(8D0*PARU(1)))*SHR
27168 DO 510 I=1,MDCY(KC,3)
27170 IF(MDME(IDC,1).LT.0) GOTO 510
27171 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27172 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27173 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27176 C...H_L++/-- -> l+/- + l'+/-
27177 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27178 & (IABS(KFDP(IDC,2))-9)/2)**2
27179 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27180 ELSEIF(I.EQ.7) THEN
27181 C...H_L++/-- -> W_L+/- + W_L+/-
27182 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27183 & (3D0*RM1+0.25D0/RM1-1D0)
27184 WID2=WIDS(24,4+(1-KFLS)/2)
27187 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27188 WDTP(I)=FUDGE*WDTP(I)
27189 WDTP(0)=WDTP(0)+WDTP(I)
27190 IF(MDME(IDC,1).GT.0) THEN
27191 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27192 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27193 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27194 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27198 ELSEIF(KFLA.EQ.9900042) THEN
27200 FAC=(1D0/(8D0*PARU(1)))*SHR
27201 DO 520 I=1,MDCY(KC,3)
27203 IF(MDME(IDC,1).LT.0) GOTO 520
27204 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27205 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27206 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27209 C...H_R++/-- -> l+/- + l'+/-
27210 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27211 & (IABS(KFDP(IDC,2))-9)/2)**2
27212 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27213 ELSEIF(I.EQ.7) THEN
27214 C...H_R++/-- -> W_R+/- + W_R+/-
27215 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27216 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27219 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27220 WDTP(I)=FUDGE*WDTP(I)
27221 WDTP(0)=WDTP(0)+WDTP(I)
27222 IF(MDME(IDC,1).GT.0) THEN
27223 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27224 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27225 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27226 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27230 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27232 C...Need to update to alpha_rho
27233 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27234 FAC=(ALPRHT/12D0)*SHR
27235 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27239 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27241 XWRHT=1D0/(4D0*XW*(1D0-XW))
27242 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27243 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27244 DO 530 I=1,MDCY(KC,3)
27246 IF(MDME(IDC,1).LT.0) GOTO 530
27247 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27248 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27249 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27251 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27254 FACPA=PCM**2+1.5D0*RM1
27257 C...a2_tc0 -> W+ + W-
27259 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27260 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27262 C...a2_tc0 -> W+ + pi_tc- + c.c.
27263 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27264 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27266 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27268 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27270 ELSEIF(I.EQ.4) THEN
27271 C...a2_tc0 -> Z0 + pi_tc0'
27272 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27273 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27275 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27276 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27277 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27278 FACPA=PCM**2*(1D0+RM1+RM2)
27282 C...a_T^0 -> gamma rho_T^0
27283 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27284 WID2=WIDS(PYCOMP(KTECHN+113),2)
27285 ELSEIF(I.EQ.6) THEN
27286 C...a_T^0 -> gamma omega_T
27287 VA2=1D0/RTCM(50)**4
27288 WID2=WIDS(PYCOMP(KTECHN+223),2)
27289 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27290 C...a_T^0 -> W^+- rho_T^-+
27291 AA2=.25D0/XW/RTCM(51)**4
27293 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27295 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27297 ELSEIF(I.EQ.9) THEN
27298 C...a_T^0 -> Z^0 rho_T^0
27299 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27300 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27301 ELSEIF(I.EQ.10) THEN
27302 C...a_T^0 -> Z^0 omega_T
27303 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27304 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27306 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27308 C...a2_tc0 -> f + fbar.
27313 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27317 IF(IA.GE.17) WID2=WIDS(IA,1)
27320 AI=SIGN(1D0,EI+0.1D0)
27324 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27325 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27326 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27327 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27329 WDTP(I)=FUDGE*WDTP(I)
27330 WDTP(0)=WDTP(0)+WDTP(I)
27331 IF(MDME(IDC,1).GT.0) THEN
27332 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27333 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27334 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27335 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27339 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27341 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27342 FAC=(ALPRHT/12D0)*SHR
27346 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27348 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27349 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27350 DO 540 I=1,MDCY(KC,3)
27352 IF(MDME(IDC,1).LT.0) GOTO 540
27353 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27354 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27355 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
27357 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27366 C...a2_tc+ -> gamma + W+.
27368 AA2=RTCM(3)**2/RTCM(49)**2
27369 WID2=WIDS(24,ICHANN)
27370 C...a2_tc+ -> gamma + pi_tc+.
27371 ELSEIF(I.EQ.2) THEN
27372 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
27373 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
27374 C...a2_tc+ -> W+ + Z
27375 ELSEIF(I.EQ.3) THEN
27376 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
27377 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
27378 WID2=WIDS(24,ICHANN)*WIDS(23,2)
27379 C...a2_tc+ -> W+ + pi_tc0.
27380 ELSEIF(I.EQ.4) THEN
27381 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27382 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
27383 C...a2_tc+ -> W+ + pi_tc'0.
27384 ELSEIF(I.EQ.5) THEN
27385 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
27386 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
27387 C...a2_tc+ -> Z0 + pi_tc+.
27388 ELSEIF(I.EQ.6) THEN
27389 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
27391 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
27393 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27395 ELSEIF(I.LE.10) THEN
27396 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27397 FACPA=PCM**2*(1D0+RM1+RM2)
27400 C...a2_tc+ -> gamma + rho_tc+
27402 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27403 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
27404 C...a2_tc+ -> W+ + rho_T^0
27405 ELSEIF(I.EQ.8) THEN
27406 AA2=1D0/(4D0*XW)/RTCM(51)**4
27407 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
27408 C...a2_tc+ -> W+ + omega_T
27409 ELSEIF(I.EQ.9) THEN
27410 VA2=.25D0/XW/RTCM(50)**4
27411 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
27412 C...a2_tc+ -> Z^0 + rho_T^+
27413 ELSEIF(I.EQ.10) THEN
27414 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27415 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
27416 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
27418 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27420 C...a2_tc+ -> f + fbar'.
27424 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27426 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27427 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27428 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27430 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27431 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27432 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27437 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27439 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27442 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27443 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27445 WDTP(I)=FUDGE*WDTP(I)
27446 WDTP(0)=WDTP(0)+WDTP(I)
27447 IF(MDME(IDC,1).GT.0) THEN
27448 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27449 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27450 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27451 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27462 C***********************************************************************
27465 C...Calculates partial width and differential cross-section maxima
27466 C...of channels/processes not allowed on mass-shell, and selects
27467 C...masses in such channels/processes.
27469 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27471 C...Double precision and integer declarations.
27472 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27473 IMPLICIT INTEGER(I-N)
27474 INTEGER PYK,PYCHGE,PYCOMP
27476 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27477 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27478 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27479 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27480 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27481 COMMON/PYINT1/MINT(400),VINT(400)
27482 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27483 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27484 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
27487 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
27488 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
27489 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
27492 C...Find if particles equal, maximum mass, matrix elements, etc.
27498 IF(KFD(1).EQ.KFD(2)) MEQL=1
27500 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
27501 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
27507 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
27510 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
27511 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
27512 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
27513 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
27514 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
27515 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
27518 C...Find where Breit-Wigners are required, else select discrete masses.
27520 KFCA=PYCOMP(KFD(I))
27522 PMD(I)=PMAS(KFCA,1)
27523 PGD(I)=PMAS(KFCA,2)
27528 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
27531 RMG(I)=(PMG(I)/PMMX)**2
27537 C...Find allowed mass range and Breit-Wigner parameters.
27539 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
27541 PMU(I)=PMMX-PARP(42)
27542 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27543 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27544 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
27546 IF(MLM.EQ.2) ILM=3-I
27547 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
27548 IF(MBW(3-I).EQ.0) THEN
27549 PMU(I)=PMMX-PMD(3-I)
27551 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
27553 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
27554 & MIN(PMU(I),CKIN(NOFF+2*ILM))
27555 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27556 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27557 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27558 IF(MBW(I).EQ.1) THEN
27559 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27560 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27561 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27564 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
27566 IF(MLM.EQ.2) ILM=3-I
27567 PML(I)=MAX(CKIN(48+I),PARP(42))
27568 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
27569 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27570 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27571 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27572 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27573 IF(MBW(I).EQ.1) THEN
27574 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27575 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27576 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27581 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
27583 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
27588 C...Calculation of partial width of resonance.
27589 IF(MOFSH.EQ.1) THEN
27591 C..If only one integration, pick that to be the inner.
27592 IF(MBW(1).EQ.0) THEN
27598 ELSEIF(MBW(2).EQ.0) THEN
27602 C...Start outer loop of integration.
27603 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27604 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27605 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27611 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27612 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
27613 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
27617 C...Start inner loop of integration.
27619 PMU1=MIN(PMU(1),PMMX-PM2)
27620 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
27621 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27622 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27623 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
27631 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
27632 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
27635 C...Evaluate function value - inner loop.
27636 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27637 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
27638 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
27639 & RM2**2+10D0*RM1*RM2)
27640 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
27643 C...Go to next position in inner loop.
27649 ELSEIF(NPT1.LE.8) THEN
27651 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
27653 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27654 INX1(NPT1)=INX1(ISH1)
27657 ELSEIF(NPT1.LT.100) THEN
27660 IF(ISH1.GT.NPT1) ISH1=2
27661 IF(ISH1.EQ.ISN1) GOTO 160
27662 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
27663 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
27665 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27666 INX1(NPT1)=INX1(ISH1)
27671 C...Calculate integral over inner loop.
27674 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
27675 & (XPT1(INX1(IPT1))-XPT1(IPT1))
27677 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
27678 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27679 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
27682 C...Go to next position in outer loop.
27688 ELSEIF(NPT2.LE.8) THEN
27690 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
27692 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27693 INX2(NPT2)=INX2(ISH2)
27696 ELSEIF(NPT2.LT.100) THEN
27699 IF(ISH2.GT.NPT2) ISH2=2
27700 IF(ISH2.EQ.ISN2) GOTO 200
27701 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
27702 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
27704 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27705 INX2(NPT2)=INX2(ISH2)
27710 C...Calculate integral over outer loop.
27713 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
27714 & (XPT2(INX2(IPT2))-XPT2(IPT2))
27716 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
27717 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
27722 C...Save result; second integration for user-selected mass range.
27723 IF(LOOP.EQ.1) WIDW=FSUM2
27725 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
27726 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
27733 C...Select two decay product masses of a resonance.
27734 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
27736 IF(MBW(I).EQ.0) GOTO 230
27737 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
27739 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
27740 RMG(I)=(PMG(I)/PMMX)**2
27742 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27743 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
27745 C...Weight with matrix element (if none known, use beta factor).
27746 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
27748 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
27749 ELSEIF(MMED.EQ.2) THEN
27750 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
27751 & RMG(2)**2+10D0*RMG(1)*RMG(2))
27752 ELSEIF(MMED.EQ.3) THEN
27753 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
27757 IF(WTBE.LT.PYR(0)) GOTO 220
27761 C...Find suitable set of masses for initialization of 2 -> 2 processes.
27762 ELSEIF(MOFSH.EQ.3) THEN
27763 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
27764 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
27766 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
27768 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
27772 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
27773 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
27774 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
27779 C...Evaluate importance of excluded tails of Breit-Wigners.
27780 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27781 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27785 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
27789 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
27790 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
27792 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
27793 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
27794 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
27795 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27797 C...Pick one particle to be the lighter (if improves efficiency).
27798 ELSEIF(MOFSH.EQ.4) THEN
27799 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27800 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27801 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
27803 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27805 IF(MBW(I).EQ.0) GOTO 270
27807 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27809 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27811 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27812 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
27813 IF(RBR.LT.0.8D0) THEN
27814 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
27815 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
27816 ELSEIF(RBR.LT.0.9D0) THEN
27817 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
27818 ELSEIF(RBR.LT.1.5D0) THEN
27819 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
27821 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
27822 & (PMV**2-PML(I)**2))))
27825 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27826 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
27827 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
27828 NGEN(0,1)=NGEN(0,1)+1
27829 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
27839 C...Give weight for selected mass distribution.
27842 IF(MBW(I).EQ.0) GOTO 280
27844 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27846 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27847 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
27848 & (PMD(I)*PGD(I))**2)/PARU(1)
27852 FI0=(ATV-ATL(I))/PARU(1)
27853 FI1=PMV**2-PML(I)**2
27854 FI2=2D0*LOG(PMV/PML(I))
27855 FI3=1D0/PML(I)**2-1D0/PMV**2
27856 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27857 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27858 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27861 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27863 VINT(80)=VINT(80)*FI0
27865 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27871 C***********************************************************************
27874 C...Handles the possibility of colour reconnection in W+W- events,
27875 C...Based on the main scenarios of the Sjostrand and Khoze study:
27876 C...I, II, II', intermediate and instantaneous; plus one model
27877 C...along the lines of the Gustafson and Hakkinen: GH.
27878 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27879 C...is as if first resonance is W+ and second W-.
27881 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27883 C...Double precision and integer declarations.
27884 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27885 IMPLICIT INTEGER(I-N)
27886 INTEGER PYK,PYCHGE,PYCOMP
27887 C...Parameter value; number of points in MC integration.
27888 PARAMETER (NPT=100)
27890 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27891 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27892 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27893 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27894 COMMON/PYINT1/MINT(400),VINT(400)
27895 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27897 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27898 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27899 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27900 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27901 &TMC(20),IJOIN(100)
27903 C...Functions to give four-product and to do determinants.
27904 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)
27905 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27906 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27907 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27909 C...Only allow fraction of recoupling for GH, intermediate and
27911 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27912 IF(PYR(0).GT.PARP(120)) RETURN
27916 C...Common part for scenarios I, II, II', and GH.
27917 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27918 &MSTP(115).EQ.5) THEN
27920 C...Read out frequently-used parameters.
27924 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27926 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27933 C...Find range of decay products of the W's.
27934 C...Background: the W's are stored in IW1 and IW2.
27935 C...Their direct decay products in NSD1+1 through NSD1+4.
27936 C...Products after shower (if any) in NSD1+5 through NAFT1
27937 C...for first W and in NAFT1+1 through N for the second.
27938 IF(NAFT1.GT.NSD1+4) THEN
27945 IF(N.GT.NAFT1) THEN
27953 C...Rearrange parton shower products along strings.
27955 CALL PYPREP(NSD1+1)
27956 IF(MINT(51).NE.0) RETURN
27958 C...Find partons pointing back to W+ and W-; store them with quark
27959 C...end of string first.
27965 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27966 IF(IABS(K(I,2)).GE.22) GOTO 120
27967 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27968 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27978 IF(K(I,1).EQ.1) ISGP=0
27979 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27980 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27990 IF(K(I,1).EQ.1) ISGM=0
27994 C...Boost to W+W- rest frame (not strictly needed).
27996 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27998 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27999 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28000 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28002 C...Select decay vertices of W+ and W-.
28003 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
28004 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
28005 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
28006 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28009 XP(J)=TP*P(IW1,J)/P(IW1,4)
28010 XM(J)=TM*P(IW2,J)/P(IW2,4)
28013 C...Begin scenario I specifics.
28014 IF(MSTP(115).EQ.1) THEN
28016 C...Reconstruct velocity and direction of W+ string pieces.
28018 IF(K(INP(IIP),2).LT.0) GOTO 170
28021 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28022 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28026 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28027 DIRP(IIP,J)=V1(J)-V2(J)
28029 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28031 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28033 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28037 C...Reconstruct velocity and direction of W- string pieces.
28039 IF(K(INM(IIM),2).LT.0) GOTO 200
28042 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28043 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28047 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28048 DIRM(IIM,J)=V1(J)-V2(J)
28050 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28052 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28054 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28058 C...Loop over number of space-time points.
28063 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28064 R=SQRT(-LOG(PYR(0)))
28066 X=BLOWR*RHAD*R*COS(PHI)
28067 Y=BLOWR*RHAD*R*SIN(PHI)
28068 R=SQRT(-LOG(PYR(0)))
28070 Z=BLOWR*RHAD*R*COS(PHI)
28071 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28073 C...Reject impossible points. Weight for sample distribution.
28074 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28075 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28076 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28078 C...Loop over W+ string pieces and find one with largest weight.
28086 IF(K(INP(IIP),2).LT.0) GOTO 220
28087 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28088 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28090 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28092 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28093 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28094 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28095 & DIRP(IIP,3)*XB(3))**2
28096 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28098 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28099 IF(WTP.GT.WTMAXP) THEN
28105 C...Loop over W- string pieces and find one with largest weight.
28113 IF(K(INM(IIM),2).LT.0) GOTO 240
28114 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28115 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28117 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28119 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28120 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28121 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28122 & DIRM(IIM,3)*XB(3))**2
28123 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28125 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28126 IF(WTM.GT.WTMAXM) THEN
28132 C...Result of integration.
28134 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28135 WT=WTMAXP*WTMAXM/WTSMP
28143 RES=BLOWR**3*BLOWT*SUM/NPT
28145 C...Decide whether to reconnect and, if so, where.
28147 PREC=1D0-EXP(-FACT*RES)
28148 IF(PREC.GT.PYR(0)) THEN
28153 IF(RSUM.LE.0D0) GOTO 270
28159 C...Begin scenario II and II' specifics.
28160 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28162 C...Loop through all string pieces, one from W+ and one from W-.
28166 IF(K(INP(IIP),2).LT.0) GOTO 340
28170 IF(K(INM(IIM),2).LT.0) GOTO 330
28174 C...Find endpoint velocity vectors.
28176 V1P(J)=P(I1P,J)/P(I1P,4)
28177 V2P(J)=P(I2P,J)/P(I2P,4)
28178 V1M(J)=P(I1M,J)/P(I1M,4)
28179 V2M(J)=P(I2M,J)/P(I2M,4)
28182 C...Define q matrix and find t.
28184 Q(1,J)=V2P(J)-V1P(J)
28185 Q(2,J)=-(V2M(J)-V1M(J))
28186 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28187 Q(4,J)=V1P(J)-V1M(J)
28189 T=-DETER(1,2,3)/DETER(1,2,4)
28191 C...Find alpha and beta; i.e. coordinates of crossing point.
28194 S13=Q(3,1)+Q(4,1)*T
28197 S23=Q(3,2)+Q(4,2)*T
28198 DEN=S11*S22-S12*S21
28199 ALP=(S12*S23-S22*S13)/DEN
28200 BET=(S21*S13-S11*S23)/DEN
28202 C...Check if solution acceptable.
28204 IF(T.LT.GTMAX) IANSW=0
28205 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28206 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28208 C...Find point of crossing and check that not inconsistent.
28210 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28211 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28213 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28214 & (XPP(3)-XMM(3))**2
28215 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28216 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28217 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28219 C...Find string eigentimes at crossing.
28220 IF(IANSW.EQ.1) THEN
28221 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28222 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28223 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28224 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28230 C...Order crossings by time. End loop over crossings.
28231 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28233 DO 310 I1=NCROSS,1,-1
28234 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28254 C...Loop over crossings; find first (if any) acceptable one.
28256 IF(NCROSS.GE.1) THEN
28258 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28259 IF(PNFRAG.GT.PYR(0)) THEN
28260 C...Scenario II: only compare with fragmentation time.
28261 IF(MSTP(115).EQ.2) THEN
28266 C...Scenario II': also require that string length decreases.
28274 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28275 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28276 IF(ELNEW.LT.ELOLD) THEN
28288 C...Begin scenario GH specifics.
28289 ELSEIF(MSTP(115).EQ.5) THEN
28291 C...Loop through all string pieces, one from W+ and one from W-.
28295 IF(K(INP(IIP),2).LT.0) GOTO 380
28299 IF(K(INM(IIM),2).LT.0) GOTO 370
28303 C...Look for largest decrease of (exponent of) Lambda measure.
28304 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28305 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28306 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28307 IF(ELDIF.LT.ELMIN) THEN
28319 C...Common for scenarios I, II, II' and GH: reconnect strings.
28323 DO 390 IS=1,NNP+NNM
28327 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28329 ELSEIF(IS.LE.IIP+NNM) THEN
28330 I=INM(IS-IIP-NNM+IIM)
28335 IF(K(I,2).LT.0) THEN
28336 CALL PYJOIN(NJOIN,IJOIN)
28341 C...Restore original event record if no reconnection.
28343 DO 400 I=NSD1+1,NOLD
28344 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28345 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28346 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28355 C...Boost back system.
28356 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28357 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28358 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
28359 & BEWW(1),BEWW(2),BEWW(3))
28361 C...Common part for intermediate and instantaneous scenarios.
28362 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28365 C...Remove old shower products and reset showering ones.
28367 DO 420 I=NSD1+1,NSD1+4
28369 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28370 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28373 C...Identify quark-antiquark pairs.
28377 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
28380 C...Reconnect strings.
28383 CALL PYJOIN(2,IJOIN)
28386 CALL PYJOIN(2,IJOIN)
28388 C...Do new parton showers in intermediate scenario.
28389 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
28392 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
28393 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
28396 C...Do new parton showers in instantaneous scenario.
28397 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
28398 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
28399 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
28400 PPM=SQRT(MAX(0D0,PPM2))
28401 CALL PYSHOW(IQ1,IQ4,PPM)
28402 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
28403 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
28404 PPM=SQRT(MAX(0D0,PPM2))
28405 CALL PYSHOW(IQ3,IQ2,PPM)
28412 C***********************************************************************
28415 C...Checks generated variables against pre-set kinematical limits;
28416 C...also calculates limits on variables used in generation.
28418 SUBROUTINE PYKLIM(ILIM)
28420 C...Double precision and integer declarations.
28421 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28422 IMPLICIT INTEGER(I-N)
28423 INTEGER PYK,PYCHGE,PYCOMP
28425 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28426 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28427 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28428 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28429 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28430 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28431 COMMON/PYINT1/MINT(400),VINT(400)
28432 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28433 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28436 C...Common kinematical expressions.
28440 IF(ISUB.EQ.96) GOTO 100
28444 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
28445 CKIN09=MAX(CKIN(9),CKIN(13))
28446 CKIN10=MIN(CKIN(10),CKIN(14))
28447 CKIN11=MAX(CKIN(11),CKIN(15))
28448 CKIN12=MIN(CKIN(12),CKIN(16))
28450 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
28451 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
28452 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
28453 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
28458 RM3=SQM3/(TAU*VINT(2))
28459 RM4=SQM4/(TAU*VINT(2))
28460 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28463 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
28464 &PTHMIN=MAX(CKIN(3),CKIN(5))
28467 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28468 C...pre-set kinematical limits.
28473 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28474 X1=SQRT(TAUE)*EXP(YST)
28475 X2=SQRT(TAUE)*EXP(-YST)
28477 IF(MINT(47).NE.1) THEN
28478 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
28479 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
28480 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
28481 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
28483 IF(MINT(45).NE.1) THEN
28484 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
28486 IF(MINT(46).NE.1) THEN
28487 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
28489 IF(MINT(45).EQ.2) THEN
28490 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28492 IF(MINT(46).EQ.2) THEN
28493 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28495 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28496 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
28497 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
28498 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
28499 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
28500 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
28501 Y3=YST+0.5D0*LOG(EXPY3)
28502 Y4=YST+0.5D0*LOG(EXPY4)
28507 STH=SQRT(MAX(0D0,1D0-CTH**2))
28508 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
28509 & CTH)**2-4D0*RM3))
28510 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
28511 & CTH)**2-4D0*RM4))
28512 IF(STH.GE.1D-10) THEN
28513 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
28515 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
28517 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
28518 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
28519 ETALAR=MAX(ETA3,ETA4)
28520 ETASMA=MIN(ETA3,ETA4)
28522 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
28523 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
28524 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
28525 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
28527 RPTS=4D0*VINT(71)**2/SH
28528 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28529 RM34=MAX(1D-20,2D0*RM3*RM4)
28530 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28531 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28532 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28533 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
28534 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28535 IF(PTH.LT.PTHMIN) MINT(51)=1
28536 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
28537 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
28538 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
28539 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
28540 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
28541 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
28542 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
28543 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
28544 IF(THA.LT.CKIN(35)) MINT(51)=1
28545 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
28546 IF(UHA.LT.CKIN(37)) MINT(51)=1
28547 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
28549 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28550 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
28551 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
28554 C...Additional cuts on W2 (approximately) in DIS.
28555 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
28557 IF(IABS(MINT(12)).LT.20) XBJ=X1
28559 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
28560 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
28561 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
28564 ELSEIF(ILIM.EQ.1) THEN
28565 C...Calculate limits on tau
28566 C...0) due to definition
28569 C...1) due to limits on subsystem mass
28570 TAUMN1=CKIN(1)**2/VINT(2)
28572 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
28573 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28574 TM3=SQRT(SQM3+PTHMIN**2)
28575 TM4=SQRT(SQM4+PTHMIN**2)
28577 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
28578 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
28580 C...3) due to limits on pT-hat and cos(theta-hat)
28581 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
28582 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
28584 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
28585 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
28586 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
28588 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
28589 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
28590 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
28591 C...4) due to limits on x1 and x2
28592 TAUMN4=CKIN(21)*CKIN(23)
28593 TAUMX4=CKIN(22)*CKIN(24)
28594 C...5) due to limits on xF
28596 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
28597 C...6) due to limits on that and uhat
28598 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
28600 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
28601 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
28603 C...Net effect of all separate limits.
28604 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
28605 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
28606 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28609 ELSEIF(MINT(47).EQ.5) THEN
28610 VINT(31)=MIN(VINT(31),1D0-2D-10)
28611 ELSEIF(MINT(47).GE.6) THEN
28612 VINT(31)=MIN(VINT(31),1D0-1D-10)
28614 IF(VINT(31).LE.VINT(11)) MINT(51)=1
28616 ELSEIF(ILIM.EQ.2) THEN
28617 C...Calculate limits on y*
28619 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28621 C...0) due to kinematics
28624 C...1) due to explicit limits
28627 C...2) due to limits on x1
28628 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
28629 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
28630 C...3) due to limits on x2
28631 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
28632 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
28633 C...4) due to limits on xF
28634 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
28635 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
28636 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
28637 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
28638 C...5) due to simultaneous limits on y-large and y-small
28639 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
28640 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
28641 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
28642 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
28643 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
28644 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
28645 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28647 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
28648 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
28649 RZMX=BE34*MIN(CKIN(28),CTHLIM)
28650 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
28651 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
28652 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
28653 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
28654 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
28655 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
28657 C...Net effect of all separate limits.
28658 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
28659 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
28660 IF(MINT(47).EQ.1) THEN
28663 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28664 VINT(12)=(1D0-1D-9)*YSTMX0
28665 VINT(32)=(1D0+1D-9)*YSTMX0
28666 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28667 VINT(12)=-(1D0+1D-9)*YSTMX0
28668 VINT(32)=-(1D0-1D-9)*YSTMX0
28669 ELSEIF(MINT(47).EQ.5) THEN
28670 YSTEE=LOG((1D0-1D-10)/TAURT)
28671 VINT(12)=MAX(VINT(12),-YSTEE)
28672 VINT(32)=MIN(VINT(32),YSTEE)
28674 IF(VINT(32).LE.VINT(12)) MINT(51)=1
28676 ELSEIF(ILIM.EQ.3) THEN
28677 C...Calculate limits on cos(theta-hat)
28679 C...0) due to definition
28684 C...1) due to explicit limits
28685 CTNMN1=MIN(0D0,CKIN(27))
28686 CTNMX1=MIN(0D0,CKIN(28))
28687 CTPMN1=MAX(0D0,CKIN(27))
28688 CTPMX1=MAX(0D0,CKIN(28))
28689 C...2) due to limits on pT-hat
28690 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
28694 IF(CKIN(4).GE.0D0) THEN
28695 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
28696 & (BE34**2*TAU*VINT(2))))
28699 C...3) due to limits on y-large and y-small
28700 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
28701 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
28702 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
28703 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
28704 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
28705 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
28706 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
28707 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
28708 C...4) due to limits on that
28714 IF(CKIN(35).GT.0D0) THEN
28715 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
28716 IF(CTLIM.GT.0D0) THEN
28723 IF(CKIN(36).GT.0D0) THEN
28724 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
28725 IF(CTLIM.LT.0D0) THEN
28732 C...5) due to limits on uhat
28737 IF(CKIN(37).GT.0D0) THEN
28738 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
28739 IF(CTLIM.LT.0D0) THEN
28746 IF(CKIN(38).GT.0D0) THEN
28747 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
28748 IF(CTLIM.GT.0D0) THEN
28756 C...Net effect of all separate limits.
28757 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
28758 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
28759 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
28760 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
28761 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
28763 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
28764 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
28766 ELSEIF(ILIM.EQ.4) THEN
28767 C...Calculate limits on tau'
28768 C...0) due to kinematics
28770 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
28771 PQRAT=(VINT(201)+VINT(206))/VINT(1)
28772 TAPMN0=(SQRT(TAU)+PQRAT)**2
28775 C...1) due to explicit limits
28776 TAPMN1=CKIN(31)**2/VINT(2)
28778 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
28780 C...Net effect of all separate limits.
28781 VINT(16)=MAX(TAPMN0,TAPMN1)
28782 VINT(36)=MIN(TAPMX0,TAPMX1)
28783 IF(MINT(47).EQ.1) THEN
28786 ELSEIF(MINT(47).EQ.5) THEN
28787 VINT(36)=MIN(VINT(36),1D0-2D-10)
28788 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
28789 VINT(36)=MIN(VINT(36),1D0-1D-10)
28791 IF(VINT(36).LE.VINT(16)) MINT(51)=1
28796 C...Special case for low-pT and multiple interactions:
28797 C...effective kinematical limits for tau, y*, cos(theta-hat).
28798 100 IF(ILIM.EQ.0) THEN
28799 ELSEIF(ILIM.EQ.1) THEN
28800 IF(MSTP(82).LE.1) THEN
28801 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28804 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
28807 ELSEIF(ILIM.EQ.2) THEN
28808 VINT(12)=0.5D0*LOG(VINT(21))
28810 ELSEIF(ILIM.EQ.3) THEN
28811 IF(MSTP(82).LE.1) THEN
28812 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28813 & (VINT(21)*VINT(2))
28815 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
28816 & (VINT(21)*VINT(2))
28818 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
28827 C*********************************************************************
28830 C...Maps a uniform distribution into a distribution of a kinematical
28831 C...variable according to one of the possibilities allowed. It is
28832 C...assumed that kinematical limits have been set by a PYKLIM call.
28834 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
28836 C...Double precision and integer declarations.
28837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28838 IMPLICIT INTEGER(I-N)
28839 INTEGER PYK,PYCHGE,PYCOMP
28841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28843 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28844 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28845 COMMON/PYINT1/MINT(400),VINT(400)
28846 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28847 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28849 C...Convert VVAR to tau variable.
28855 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28858 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28861 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28865 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28867 ELSEIF(MVAR.EQ.1) THEN
28868 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28869 ELSEIF(MVAR.EQ.2) THEN
28870 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28871 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28872 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28873 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28874 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28875 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28876 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28877 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28878 ELSEIF(MINT(47).EQ.5) THEN
28879 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28880 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28881 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28883 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28884 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28885 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28887 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28889 C...Convert VVAR to y* variable.
28890 ELSEIF(IVAR.EQ.2) THEN
28894 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28895 IF(MINT(47).EQ.1) THEN
28897 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28898 YST=-0.5D0*LOG(TAUE)
28899 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28900 YST=0.5D0*LOG(TAUE)
28901 ELSEIF(MVAR.EQ.1) THEN
28902 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28903 ELSEIF(MVAR.EQ.2) THEN
28904 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28905 ELSEIF(MVAR.EQ.3) THEN
28906 AUPP=ATAN(EXP(YSTMAX))
28907 ALOW=ATAN(EXP(YSTMIN))
28908 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28909 ELSEIF(MVAR.EQ.4) THEN
28910 YST0=-0.5D0*LOG(TAUE)
28911 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28912 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28913 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28915 YST0=-0.5D0*LOG(TAUE)
28916 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28917 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28918 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28920 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28922 C...Convert VVAR to cos(theta-hat) variable.
28923 ELSEIF(IVAR.EQ.3) THEN
28924 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28926 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28927 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28935 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28936 VCTN=VVAR*(ANEG+APOS)/ANEG
28937 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28939 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28940 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28942 ELSEIF(MVAR.EQ.2) THEN
28943 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28944 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28945 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28946 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28947 ANEG=LOG(RMNMIN/RMNMAX)
28948 APOS=LOG(RMPMIN/RMPMAX)
28949 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28950 VCTN=VVAR*(ANEG+APOS)/ANEG
28951 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28953 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28954 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28956 ELSEIF(MVAR.EQ.3) THEN
28957 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28958 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28959 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28960 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28961 ANEG=LOG(RMNMAX/RMNMIN)
28962 APOS=LOG(RMPMAX/RMPMIN)
28963 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28964 VCTN=VVAR*(ANEG+APOS)/ANEG
28965 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28967 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28968 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28970 ELSEIF(MVAR.EQ.4) THEN
28971 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28972 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28973 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28974 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28975 ANEG=1D0/RMNMAX-1D0/RMNMIN
28976 APOS=1D0/RMPMAX-1D0/RMPMIN
28977 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28978 VCTN=VVAR*(ANEG+APOS)/ANEG
28979 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28981 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28982 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28984 ELSEIF(MVAR.EQ.5) THEN
28985 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28986 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28987 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28988 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28989 ANEG=1D0/RMNMIN-1D0/RMNMAX
28990 APOS=1D0/RMPMIN-1D0/RMPMAX
28991 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28992 VCTN=VVAR*(ANEG+APOS)/ANEG
28993 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28995 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28996 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28999 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
29000 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
29003 C...Convert VVAR to tau' variable.
29004 ELSEIF(IVAR.EQ.4) THEN
29008 IF(MINT(47).EQ.1) THEN
29010 ELSEIF(MVAR.EQ.1) THEN
29011 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29012 ELSEIF(MVAR.EQ.2) THEN
29013 AUPP=(1D0-TAU/TAUPMX)**4
29014 ALOW=(1D0-TAU/TAUPMN)**4
29015 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29016 ELSEIF(MINT(47).EQ.5) THEN
29017 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29018 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29019 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29021 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29022 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29023 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29025 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29027 C...Selection of extra variables needed in 2 -> 3 process:
29028 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29029 C...Since no options are available, the functions of PYKLIM
29030 C...and PYKMAP are joint for these choices.
29031 ELSEIF(IVAR.EQ.5) THEN
29033 C...Read out total energy and particle masses.
29036 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29037 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29039 SHP=VINT(26)*VINT(2)
29043 PM3=SQRT(VINT(21))*VINT(1)
29044 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29051 C...Specify coefficients of pT choice; upper and lower limits.
29052 IF(MPTPK.EQ.1) THEN
29060 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29062 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29064 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29066 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29069 C...Select transverse momenta according to
29070 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29073 IF(HMX.LT.1.0001D0*HMN) THEN
29079 IF(RPT.LT.HWT1) THEN
29080 PTS1=PTSMN1+PYR(0)*HDE
29081 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29082 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29084 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29086 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29087 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29090 IF(HMX.LT.1.0001D0*HMN) THEN
29096 IF(RPT.LT.HWT1) THEN
29097 PTS2=PTSMN2+PYR(0)*HDE
29098 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29099 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29101 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29103 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29104 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29106 C...Select azimuthal angles and check pT choice.
29107 PHI1=PARU(2)*PYR(0)
29108 PHI2=PARU(2)*PYR(0)
29110 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29111 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29112 & CKIN(56)**2)) THEN
29117 C...Calculate transverse masses and check phase space not closed.
29124 PM12=(PMT1+PMT2)**2
29125 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29130 C...Select rapidity for particle 3 and check phase space not closed.
29131 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29132 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29133 IF(Y3MAX.LT.1D-6) THEN
29137 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29141 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29144 PMS12=PE12**2-PZ12**2
29145 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29146 IF(SQL12.LT.1D-6*SHP) THEN
29150 PMM1=PMS12+PMS1-PMS2
29151 PMM2=PMS12+PMS2-PMS1
29152 TFAC=-SHPR/(2D0*PMS12)
29153 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29154 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29155 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29156 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29158 C...Construct relative mirror weights and make choice.
29159 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29163 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29164 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29166 WTP=WTPU/(WTPU+WTNU)
29167 WTN=WTNU/(WTPU+WTNU)
29169 IF(WTN.GT.PYR(0)) EPS=-1D0
29171 C...Store result of variable choice and associated weights.
29181 IF(EPS.GT.0D0) THEN
29190 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29191 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29192 VINT(219)=0.5D0*(PMS12-PTS3)
29199 C***********************************************************************
29202 C...Differential matrix elements for all included subprocesses
29203 C...Note that what is coded is (disregarding the COMFAC factor)
29204 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29205 C...when d(sigma-hat) is given in the zero-width limit, the delta
29206 C...function in tau is replaced by a (modified) Breit-Wigner:
29207 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29208 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29209 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29210 C...i.e., dimensionless quantities
29211 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29212 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29213 C...(2pi)^4 delta^4(P - sum p_i)
29214 C...COMFAC contains the factor pi/s (or equivalent) and
29215 C...the conversion factor from GeV^-2 to mb
29217 SUBROUTINE PYSIGH(NCHN,SIGS)
29219 C...Double precision and integer declarations
29220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29221 IMPLICIT INTEGER(I-N)
29222 INTEGER PYK,PYCHGE,PYCOMP
29223 C...Parameter statement to help give large particle numbers.
29224 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29225 &KEXCIT=4000000,KDIMEN=5000000)
29227 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29228 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29229 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29230 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29231 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29232 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29233 COMMON/PYINT1/MINT(400),VINT(400)
29234 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29235 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29236 COMMON/PYINT4/MWID(500),WIDS(500,5)
29237 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29238 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29239 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29240 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29241 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29242 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29243 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29244 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29245 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29246 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29247 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29248 COMMON/PYTCCO/COEFX(194:380,2)
29249 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29250 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29251 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29252 C...Local arrays and complex variables
29253 DIMENSION XPQ(-25:25)
29255 C...Map of processes onto which routine to call
29256 C...in order to evaluate cross section:
29257 C...0 = not implemented;
29258 C...1 = standard QCD (including photons);
29259 C...2 = heavy flavours;
29261 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29263 C...6 = Technicolor;
29264 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29265 C...8 = Universal Extra Dimensions
29266 DIMENSION MAPPR(500)
29267 DATA (MAPPR(I),I=1,180)/
29268 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29269 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29270 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29271 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29272 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29273 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29274 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29275 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29276 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29277 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29278 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29279 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29280 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29281 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29282 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29283 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29284 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29285 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29286 DATA (MAPPR(I),I=181,500)/
29287 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29288 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29290 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29291 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29293 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29294 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29295 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29296 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29297 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29298 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29300 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29301 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29303 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29304 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29307 C...Reset number of channels and cross-section
29311 C...Read process to consider.
29316 C...Read kinematical variables and limits
29334 C...Derive kinematical quantities
29336 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29337 X(1)=SQRT(TAUE)*EXP(YST)
29338 X(2)=SQRT(TAUE)*EXP(-YST)
29339 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29340 IF(X(1).GT.1D0-1D-7) RETURN
29341 ELSEIF(MINT(45).EQ.3) THEN
29342 X(1)=MIN(1D0-1.1D-10,X(1))
29344 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29345 IF(X(2).GT.1D0-1D-7) RETURN
29346 ELSEIF(MINT(46).EQ.3) THEN
29347 X(2)=MIN(1D0-1.1D-10,X(2))
29349 SH=MAX(1D0,TAU*VINT(2))
29354 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29355 RPTS=4D0*VINT(71)**2/SH
29356 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29357 RM34=MAX(1D-20,2D0*RM3*RM4)
29359 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
29360 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
29361 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29362 IF(ISTSB.EQ.0) THEN
29364 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29365 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
29367 C...Kinematics with incoming masses tricky: now depends on how
29368 C...subprocess has been set up w.r.t. order of incoming partons.
29370 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
29372 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
29373 IF(ISUB.EQ.35) THEN
29377 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
29378 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
29379 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
29381 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
29383 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
29390 C...Choice of Q2 scale for hard process (e.g. alpha_s).
29391 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
29393 ELSEIF(ISTSB.EQ.8) THEN
29394 IF(MINT(107).EQ.4) Q2=VINT(307)
29395 IF(MINT(108).EQ.4) Q2=VINT(308)
29396 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
29398 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
29400 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
29401 IF(MSTP(32).EQ.1) THEN
29402 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
29403 ELSEIF(MSTP(32).EQ.2) THEN
29404 Q2=SQPTH+0.5D0*(SQM3+SQM4)
29405 ELSEIF(MSTP(32).EQ.3) THEN
29407 ELSEIF(MSTP(32).EQ.4) THEN
29409 ELSEIF(MSTP(32).EQ.5) THEN
29411 ELSEIF(MSTP(32).EQ.6) THEN
29413 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
29415 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
29416 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
29417 & (SQPTH+0.5D0*(SQM3+SQM4))
29418 ELSEIF(MSTP(32).EQ.7) THEN
29419 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
29420 ELSEIF(MSTP(32).EQ.8) THEN
29421 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
29422 ELSEIF(MSTP(32).EQ.9) THEN
29423 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
29424 ELSEIF(MSTP(32).EQ.10) THEN
29427 ELSEIF(MSTP(32).EQ.11) THEN
29428 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
29429 ELSEIF(MSTP(32).EQ.12) THEN
29432 ELSEIF(MSTP(32).EQ.13) THEN
29435 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
29436 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
29437 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
29440 C...Choice of Q2 scale for parton densities.
29443 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
29444 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
29447 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29449 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
29450 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
29451 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
29452 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
29453 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
29454 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
29455 IF(MSTP(39).EQ.2) Q2SF=
29456 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
29457 IF(MSTP(39).EQ.3) Q2SF=SH
29458 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
29459 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
29461 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
29462 IF(MSTP(39).EQ.7) Q2SF=
29463 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
29464 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
29468 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
29472 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
29473 IF(MSTP(69).GE.2) Q2SF=VINT(2)
29475 C...Identify to which class(es) subprocess belongs
29479 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
29480 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
29481 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
29482 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
29483 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
29484 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
29485 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
29486 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
29487 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
29488 IF (ISTSB.EQ.9) ISQCD=1
29489 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
29490 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
29491 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
29492 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
29493 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
29494 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
29495 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
29496 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
29497 C...WBF is special case of ISJETS
29498 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
29499 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
29500 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
29501 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
29502 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
29503 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
29504 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
29505 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
29506 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
29507 C...Some processes with photons also belong here.
29508 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
29509 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
29510 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
29511 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
29512 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
29513 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
29515 C...Choice of Q2 scale for parton-shower activity.
29516 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
29517 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
29519 IF(MINT(43).EQ.3) XBJ=X(1)
29520 IF(MSTP(22).EQ.1) THEN
29522 ELSEIF(MSTP(22).EQ.2) THEN
29523 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
29524 ELSEIF(MSTP(22).EQ.3) THEN
29525 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
29527 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
29530 C...For multiple interactions, start from scale defined above
29531 C...For all other QCD or "+jets"-type events, start shower from pThard.
29532 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
29533 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
29534 C...Max shower scale = s for ME corrected processes.
29535 C...(pT-ordering: max pT2 is s/4)
29537 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29538 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
29539 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29540 C...(pT-ordering: max pT2 is s/4)
29542 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29544 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
29546 C...Elastic and diffractive events not associated with scales so set 0.
29547 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
29552 C...Store derived kinematical quantities
29559 IF(ISTSB.NE.8) VINT(48)=SQPTH
29560 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
29561 VINT(50)=TAUP*VINT(2)
29562 VINT(49)=SQRT(MAX(0D0,VINT(50)))
29566 VINT(53)=SQRT(Q2SF)
29568 VINT(55)=SQRT(Q2PS)
29570 C...Set starting scale for multiple interactions
29571 IF (ISUBSV.EQ.95) THEN
29573 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
29574 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
29575 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
29576 & ISUBSV.NE.96)) THEN
29577 C...All accessible phase space allowed.
29578 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
29580 C...Scale of hard process sets limit.
29581 C...2 -> 1. Limit is tau = x1*x2.
29582 C...2 -> 2. Limit is XT2 for hard process + FS masses.
29583 C...2 -> n > 2. Limit is tau' = tau of outer process.
29585 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
29587 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
29588 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
29590 VINT(62)=0.25D0*XT2GMX*VINT(2)
29591 VINT(61)=SQRT(MAX(0D0,VINT(62)))
29593 C...Calculate parton distributions
29594 IF(ISTSB.LE.0) GOTO 160
29595 IF(MINT(47).GE.2) THEN
29596 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
29598 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
29599 IF(ISUB.EQ.99) THEN
29600 IF(MINT(140+I).EQ.0) THEN
29601 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
29603 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
29608 MINT(105)=MINT(102+I)
29609 MINT(109)=MINT(106+I)
29610 VINT(120)=VINT(2+I)
29612 C.... Store side in MINT(124)
29615 IF(MSTP(57).LE.1) THEN
29616 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
29618 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
29620 C...Safety margin against heavy flavour very close to threshold,
29621 C...e.g. caused by mismatch in c and b masses.
29622 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
29626 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
29631 XSFX(I,KFL)=XPQ(KFL)
29636 C...Calculate alpha_em, alpha_strong and K-factor
29639 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
29640 &1D0-(PMAS(24,1)/PMAS(23,1))**2
29642 XWC=1D0/(16D0*XW*XW1)
29644 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
29645 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
29648 IF(MSTP(33).EQ.1) THEN
29650 ELSEIF(MSTP(33).EQ.2) THEN
29652 FACA=PARP(32)/PARP(31)
29653 ELSEIF(MSTP(33).EQ.3) THEN
29655 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
29656 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
29663 C...Set flags for allowed reacting partons/leptons
29668 IF(MINT(44+I).EQ.1) THEN
29669 KFAC(I,MINT(10+I))=1
29670 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
29671 KFAC(I,MINT(10+I))=1
29677 KFAC(I,J)=KFIN(I,J)
29678 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
29679 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
29684 C...Lower and upper limit for fermion flavour loops
29690 IF(KFAC(1,-J).EQ.1) MMIN1=-J
29691 IF(KFAC(1,J).EQ.1) MMAX1=J
29692 IF(KFAC(2,-J).EQ.1) MMIN2=-J
29693 IF(KFAC(2,J).EQ.1) MMAX2=J
29695 MMINA=MIN(MMIN1,MMIN2)
29696 MMAXA=MAX(MMAX1,MMAX2)
29698 C...Common resonance mass and width combinations
29701 GMMZ=PMAS(23,1)*PMAS(23,2)
29702 GMMW=PMAS(24,1)*PMAS(24,2)
29704 C...Polarization factors...implemented so far for W+W-(25)
29705 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
29706 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
29707 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
29708 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
29710 C...Phase space integral in tau
29711 COMFAC=PARU(1)*PARU(5)/VINT(2)
29712 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
29713 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
29714 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
29715 ATAU1=LOG(TAUMAX/TAUMIN)
29716 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
29717 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
29718 IF(MINT(72).GE.1) THEN
29721 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
29723 IF(ATAUD.GT.1D-10) H1=H1+
29724 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
29725 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
29727 IF(ATAUD.GT.1D-10) H1=H1+
29728 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
29730 IF(MINT(72).GE.2) THEN
29733 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
29735 IF(ATAUD.GT.1D-10) H1=H1+
29736 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
29737 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
29739 IF(ATAUD.GT.1D-10) H1=H1+
29740 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
29742 IF(MINT(72).EQ.3) THEN
29745 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
29747 IF(ATAUD.GT.1D-10) H1=H1+
29748 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
29749 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
29751 IF(ATAUD.GT.1D-10) H1=H1+
29752 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
29754 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29755 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
29756 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29757 & MAX(2D-10,1D0-TAU)
29758 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29759 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
29760 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29761 & MAX(1D-10,1D0-TAU)
29763 COMFAC=COMFAC*ATAU1/(TAU*H1)
29766 C...Phase space integral in y*
29767 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
29769 AYST0=YSTMAX-YSTMIN
29770 IF(AYST0.LT.1D-10) THEN
29773 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29775 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29776 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29777 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29778 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29779 IF(MINT(45).EQ.3) THEN
29780 YST0=-0.5D0*LOG(TAUE)
29781 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
29782 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29783 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
29784 & MAX(1D-10,1D0-EXP(YST-YST0))
29786 IF(MINT(46).EQ.3) THEN
29787 YST0=-0.5D0*LOG(TAUE)
29788 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
29789 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29790 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
29791 & MAX(1D-10,1D0-EXP(-YST-YST0))
29793 COMFAC=COMFAC*AYST0/H2
29797 C...2 -> 1 processes: reduction in angular part of phase space integral
29798 C...for case of decaying resonance
29799 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
29800 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
29801 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
29802 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
29803 & KFPR(ISUB,1).EQ.39) THEN
29804 COMFAC=COMFAC*0.5D0*ACTH0
29806 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
29807 & CTPMAX**3-CTPMIN**3)
29811 C...2 -> 2 processes: angular part of phase space integral
29812 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29813 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
29814 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
29815 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
29816 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
29817 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
29818 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
29819 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
29820 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
29821 H3=COEF(ISUBSV,13)+
29822 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
29823 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
29824 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
29825 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
29826 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
29828 C...2 -> 2 processes: take into account final state Breit-Wigners
29829 COMFAC=COMFAC*VINT(80)
29832 C...2 -> 3, 4 processes: phace space integral in tau'
29833 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29834 ATAUP1=LOG(TAUPMX/TAUPMN)
29835 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
29836 H4=COEF(ISUBSV,18)+
29837 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
29838 IF(MINT(47).EQ.5) THEN
29839 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
29840 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
29841 ELSEIF(MINT(47).GE.6) THEN
29842 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
29843 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
29845 COMFAC=COMFAC*ATAUP1/H4
29848 C...2 -> 3, 4 processes: effective W/Z parton distributions
29849 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
29850 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29851 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29853 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29858 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29859 IF(ISTSB.EQ.5) THEN
29860 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29861 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29864 C...Phase space integral for low-pT and multiple interactions
29865 IF(ISTSB.EQ.9) THEN
29866 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29867 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29868 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29869 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29870 COMFAC=COMFAC*ATAU1/H1
29871 AYST0=YSTMAX-YSTMIN
29872 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29873 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29874 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29875 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29876 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29877 COMFAC=COMFAC*AYST0/H2
29878 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29879 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29880 C...introduced to make cross-section finite for xT2 -> 0
29881 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29885 C...Real gamma + gamma: include factor 2 when different nature
29886 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29887 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29889 C...Extra factors to include the effects of
29890 C...longitudinal resolved photons (but not direct or DIS ones).
29892 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29893 & MINT(106+ISDE).LE.3) THEN
29896 IF(MSTP(16).EQ.0) THEN
29897 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29898 & XY=VINT(304+ISDE)
29900 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29901 & XY=VINT(308+ISDE)
29903 Q2GA=VINT(306+ISDE)
29904 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29905 & Q2GA.GT.0D0) THEN
29907 IF(MSTP(17).EQ.1) THEN
29908 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29909 ELSEIF(MSTP(17).EQ.2) THEN
29910 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29911 ELSEIF(MSTP(17).EQ.3) THEN
29912 PMVIRT=PMAS(PYCOMP(113),1)
29913 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29914 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29915 PMVIRT=PMAS(PYCOMP(113),1)
29916 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29917 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29918 PMVIRT=PMAS(PYCOMP(113),1)
29919 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29920 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29921 PMVSMN=4D0*PARP(15)**2
29922 PMVSMX=4D0*VINT(154)**2
29923 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29924 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29925 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29926 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29927 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29928 PMVIRT=PMAS(PYCOMP(113),1)
29929 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29930 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29931 PMVIRT=PMAS(PYCOMP(113),1)
29932 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29933 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29934 PMVSMN=4D0*PARP(15)**2
29935 PMVSMX=4D0*VINT(154)**2
29936 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29937 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29938 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29941 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29942 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29943 & (1D0-2D0*BEAMAS**2/Q2GA))
29944 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29949 COMFAC=COMFAC*VINT(314+ISDE)
29952 C...Evaluate cross sections - done in separate routines by kind
29953 C...of physics, to keep PYSIGH of sensible size.
29955 C...Standard QCD (including photons).
29956 CALL PYSGQC(NCHN,SIGS)
29957 ELSEIF(MAP.EQ.2) THEN
29958 C...Heavy flavours.
29959 CALL PYSGHF(NCHN,SIGS)
29960 ELSEIF(MAP.EQ.3) THEN
29962 CALL PYSGWZ(NCHN,SIGS)
29963 ELSEIF(MAP.EQ.4) THEN
29964 C...Higgs (2 doublets; including longitudinal W/Z scattering).
29965 CALL PYSGHG(NCHN,SIGS)
29966 ELSEIF(MAP.EQ.5) THEN
29968 CALL PYSGSU(NCHN,SIGS)
29969 ELSEIF(MAP.EQ.6) THEN
29971 CALL PYSGTC(NCHN,SIGS)
29972 ELSEIF(MAP.EQ.7) THEN
29973 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29974 CALL PYSGEX(NCHN,SIGS)
29975 ELSEIF(MAP.EQ.8) THEN
29976 C... Universal Extra Dimensions
29977 CALL PYXUED(NCHN,SIGS)
29980 C...Multiply with parton distributions
29981 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29983 IF(MINT(45).GE.2) THEN
29985 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29987 IF(MINT(46).GE.2) THEN
29989 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29991 SIGS=SIGS+SIGH(ICHN)
29998 C*********************************************************************
30001 C...Subprocess cross sections for QCD processes,
30002 C...including photons.
30003 C...Auxiliary to PYSIGH.
30005 SUBROUTINE PYSGQC(NCHN,SIGS)
30007 C...Double precision and integer declarations
30008 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30009 IMPLICIT INTEGER(I-N)
30010 INTEGER PYK,PYCHGE,PYCOMP
30011 C...Parameter statement to help give large particle numbers.
30012 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30013 &KEXCIT=4000000,KDIMEN=5000000)
30015 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30016 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30017 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30018 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30019 COMMON/PYINT1/MINT(400),VINT(400)
30020 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30021 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30022 COMMON/PYINT4/MWID(500),WIDS(500,5)
30023 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30024 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30025 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30026 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30027 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30028 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30029 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30031 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30033 C...Differential cross section expressions.
30035 IF(ISUB.LE.20) THEN
30036 IF(ISUB.EQ.10) THEN
30037 C...f + f' -> f + f' (gamma/Z/W exchange)
30038 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30039 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30040 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30041 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30042 DO 110 I=MMIN1,MMAX1
30043 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30045 DO 100 J=MMIN2,MMAX2
30046 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30048 C...Electroweak couplings
30049 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30050 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30052 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30053 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30056 C...gamma/Z exchange, only gamma exchange, or only Z exchange
30057 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30058 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30059 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30060 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30061 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30062 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30063 ELSEIF(MSTP(21).EQ.2) THEN
30064 FACNCF=FACGGF*EI**2*EJ**2
30066 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30067 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30069 C...Extrafactor 2 for only one incoming neutrino spin state.
30070 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30071 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30079 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30080 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30081 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30082 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30083 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30093 ELSEIF(ISUB.EQ.11) THEN
30094 C...f + f' -> f + f' (g exchange)
30095 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30096 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30097 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30098 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30099 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30100 DO 130 I=MMIN1,MMAX1
30102 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30103 DO 120 J=MMIN2,MMAX2
30105 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30111 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30113 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30118 SIGH(NCHN)=0.5D0*FACQQ2
30123 ELSEIF(ISUB.EQ.12) THEN
30124 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30125 CALL PYWIDT(21,SH,WDTP,WDTE)
30126 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30127 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30128 DO 140 I=MMINA,MMAXA
30129 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30130 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30138 ELSEIF(ISUB.EQ.13) THEN
30139 C...f + fbar -> g + g (q + qbar -> g + g only)
30140 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30142 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30144 DO 150 I=MMINA,MMAXA
30145 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30146 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30151 SIGH(NCHN)=0.5D0*FACGG1
30156 SIGH(NCHN)=0.5D0*FACGG2
30159 ELSEIF(ISUB.EQ.14) THEN
30160 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30161 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30162 DO 160 I=MMINA,MMAXA
30163 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30164 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30165 EI=KCHG(IABS(I),1)/3D0
30170 SIGH(NCHN)=FACGG*EI**2
30173 ELSEIF(ISUB.EQ.18) THEN
30174 C...f + fbar -> gamma + gamma
30175 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30176 DO 170 I=MMINA,MMAXA
30177 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30178 EI=KCHG(IABS(I),1)/3D0
30180 IF(IABS(I).LE.10) FCOI=FACA/3D0
30185 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30189 ELSEIF(ISUB.LE.40) THEN
30190 IF(ISUB.EQ.28) THEN
30191 C...f + g -> f + g (q + g -> q + g only)
30192 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30194 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30196 DO 190 I=MMINA,MMAXA
30197 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30199 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30200 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30203 ISIG(NCHN,3-ISDE)=21
30208 ISIG(NCHN,3-ISDE)=21
30214 ELSEIF(ISUB.EQ.29) THEN
30215 C...f + g -> f + gamma (q + g -> q + gamma only)
30216 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30217 DO 210 I=MMINA,MMAXA
30218 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30219 EI=KCHG(IABS(I),1)/3D0
30222 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30223 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30226 ISIG(NCHN,3-ISDE)=21
30232 ELSEIF(ISUB.EQ.33) THEN
30233 C...f + gamma -> f + g (q + gamma -> q + g only)
30234 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30235 DO 230 I=MMINA,MMAXA
30236 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30237 EI=KCHG(IABS(I),1)/3D0
30240 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30241 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30244 ISIG(NCHN,3-ISDE)=22
30250 ELSEIF(ISUB.EQ.34) THEN
30251 C...f + gamma -> f + gamma
30252 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30253 DO 250 I=MMINA,MMAXA
30254 IF(I.EQ.0) GOTO 250
30255 EI=KCHG(IABS(I),1)/3D0
30258 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30259 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30262 ISIG(NCHN,3-ISDE)=22
30269 ELSEIF(ISUB.LE.80) THEN
30270 IF(ISUB.EQ.53) THEN
30271 C...g + g -> f + fbar (g + g -> q + qbar only)
30272 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30274 C...Begin by d, u, s flavours.
30276 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30277 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30278 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30279 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30280 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30281 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30282 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30283 & UH2/SH2)*FLAVWT*FACA
30284 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30285 & TH2/SH2)*FLAVWT*FACA
30296 C...Next c and b flavours: modified that and uhat for fixed
30297 C...cos(theta-hat).
30299 SQMAVG=PMAS(IFL,1)**2
30300 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30301 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30302 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30303 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30304 THUHQ=THQ*UHQ-SQMAVG*SH
30305 IF(MSTP(34).EQ.0) THEN
30306 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30307 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30309 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30310 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30311 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30312 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30314 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30315 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30319 ISIG(NCHN,3)=1+2*(IFL-3)
30324 ISIG(NCHN,3)=2+2*(IFL-3)
30330 ELSEIF(ISUB.EQ.54) THEN
30331 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30332 CALL PYWIDT(21,SH,WDTP,WDTE)
30334 DO 280 I=1,MIN(8,MDCY(21,3))
30336 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30339 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
30340 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30347 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30355 ELSEIF(ISUB.EQ.58) THEN
30356 C...gamma + gamma -> f + fbar
30357 CALL PYWIDT(22,SH,WDTP,WDTE)
30359 DO 290 I=1,MIN(12,MDCY(22,3))
30360 IF(I.LE.8) EF= KCHG(I,1)/3D0
30361 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30362 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30365 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
30366 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30374 ELSEIF(ISUB.EQ.68) THEN
30376 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
30377 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
30379 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
30381 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
30387 SIGH(NCHN)=0.5D0*FACGG1
30392 SIGH(NCHN)=0.5D0*FACGG2
30397 SIGH(NCHN)=0.5D0*FACGG3
30400 ELSEIF(ISUB.EQ.80) THEN
30401 C...q + gamma -> q' + pi+/-
30402 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
30403 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
30404 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
30405 DELSH=UH*SQRT(ASSH*Q2FPSH)
30406 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
30407 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
30408 DELUH=SH*SQRT(ASUH*Q2FPUH)
30409 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
30410 IF(I.EQ.0) GOTO 320
30411 EI=KCHG(IABS(I),1)/3D0
30412 EJ=SIGN(1D0-ABS(EI),EI)
30414 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
30415 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
30418 ISIG(NCHN,3-ISDE)=22
30420 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
30425 ELSEIF(ISUB.LE.100) THEN
30426 IF(ISUB.EQ.91) THEN
30427 C...Elastic scattering
30428 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
30430 ELSEIF(ISUB.EQ.92) THEN
30431 C...Single diffractive scattering (first side, i.e. XB)
30432 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
30434 ELSEIF(ISUB.EQ.93) THEN
30435 C...Single diffractive scattering (second side, i.e. AX)
30436 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
30438 ELSEIF(ISUB.EQ.94) THEN
30439 C...Double diffractive scattering
30440 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
30442 ELSEIF(ISUB.EQ.95) THEN
30443 C...Low-pT scattering
30444 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
30446 ELSEIF(ISUB.EQ.96) THEN
30447 C...Multiple interactions: sum of QCD processes
30448 CALL PYWIDT(21,SH,WDTP,WDTE)
30450 C...q + q' -> q + q'
30451 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30452 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30453 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30454 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
30455 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
30456 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
30458 IF(I.EQ.0) GOTO 340
30460 IF(J.EQ.0) GOTO 330
30466 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30468 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
30473 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
30478 C...q + qbar -> q' + qbar' or g + g
30479 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30480 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
30481 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30483 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30486 IF(I.EQ.0) GOTO 350
30496 SIGH(NCHN)=0.5D0*FACGG1
30501 SIGH(NCHN)=0.5D0*FACGG2
30505 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30507 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30510 IF(I.EQ.0) GOTO 370
30514 ISIG(NCHN,3-ISDE)=21
30519 ISIG(NCHN,3-ISDE)=21
30525 C...g + g -> q + qbar (only d, u, s)
30528 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30529 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30530 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30531 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30532 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30533 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30534 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30535 & UH2/SH2)*FLAVWT*FACA
30536 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30537 & TH2/SH2)*FLAVWT*FACA
30549 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30552 SQMAVG=PMAS(IFL,1)**2
30553 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30554 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30555 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30556 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30557 THUHQ=THQ*UHQ-SQMAVG*SH
30558 IF(MSTP(34).EQ.0) THEN
30559 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30560 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30562 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30563 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30564 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30565 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30567 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30568 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30572 ISIG(NCHN,3)=531+2*(IFL-3)
30577 ISIG(NCHN,3)=532+2*(IFL-3)
30583 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
30584 & 2D0*TH/SH+TH2/SH2)*FACA
30585 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
30586 & 2D0*SH/UH+SH2/UH2)*FACA
30587 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
30588 & 2D0*UH/TH+UH2/TH2)
30593 SIGH(NCHN)=0.5D0*FACGG1
30598 SIGH(NCHN)=0.5D0*FACGG2
30603 SIGH(NCHN)=0.5D0*FACGG3
30605 ELSEIF(ISUB.EQ.99) THEN
30606 C...f + gamma* -> f.
30607 IF(MINT(107).EQ.4) THEN
30616 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
30617 PM2RHO=PMAS(PYCOMP(113),1)**2
30618 IF(MSTP(19).EQ.0) THEN
30620 ELSEIF(MSTP(19).EQ.1) THEN
30621 COMFAC=COMFAC/(Q2GA+PM2RHO)
30622 ELSEIF(MSTP(19).EQ.2) THEN
30623 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30625 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30627 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
30628 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
30629 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
30630 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
30632 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
30634 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
30636 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
30637 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
30639 DO 390 I=MMINA,MMAXA
30640 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
30641 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
30642 EI=KCHG(IABS(I),1)/3D0
30645 ISIG(NCHN,3-ISDE)=22
30647 SIGH(NCHN)=COMFAC*EI**2
30652 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
30653 C...g + g -> gamma + gamma or g + g -> g + gamma
30668 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
30670 EI=KCHG(IABS(I),1)/3D0
30672 IF(ISUB.EQ.115) EIWT=EI
30677 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
30678 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
30681 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
30682 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
30683 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
30684 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
30690 CALL PYWAUX(1,EPSS,W1SR,W1SI)
30691 CALL PYWAUX(1,EPST,W1TR,W1TI)
30692 CALL PYWAUX(1,EPSU,W1UR,W1UI)
30693 CALL PYWAUX(2,EPSS,W2SR,W2SI)
30694 CALL PYWAUX(2,EPST,W2TR,W2TI)
30695 CALL PYWAUX(2,EPSU,W2UR,W2UI)
30696 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
30697 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
30698 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
30699 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
30700 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
30701 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
30702 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
30703 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
30704 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
30705 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
30706 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30707 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30708 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
30709 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
30710 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
30711 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
30712 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30713 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30714 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
30715 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
30716 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
30717 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
30718 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30719 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
30720 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
30721 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
30722 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
30723 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
30724 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30725 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
30726 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
30727 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
30728 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
30729 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
30730 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30731 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
30732 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
30733 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
30734 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
30735 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
30736 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30737 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
30738 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
30739 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
30740 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
30741 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30742 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
30743 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
30744 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
30745 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30746 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
30747 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
30748 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
30749 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
30750 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
30751 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
30753 A0STUR=A0STUR+EIWT*B0STUR
30754 A0STUI=A0STUI+EIWT*B0STUI
30755 A0TSUR=A0TSUR+EIWT*B0TSUR
30756 A0TSUI=A0TSUI+EIWT*B0TSUI
30757 A0UTSR=A0UTSR+EIWT*B0UTSR
30758 A0UTSI=A0UTSI+EIWT*B0UTSI
30759 A1STUR=A1STUR+EIWT*B1STUR
30760 A1STUI=A1STUI+EIWT*B1STUI
30761 A2STUR=A2STUR+EIWT*B2STUR
30762 A2STUI=A2STUI+EIWT*B2STUI
30764 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
30765 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
30766 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
30767 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
30768 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
30773 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
30774 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
30777 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
30778 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30780 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30782 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30784 IF(ISUB.EQ.131) THEN
30785 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
30786 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30788 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30790 DO 430 I=MMINA,MMAXA
30791 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
30792 EI=KCHG(IABS(I),1)/3D0
30795 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
30796 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
30799 ISIG(NCHN,3-ISDE)=22
30805 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
30806 C...f + gamma*_(T,L) -> f + gamma
30808 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30810 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30812 IF(ISUB.EQ.133) THEN
30813 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
30814 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30816 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30818 DO 450 I=MMINA,MMAXA
30819 IF(I.EQ.0) GOTO 450
30820 EI=KCHG(IABS(I),1)/3D0
30823 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
30824 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
30827 ISIG(NCHN,3-ISDE)=22
30833 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
30834 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30836 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30838 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30840 CALL PYWIDT(21,SH,WDTP,WDTE)
30842 DO 460 I=1,MIN(8,MDCY(21,3))
30844 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30847 IF(ISUB.EQ.135) THEN
30848 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
30849 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
30851 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
30853 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30860 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30868 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30869 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30871 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30873 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30874 CALL PYWIDT(22,SH,WDTP,WDTE)
30876 DO 470 I=1,MIN(12,MDCY(22,3))
30877 IF(I.LE.8) EF= KCHG(I,1)/3D0
30878 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30879 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30882 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30883 IF(ISUB.EQ.137) THEN
30884 FPARAM=-SH*(TH+UH)/DLAMB2
30885 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30886 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30887 & 2D0*PH1*PH2*FPARAM**2)
30888 ELSEIF(ISUB.EQ.138) THEN
30889 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30890 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30891 & 2D0*PH1**2*(TH-UH)**2)
30892 ELSEIF(ISUB.EQ.139) THEN
30893 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30894 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30895 & 2D0*PH2**2*(TH-UH)**2)
30897 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30898 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30900 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30914 C*********************************************************************
30917 C...Subprocess cross sections for heavy flavour production,
30918 C...open and closed.
30919 C...Auxiliary to PYSIGH.
30921 SUBROUTINE PYSGHF(NCHN,SIGS)
30923 C...Double precision and integer declarations
30924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30925 IMPLICIT INTEGER(I-N)
30926 INTEGER PYK,PYCHGE,PYCOMP
30927 C...Parameter statement to help give large particle numbers.
30928 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30929 &KEXCIT=4000000,KDIMEN=5000000)
30931 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30932 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30933 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30934 COMMON/PYINT1/MINT(400),VINT(400)
30935 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30936 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30937 COMMON/PYINT4/MWID(500),WIDS(500,5)
30938 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30939 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30940 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30941 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30942 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30945 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30947 C...Determine where are charmonium/bottomonium wave function parameters.
30949 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30951 C...Convert bottomonium process into equivalent charmonium ones.
30952 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30954 C...Differential cross section expressions.
30956 IF(ISUB.LE.100) THEN
30957 IF(ISUB.EQ.81) THEN
30958 C...q + qbar -> Q + Qbar
30959 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30960 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30961 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30962 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30964 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30966 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30967 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30969 DO 100 I=MMINA,MMAXA
30970 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30971 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30979 ELSEIF(ISUB.EQ.82) THEN
30980 C...g + g -> Q + Qbar
30981 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30982 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30983 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30984 THUHQ=THQ*UHQ-SQMAVG*SH
30985 IF(MSTP(34).EQ.0) THEN
30986 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30987 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30989 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30990 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30991 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30992 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30994 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30995 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30996 IF(MSTP(35).GE.1) THEN
30997 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30998 FACQQ1=FACQQ1*FATRE
30999 FACQQ2=FACQQ2*FATRE
31002 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31003 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31006 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31019 ELSEIF(ISUB.EQ.83) THEN
31020 C...f + q -> f' + Q
31021 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31022 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31023 DO 130 I=MMIN1,MMAX1
31024 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31025 DO 120 J=MMIN2,MMAX2
31026 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31027 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31028 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31029 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31035 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31036 & (IABS(I)+1)/2)*VINT(180+J)
31037 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31038 & (MINT(55)+1)/2)*VINT(180+J)
31041 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31042 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31045 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31046 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31049 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31050 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31052 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31058 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31059 & (IABS(J)+1)/2)*VINT(180+I)
31060 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31061 & (MINT(55)+1)/2)*VINT(180+I)
31064 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31065 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31068 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31069 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31072 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31073 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31078 ELSEIF(ISUB.EQ.84) THEN
31079 C...g + gamma -> Q + Qbar
31080 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31081 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31082 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31083 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31084 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31086 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31088 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31089 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31091 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31098 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31106 ELSEIF(ISUB.EQ.85) THEN
31107 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31108 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31109 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31110 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31111 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31112 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31113 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31114 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31115 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31116 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31117 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31119 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31120 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31121 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31123 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31131 ELSEIF(ISUB.EQ.86) THEN
31132 C...g + g -> J/Psi + g
31133 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31134 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31135 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31136 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31144 ELSEIF(ISUB.EQ.87) THEN
31145 C...g + g -> chi_0c + g
31146 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31147 QGTW=(SH*TH*UH)/SH**3
31149 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31150 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31151 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31152 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31153 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31154 & (QGTW*(QGTW-RGTW*PGTW)**4)
31155 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31163 ELSEIF(ISUB.EQ.88) THEN
31164 C...g + g -> chi_1c + g
31165 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31166 QGTW=(SH*TH*UH)/SH**3
31168 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31169 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31170 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31171 & (QGTW-RGTW*PGTW)**4
31172 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31180 ELSEIF(ISUB.EQ.89) THEN
31181 C...g + g -> chi_2c + g
31182 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31183 QGTW=(SH*TH*UH)/SH**3
31185 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31186 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31187 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31188 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31189 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31190 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31191 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31200 ELSEIF(ISUB.LE.200) THEN
31201 IF(ISUB.EQ.104) THEN
31202 C...g + g -> chi_c0.
31204 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31205 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31206 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31207 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31215 ELSEIF(ISUB.EQ.105) THEN
31216 C...g + g -> chi_c2.
31218 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31219 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31220 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31221 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31229 ELSEIF(ISUB.EQ.106) THEN
31230 C...g + g -> J/Psi + gamma.
31231 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31232 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31233 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31234 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31235 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31243 ELSEIF(ISUB.EQ.107) THEN
31244 C...g + gamma -> J/Psi + g.
31245 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31246 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31247 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31248 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31249 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31256 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31264 ELSEIF(ISUB.EQ.108) THEN
31265 C...gamma + gamma -> J/Psi + gamma.
31266 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31267 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31268 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31269 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31270 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31280 C...Additional code by Stefan Wolf
31283 C...Common code for quarkonium production.
31290 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31291 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31293 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31294 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31298 IF(MSTP(145).EQ.1) THEN
31299 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31300 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31301 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31302 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31303 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31304 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31305 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31306 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31307 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31308 & ISUB.GE.437) THEN
31309 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31310 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31311 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31312 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31313 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31314 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31318 SMQQ2=SQMQQ*VINT(2)
31319 C...Polarisation frames
31320 IF(MSTP(146).EQ.1) THEN
31322 POLH1=SQRT(AQ2-SMQQ2)
31323 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31326 AX=AQ*BQ/(POLH1*POLH2)
31328 ELSEIF(MSTP(146).EQ.2) THEN
31329 C...Gottfried Jackson frame
31331 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31334 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
31335 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
31336 ELSEIF(MSTP(146).EQ.3) THEN
31339 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31342 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
31343 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
31344 ELSEIF(MSTP(146).EQ.4) THEN
31345 C...Collins Soper frame
31347 POLH2=SQRT(VINT(2)*POLH1)
31350 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
31351 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
31353 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31354 EL1K10=AZ*ATILK1+BZ*BTILK1
31355 EL1K20=AZ*ATILK2+BZ*BTILK2
31358 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
31359 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
31364 IF(ISUB.EQ.421) THEN
31365 C...g + g -> QQ~[3S11] + g
31366 IF(MSTP(145).EQ.0) THEN
31367 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31368 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
31369 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31370 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
31371 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31372 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31374 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
31375 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31379 IF(MSTP(147).EQ.0) THEN
31380 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31381 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31382 ELSEIF(MSTP(147).EQ.1) THEN
31383 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31384 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31385 ELSEIF(MSTP(147).EQ.3) THEN
31386 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31387 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31388 ELSEIF(MSTP(147).EQ.4) THEN
31389 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31390 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31391 ELSEIF(MSTP(147).EQ.5) THEN
31392 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31393 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31394 ELSEIF(MSTP(147).EQ.6) THEN
31395 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31396 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31398 FACQQG=COMFAC*FF*FACQQG
31400 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31405 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
31408 ELSEIF(ISUB.EQ.422) THEN
31409 C...g + g -> QQ~[3S18] + g
31410 IF(MSTP(145).EQ.0) THEN
31411 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
31412 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31414 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
31416 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31417 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
31418 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31422 IF(MSTP(147).EQ.0) THEN
31423 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31424 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31425 ELSEIF(MSTP(147).EQ.1) THEN
31426 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31427 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31428 ELSEIF(MSTP(147).EQ.3) THEN
31429 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31430 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31431 ELSEIF(MSTP(147).EQ.4) THEN
31432 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31433 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31434 ELSEIF(MSTP(147).EQ.5) THEN
31435 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31436 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31437 ELSEIF(MSTP(147).EQ.6) THEN
31438 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31439 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31441 FACQQG=COMFAC*FF*FACQQG
31443 C...Split total contribution into different colour flows just like
31444 C...in g g -> g g (recalculate kinematics for massless partons).
31445 THP=-0.5D0*SH*(1D0-CTH)
31446 UHP=-0.5D0*SH*(1D0+CTH)
31447 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31448 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31449 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31450 FACGGS=FACGG1+FACGG2+FACGG3
31451 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31456 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31461 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31466 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
31469 ELSEIF(ISUB.EQ.423) THEN
31470 C...g + g -> QQ~[1S08] + g
31471 IF(MSTP(145).EQ.0) THEN
31472 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31473 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31474 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31475 * & (SHTH2*THUH2*UHSH2)
31476 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
31477 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31478 & TH2/(SHTH2*THUH2))*
31479 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31481 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
31482 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31483 & TH2/(SHTH2*THUH2))*
31484 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31485 IF(MSTP(147).EQ.0) THEN
31487 ELSEIF(MSTP(147).EQ.1) THEN
31488 FACQQG=COMFAC*2D0*FA
31489 ELSEIF(MSTP(147).EQ.3) THEN
31491 ELSEIF(MSTP(147).EQ.4) THEN
31493 ELSEIF(MSTP(147).EQ.5) THEN
31495 ELSEIF(MSTP(147).EQ.6) THEN
31499 C...Split total contribution into different colour flows just like
31500 C...in g g -> g g (recalculate kinematics for massless partons).
31501 THP=-0.5D0*SH*(1D0-CTH)
31502 UHP=-0.5D0*SH*(1D0+CTH)
31503 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31504 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31505 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31506 FACGGS=FACGG1+FACGG2+FACGG3
31507 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31512 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31517 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31522 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
31525 ELSEIF(ISUB.EQ.424) THEN
31526 C...g + g -> QQ~[3PJ8] + g
31528 IF(MSTP(145).EQ.0) THEN
31529 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
31530 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
31531 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
31533 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
31534 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
31535 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
31537 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
31538 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
31539 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
31541 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
31542 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
31543 & +451D0*SH*TH**5+126D0*TH**6)
31544 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
31545 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
31546 & +171D0*SH*TH**5+42D0*TH**6)
31547 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
31548 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
31549 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
31550 & +99D0*SH*TH**3+35D0*TH**4)
31551 & +7D0*SQMQQ**8*SHTH*POLY)/
31552 & (SH*TH*UH*SQMQQR*SQMQQ*
31553 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31555 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
31556 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31557 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
31558 & -SQMQQ*SHTH2*POLY**2*
31559 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
31560 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
31561 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
31562 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
31563 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
31564 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
31565 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
31566 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
31567 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
31568 & +145D0*SH*TH**5+34D0*TH**6)
31569 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
31570 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
31572 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
31573 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
31574 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
31575 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
31576 & +3D0*SQMQQ**8*SHTH*POLY)
31577 BB=4D0*SHTH2*POLY**3
31578 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
31579 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
31580 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
31581 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
31582 & +84D0*SH*TH**9+20D0*TH**10)
31583 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
31584 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
31585 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
31587 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
31588 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
31589 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
31591 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
31592 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
31593 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
31594 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
31595 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
31597 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
31598 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
31599 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
31601 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
31602 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
31603 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
31604 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
31606 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
31607 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
31608 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
31609 & +394D0*SH*TH**9+84D0*TH**10)
31610 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
31611 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
31612 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
31613 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
31614 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
31615 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
31616 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
31617 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
31618 & +266D0*SH*TH**6+84D0*TH**7)
31619 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
31620 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
31622 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
31623 & +7D0*SH*TH**3+4*TH**4)
31624 & +SQMQQ**8*SH*(SH-TH)**2*TH
31625 DD=2D0*TH2*SHTH2*POLY**3
31626 & *(-SH2+2*SH*TH+2*TH2)
31627 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
31628 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
31629 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
31630 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
31631 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
31632 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
31633 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
31634 & -210D0*SH*TH**8-60D0*TH**9)
31635 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
31636 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
31637 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
31639 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
31640 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
31641 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
31642 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
31643 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
31644 & -30D0*SH*TH**6-24D0*TH**7)
31645 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
31646 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
31648 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
31649 IF(MSTP(147).EQ.0) THEN
31650 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31651 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31652 ELSEIF(MSTP(147).EQ.1) THEN
31653 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31654 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31655 ELSEIF(MSTP(147).EQ.3) THEN
31656 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31657 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31658 ELSEIF(MSTP(147).EQ.4) THEN
31659 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31660 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31661 ELSEIF(MSTP(147).EQ.5) THEN
31662 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31663 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31664 ELSEIF(MSTP(147).EQ.6) THEN
31665 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31666 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31668 FACQQG=COMFAC*FF*FACQQG
31670 C...Split total contribution into different colour flows just like
31671 C...in g g -> g g (recalculate kinematics for massless partons).
31672 THP=-0.5D0*SH*(1D0-CTH)
31673 UHP=-0.5D0*SH*(1D0+CTH)
31674 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31675 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31676 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31677 FACGGS=FACGG1+FACGG2+FACGG3
31678 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31683 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31688 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31693 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
31696 ELSEIF(ISUB.EQ.425) THEN
31697 C...q + g -> q + QQ~[3S18]
31698 IF(MSTP(145).EQ.0) THEN
31699 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
31700 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
31701 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
31703 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
31704 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
31709 IF(MSTP(147).EQ.0) THEN
31710 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31711 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31712 ELSEIF(MSTP(147).EQ.1) THEN
31713 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31714 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31715 ELSEIF(MSTP(147).EQ.3) THEN
31716 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31717 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31718 ELSEIF(MSTP(147).EQ.4) THEN
31719 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31720 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31721 ELSEIF(MSTP(147).EQ.5) THEN
31722 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31723 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31724 ELSEIF(MSTP(147).EQ.6) THEN
31725 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31726 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31728 FACQQG=COMFAC*FF*FACQQG
31730 C...Split total contribution into different colour flows just like
31731 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31732 C...(recalculate kinematics for massless partons).
31733 THP=-0.5D0*SH*(1D0-CTH)
31734 UHP=-0.5D0*SH*(1D0+CTH)
31735 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31736 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31737 FACQGS=FACQG1+FACQG2
31738 DO 2442 I=MMINA,MMAXA
31739 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
31741 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
31742 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
31745 ISIG(NCHN,3-ISDE)=21
31747 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
31750 ISIG(NCHN,3-ISDE)=21
31752 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
31756 ELSEIF(ISUB.EQ.426) THEN
31757 C...q + g -> q + QQ~[1S08]
31758 IF(MSTP(145).EQ.0) THEN
31759 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
31760 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
31762 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
31763 IF(MSTP(147).EQ.0) THEN
31765 ELSEIF(MSTP(147).EQ.1) THEN
31766 FACQQG=COMFAC*2D0*FA
31767 ELSEIF(MSTP(147).EQ.3) THEN
31769 ELSEIF(MSTP(147).EQ.4) THEN
31771 ELSEIF(MSTP(147).EQ.5) THEN
31773 ELSEIF(MSTP(147).EQ.6) THEN
31777 C...Split total contribution into different colour flows just like
31778 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31779 C...(recalculate kinematics for massless partons).
31780 THP=-0.5D0*SH*(1D0-CTH)
31781 UHP=-0.5D0*SH*(1D0+CTH)
31782 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31783 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31784 FACQGS=FACQG1+FACQG2
31785 DO 2444 I=MMINA,MMAXA
31786 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
31788 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
31789 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
31792 ISIG(NCHN,3-ISDE)=21
31794 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
31797 ISIG(NCHN,3-ISDE)=21
31799 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
31803 ELSEIF(ISUB.EQ.427) THEN
31804 C...q + g -> q + QQ~[3PJ8]
31805 IF(MSTP(145).EQ.0) THEN
31806 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
31807 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
31808 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
31809 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
31811 FF=10D0*PARU(1)*AS**3/
31812 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
31813 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
31814 BB=8D0*(SHTH2+TH*UH)
31815 CC=8D0*UHSH*(SHTH+THUH)
31816 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
31817 IF(MSTP(147).EQ.0) THEN
31818 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31819 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31820 ELSEIF(MSTP(147).EQ.1) THEN
31821 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31822 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31823 ELSEIF(MSTP(147).EQ.3) THEN
31824 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31825 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31826 ELSEIF(MSTP(147).EQ.4) THEN
31827 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31828 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31829 ELSEIF(MSTP(147).EQ.5) THEN
31830 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31831 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31832 ELSEIF(MSTP(147).EQ.6) THEN
31833 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31834 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31836 FACQQG=COMFAC*FF*FACQQG
31838 C...Split total contribution into different colour flows just like
31839 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31840 C...(recalculate kinematics for massless partons).
31841 THP=-0.5D0*SH*(1D0-CTH)
31842 UHP=-0.5D0*SH*(1D0+CTH)
31843 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31844 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31845 FACQGS=FACQG1+FACQG2
31846 DO 2446 I=MMINA,MMAXA
31847 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
31849 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
31850 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
31853 ISIG(NCHN,3-ISDE)=21
31855 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31858 ISIG(NCHN,3-ISDE)=21
31860 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31864 ELSEIF(ISUB.EQ.428) THEN
31865 C...q + q~ -> g + QQ~[3S18]
31866 IF(MSTP(145).EQ.0) THEN
31867 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31868 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31869 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31871 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31872 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31877 IF(MSTP(147).EQ.0) THEN
31878 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31879 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31880 ELSEIF(MSTP(147).EQ.1) THEN
31881 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31882 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31883 ELSEIF(MSTP(147).EQ.3) THEN
31884 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31885 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31886 ELSEIF(MSTP(147).EQ.4) THEN
31887 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31888 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31889 ELSEIF(MSTP(147).EQ.5) THEN
31890 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31891 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31892 ELSEIF(MSTP(147).EQ.6) THEN
31893 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31894 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31896 FACQQG=COMFAC*FF*FACQQG
31898 C...Split total contribution into different colour flows just like
31899 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31900 C...(recalculate kinematics for massless partons).
31901 THP=-0.5D0*SH*(1D0-CTH)
31902 UHP=-0.5D0*SH*(1D0+CTH)
31903 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31904 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31905 FACGGS=FACGG1+FACGG2
31906 DO 2447 I=MMINA,MMAXA
31907 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31908 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31913 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31918 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31921 ELSEIF(ISUB.EQ.429) THEN
31922 C...q + q~ -> g + QQ~[1S08]
31923 IF(MSTP(145).EQ.0) THEN
31924 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31925 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31927 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31928 IF(MSTP(147).EQ.0) THEN
31930 ELSEIF(MSTP(147).EQ.1) THEN
31931 FACQQG=COMFAC*2D0*FA
31932 ELSEIF(MSTP(147).EQ.3) THEN
31934 ELSEIF(MSTP(147).EQ.4) THEN
31936 ELSEIF(MSTP(147).EQ.5) THEN
31938 ELSEIF(MSTP(147).EQ.6) THEN
31942 C...Split total contribution into different colour flows just like
31943 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31944 C...(recalculate kinematics for massless partons).
31945 THP=-0.5D0*SH*(1D0-CTH)
31946 UHP=-0.5D0*SH*(1D0+CTH)
31947 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31948 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31949 FACGGS=FACGG1+FACGG2
31950 DO 2448 I=MMINA,MMAXA
31951 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31952 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31957 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31962 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31965 ELSEIF(ISUB.EQ.430) THEN
31966 C...q + q~ -> g + QQ~[3PJ8]
31967 IF(MSTP(145).EQ.0) THEN
31968 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31969 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31970 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31971 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31973 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31974 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31975 BB=8D0*(UHSH2+SH*TH)
31976 CC=8D0*(SHTH2+SH*UH)
31977 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31978 IF(MSTP(147).EQ.0) THEN
31979 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31980 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31981 ELSEIF(MSTP(147).EQ.1) THEN
31982 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31983 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31984 ELSEIF(MSTP(147).EQ.3) THEN
31985 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31986 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31987 ELSEIF(MSTP(147).EQ.4) THEN
31988 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31989 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31990 ELSEIF(MSTP(147).EQ.5) THEN
31991 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31992 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31993 ELSEIF(MSTP(147).EQ.6) THEN
31994 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31995 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31997 FACQQG=COMFAC*FF*FACQQG
31999 C...Split total contribution into different colour flows just like
32000 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32001 C...(recalculate kinematics for massless partons).
32002 THP=-0.5D0*SH*(1D0-CTH)
32003 UHP=-0.5D0*SH*(1D0+CTH)
32004 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32005 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32006 FACGGS=FACGG1+FACGG2
32007 DO 2449 I=MMINA,MMAXA
32008 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32009 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32014 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32019 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32022 ELSEIF(ISUB.EQ.431) THEN
32023 C...g + g -> QQ~[3P01] + g
32024 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32025 QGTW=(SH*TH*UH)/SH**3
32027 IF(MSTP(145).EQ.0) THEN
32028 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*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)
32037 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32038 & (9D0*RGTW**2*PGTW**4*
32039 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32040 & -6D0*RGTW*PGTW**3*QGTW*
32041 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32042 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32043 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32044 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32045 IF(MSTP(147).EQ.0) THEN
32047 ELSEIF(MSTP(147).EQ.1) THEN
32048 FACQQG=COMFAC*2D0*FC1
32049 ELSEIF(MSTP(147).EQ.3) THEN
32051 ELSEIF(MSTP(147).EQ.4) THEN
32053 ELSEIF(MSTP(147).EQ.5) THEN
32055 ELSEIF(MSTP(147).EQ.6) THEN
32059 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32064 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32067 ELSEIF(ISUB.EQ.432) THEN
32068 C...g + g -> QQ~[3P11] + g
32069 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32070 QGTW=(SH*TH*UH)/SH**3
32072 IF(MSTP(145).EQ.0) THEN
32073 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32074 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32075 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32076 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32078 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32079 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32080 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32081 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32082 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32083 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32084 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32085 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32086 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32087 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32088 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32089 C4=-4D0*THUH*(TH-UH)**2*
32090 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32091 & -SH2*TH*UH*(TH2+UH2))
32092 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32093 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32094 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32095 IF(MSTP(147).EQ.0) THEN
32096 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32097 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32098 ELSEIF(MSTP(147).EQ.1) THEN
32099 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32100 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32101 ELSEIF(MSTP(147).EQ.3) THEN
32102 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32103 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32104 ELSEIF(MSTP(147).EQ.4) THEN
32105 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32106 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32107 ELSEIF(MSTP(147).EQ.5) THEN
32108 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32109 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32110 ELSEIF(MSTP(147).EQ.6) THEN
32111 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32112 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32114 FACQQG=COMFAC*FF*FACQQG
32116 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32121 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32124 ELSEIF(ISUB.EQ.433) THEN
32125 C...g + g -> QQ~[3P21] + g
32126 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32127 QGTW=(SH*TH*UH)/SH**3
32129 IF(MSTP(145).EQ.0) THEN
32130 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32131 & (12D0*RGTW**2*PGTW**4*
32132 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32133 & -3D0*RGTW*PGTW**3*QGTW*
32134 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32135 & +2D0*PGTW**2*QGTW**2*
32136 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32137 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32138 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32140 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32141 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32142 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32144 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32145 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32146 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32147 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32148 & +10D0*(SH2**2+TH2**2))
32149 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32150 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32151 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32152 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32153 & +4D0*SH*TH*UH2**4*SHTH2)
32154 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32155 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32156 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32157 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32158 & +10D0*(SH2**2+UH2**2))
32159 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32160 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32161 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32162 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32163 & +4D0*SH*UH*TH2**4*UHSH2)
32164 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32165 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32166 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32167 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32168 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32169 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32170 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32171 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32172 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32173 & +3D0*(TH2**3+UH2**3)))
32174 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32175 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32176 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32177 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32178 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32179 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32180 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32182 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32184 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32186 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32187 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32188 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32189 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32190 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32191 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32193 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32195 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32197 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32198 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32199 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32200 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32201 & +4D0*SH*TH2**2*UH2**2*THUH2
32202 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32203 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32204 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32205 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32206 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32207 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32208 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32209 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32210 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32211 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32212 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32213 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32214 & +2D0*(TH2**3+UH2**3))
32215 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32216 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32217 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32218 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32219 IF(MSTP(147).EQ.0) THEN
32220 FACQQG=1D0/3D0*(C1*3D0
32221 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32222 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32223 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32224 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32225 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32226 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32227 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32228 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32229 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32230 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32231 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32232 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32233 ELSEIF(MSTP(147).EQ.1) THEN
32235 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32236 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32237 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32238 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32239 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32240 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32241 & +EL1K10*EL2K20*EL1K11*EL2K11)
32242 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32243 & +EL1K10*EL2K20*EL1K21*EL2K21)
32244 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32245 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32246 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32247 & +EL1K20*EL2K20*EL1K11*EL2K11)
32248 ELSEIF(MSTP(147).EQ.2) THEN
32250 & -C2*EL1K11*EL2K11
32251 & -C3*EL1K21*EL2K21
32252 & -C4*EL1K11*EL2K21
32253 & +C5*(EL1K11*EL2K11)**2
32254 & +C6*(EL1K21*EL2K21)**2
32255 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32256 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32257 & +(C9+C0)*(EL1K11*EL2K21)**2)
32259 FACQQG=COMFAC*FF*FACQQG
32261 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32266 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32269 ELSEIF(ISUB.EQ.434) THEN
32270 C...q + g -> q + QQ~[3P01]
32271 IF(MSTP(145).EQ.0) THEN
32272 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32273 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32275 FA=-PARU(1)*AS**3*(16D0/243D0)*
32276 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32277 IF(MSTP(147).EQ.0) THEN
32279 ELSEIF(MSTP(147).EQ.1) THEN
32280 FACQQG=COMFAC*2D0*FA
32281 ELSEIF(MSTP(147).EQ.3) THEN
32283 ELSEIF(MSTP(147).EQ.4) THEN
32285 ELSEIF(MSTP(147).EQ.5) THEN
32287 ELSEIF(MSTP(147).EQ.6) THEN
32291 DO 2452 I=MMINA,MMAXA
32292 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32294 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32295 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32298 ISIG(NCHN,3-ISDE)=21
32300 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32304 ELSEIF(ISUB.EQ.435) THEN
32305 C...q + g -> q + QQ~[3P11]
32306 IF(MSTP(145).EQ.0) THEN
32307 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32308 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32310 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32315 IF(MSTP(147).EQ.0) THEN
32316 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32317 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32318 ELSEIF(MSTP(147).EQ.1) THEN
32319 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32320 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32321 ELSEIF(MSTP(147).EQ.3) THEN
32322 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32323 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32324 ELSEIF(MSTP(147).EQ.4) THEN
32325 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32326 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32327 ELSEIF(MSTP(147).EQ.5) THEN
32328 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32329 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32330 ELSEIF(MSTP(147).EQ.6) THEN
32331 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32332 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32334 FACQQG=COMFAC*FF*FACQQG
32336 DO 2454 I=MMINA,MMAXA
32337 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
32339 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
32340 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
32343 ISIG(NCHN,3-ISDE)=21
32345 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32349 ELSEIF(ISUB.EQ.436) THEN
32350 C...q + g -> q + QQ~[3P21]
32351 IF(MSTP(145).EQ.0) THEN
32352 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
32353 & ((6D0*SQMQQ**2+TH2)*UHSH2
32354 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
32355 & (SQMQQR*TH*UHSH2**2)
32357 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
32359 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
32368 IF(MSTP(147).EQ.0) THEN
32369 FACQQG=1D0/3D0*(C1*3D0
32370 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32371 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32372 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32373 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32374 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32375 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32376 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32377 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32378 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32379 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32380 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32381 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32382 ELSEIF(MSTP(147).EQ.1) THEN
32384 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32385 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32386 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32387 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32388 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32389 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32390 & +EL1K10*EL2K20*EL1K11*EL2K11)
32391 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32392 & +EL1K10*EL2K20*EL1K21*EL2K21)
32393 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32394 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32395 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32396 & +EL1K20*EL2K20*EL1K11*EL2K11)
32397 ELSEIF(MSTP(147).EQ.2) THEN
32399 & -C2*EL1K11*EL2K11
32400 & -C3*EL1K21*EL2K21
32401 & -C4*EL1K11*EL2K21
32402 & +C5*(EL1K11*EL2K11)**2
32403 & +C6*(EL1K21*EL2K21)**2
32404 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32405 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32406 & +(C9+C0)*(EL1K11*EL2K21)**2)
32408 FACQQG=COMFAC*FF*FACQQG
32410 DO 2456 I=MMINA,MMAXA
32411 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
32413 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
32414 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
32417 ISIG(NCHN,3-ISDE)=21
32419 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32423 ELSEIF(ISUB.EQ.437) THEN
32424 C...q + q~ -> g + QQ~[3P01]
32425 IF(MSTP(145).EQ.0) THEN
32426 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
32427 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32429 FA=PARU(1)*AS**3*(128D0/729D0)*
32430 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32431 IF(MSTP(147).EQ.0) THEN
32433 ELSEIF(MSTP(147).EQ.1) THEN
32434 FACQQG=COMFAC*2D0*FA
32435 ELSEIF(MSTP(147).EQ.3) THEN
32437 ELSEIF(MSTP(147).EQ.4) THEN
32439 ELSEIF(MSTP(147).EQ.5) THEN
32441 ELSEIF(MSTP(147).EQ.6) THEN
32445 DO 2457 I=MMINA,MMAXA
32446 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32447 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
32452 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32455 ELSEIF(ISUB.EQ.438) THEN
32456 C...q + q~ -> g + QQ~[3P11]
32457 IF(MSTP(145).EQ.0) THEN
32458 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
32459 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
32461 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
32466 IF(MSTP(147).EQ.0) THEN
32467 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32468 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32469 ELSEIF(MSTP(147).EQ.1) THEN
32470 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32471 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32472 ELSEIF(MSTP(147).EQ.3) THEN
32473 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32474 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32475 ELSEIF(MSTP(147).EQ.4) THEN
32476 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32477 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32478 ELSEIF(MSTP(147).EQ.5) THEN
32479 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32480 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32481 ELSEIF(MSTP(147).EQ.6) THEN
32482 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32483 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32485 FACQQG=COMFAC*FF*FACQQG
32487 DO 2458 I=MMINA,MMAXA
32488 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32489 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
32494 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32497 ELSEIF(ISUB.EQ.439) THEN
32498 C...q + q~ -> g + QQ~[3P21]
32499 IF(MSTP(145).EQ.0) THEN
32500 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
32501 & ((6D0*SQMQQ**2+SH2)*THUH2
32502 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
32503 & (SQMQQR*SH*THUH2**2)
32505 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
32507 C2=4D0*(SH2+UH2+2D0*SH*THUH)
32508 C3=4D0*(SH2+TH2+2D0*SH*THUH)
32509 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
32516 IF(MSTP(147).EQ.0) THEN
32517 FACQQG=1D0/3D0*(C1*3D0
32518 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32519 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32520 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32521 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32522 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32523 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32524 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32525 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32526 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32527 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32528 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32529 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32530 ELSEIF(MSTP(147).EQ.1) THEN
32532 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32533 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32534 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32535 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32536 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32537 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32538 & +EL1K10*EL2K20*EL1K11*EL2K11)
32539 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32540 & +EL1K10*EL2K20*EL1K21*EL2K21)
32541 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32542 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32543 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32544 & +EL1K20*EL2K20*EL1K11*EL2K11)
32545 ELSEIF(MSTP(147).EQ.2) THEN
32547 & -C2*EL1K11*EL2K11
32548 & -C3*EL1K21*EL2K21
32549 & -C4*EL1K11*EL2K21
32550 & +C5*(EL1K11*EL2K11)**2
32551 & +C6*(EL1K21*EL2K21)**2
32552 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32553 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32554 & +(C9+C0)*(EL1K11*EL2K21)**2)
32556 FACQQG=COMFAC*FF*FACQQG
32558 DO 2459 I=MMINA,MMAXA
32559 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32560 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
32565 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32575 C*********************************************************************
32578 C...Subprocess cross sections for W/Z processes,
32579 C...except that longitudinal WW scattering is in Higgs sector.
32580 C...Auxiliary to PYSIGH.
32582 SUBROUTINE PYSGWZ(NCHN,SIGS)
32584 C...Double precision and integer declarations
32585 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32586 IMPLICIT INTEGER(I-N)
32587 INTEGER PYK,PYCHGE,PYCOMP
32588 C...Parameter statement to help give large particle numbers.
32589 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32590 &KEXCIT=4000000,KDIMEN=5000000)
32592 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32593 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32594 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32595 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32596 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32597 COMMON/PYINT1/MINT(400),VINT(400)
32598 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32599 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32600 COMMON/PYINT4/MWID(500),WIDS(500,5)
32601 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
32602 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32603 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32604 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32605 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32606 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
32607 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
32608 C...Local arrays and complex numbers
32609 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
32611 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32613 C...Differential cross section expressions.
32615 IF(ISUB.LE.20) THEN
32617 C...f + fbar -> gamma*/Z0
32619 CALL PYWIDT(23,SH,WDTP,WDTE)
32621 FACZ=4D0*COMFAC*3D0
32624 DO 100 I=MMINA,MMAXA
32625 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32626 EI=KCHG(IABS(I),1)/3D0
32630 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
32632 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
32637 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
32638 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
32639 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
32640 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
32643 ELSEIF(ISUB.EQ.2) THEN
32644 C...f + fbar' -> W+/-
32645 CALL PYWIDT(24,SH,WDTP,WDTE)
32647 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
32648 HP=AEM/(24D0*XW)*SH
32649 DO 120 I=MMIN1,MMAX1
32650 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32652 DO 110 J=MMIN2,MMAX2
32653 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32655 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
32656 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32658 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32660 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
32665 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
32666 SIGH(NCHN)=HI*FACBW*HF
32670 ELSEIF(ISUB.EQ.15) THEN
32671 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32672 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32673 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32677 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32678 DO 130 I=1,MIN(16,MDCY(23,3))
32680 IF(MDME(IDC,1).LT.0) GOTO 130
32682 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32686 AF=SIGN(1D0,EF+0.1D0)
32688 ELSEIF(I.LE.16) THEN
32690 AF=SIGN(1D0,EF+0.1D0)
32693 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32694 IF(4D0*RM1.LT.1D0) THEN
32696 IF(I.LE.8) FCOF=3D0*RADC4
32697 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32699 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32700 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32701 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32702 & AF**2*(1D0-4D0*RM1))*BE34
32706 C...Propagators: as simulated in PYOFSH and as desired
32707 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32711 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32713 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32714 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32715 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32716 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32717 C...Loop over flavours; consider full gamma/Z structure
32718 DO 140 I=MMINA,MMAXA
32719 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32720 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
32721 EI=KCHG(IABS(I),1)/3D0
32728 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
32729 & (VI**2+AI**2)*HFZZ)/HBW4
32732 ELSEIF(ISUB.EQ.16) THEN
32733 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32734 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32735 C...Propagators: as simulated in PYOFSH and as desired
32736 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32737 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32738 GMMWC=SQRT(SQM4)*WDTP(0)
32739 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32740 FACWG=FACWG*HBW4C/HBW4
32741 DO 160 I=MMIN1,MMAX1
32743 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
32744 DO 150 J=MMIN2,MMAX2
32746 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
32747 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
32748 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32749 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32750 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32755 SIGH(NCHN)=FACWG*FCKM*WIDSC
32759 ELSEIF(ISUB.EQ.19) THEN
32760 C...f + fbar -> gamma + (gamma*/Z0)
32761 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32762 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32766 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32767 DO 170 I=1,MIN(16,MDCY(23,3))
32769 IF(MDME(IDC,1).LT.0) GOTO 170
32771 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32775 AF=SIGN(1D0,EF+0.1D0)
32777 ELSEIF(I.LE.16) THEN
32779 AF=SIGN(1D0,EF+0.1D0)
32782 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32783 IF(4D0*RM1.LT.1D0) THEN
32785 IF(I.LE.8) FCOF=3D0*RADC4
32786 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32788 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32789 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32790 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32791 & AF**2*(1D0-4D0*RM1))*BE34
32795 C...Propagators: as simulated in PYOFSH and as desired
32796 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32800 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32802 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32803 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32804 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32805 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32806 C...Loop over flavours; consider full gamma/Z structure
32807 DO 180 I=MMINA,MMAXA
32808 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
32809 EI=KCHG(IABS(I),1)/3D0
32813 IF(IABS(I).LE.10) FCOI=FACA/3D0
32818 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32819 & (VI**2+AI**2)*HFZZ)/HBW4
32822 ELSEIF(ISUB.EQ.20) THEN
32823 C...f + fbar' -> gamma + W+/-
32824 FACGW=COMFAC*0.5D0*AEM**2/XW
32825 C...Propagators: as simulated in PYOFSH and as desired
32826 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32827 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32828 GMMWC=SQRT(SQM4)*WDTP(0)
32829 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32830 FACGW=FACGW*HBW4C/HBW4
32831 C...Anomalous couplings
32832 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32835 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
32836 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
32837 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
32838 & (4D0*SQMW))/(TH+UH)**2
32840 DO 200 I=MMIN1,MMAX1
32842 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
32843 DO 190 J=MMIN2,MMAX2
32845 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
32846 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
32847 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32849 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32850 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32852 FACWR=UH/(TH+UH)-1D0/3D0
32853 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32860 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32865 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32870 ELSEIF(ISUB.LE.40) THEN
32871 IF(ISUB.EQ.22) THEN
32872 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32873 C...Kinematics dependence
32874 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32875 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32876 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32882 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32883 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32884 DO 230 I=1,MIN(16,MDCY(23,3))
32886 IF(MDME(IDC,1).LT.0) GOTO 230
32888 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32889 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32892 AF=SIGN(1D0,EF+0.1D0)
32894 ELSEIF(I.LE.16) THEN
32896 AF=SIGN(1D0,EF+0.1D0)
32899 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32900 IF(4D0*RM1.LT.1D0) THEN
32902 IF(I.LE.8) FCOF=3D0*RADC3
32903 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32905 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32906 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32907 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32908 & AF**2*(1D0-4D0*RM1))*BE34
32911 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32912 IF(4D0*RM1.LT.1D0) THEN
32914 IF(I.LE.8) FCOF=3D0*RADC4
32915 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32917 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32918 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32919 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32920 & AF**2*(1D0-4D0*RM1))*BE34
32924 C...Propagators: as simulated in PYOFSH and as desired
32925 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32926 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32930 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32932 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32934 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32935 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32936 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32941 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32943 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32945 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32946 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32947 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32949 C...Loop over flavours; separate left- and right-handed couplings
32950 DO 270 I=MMINA,MMAXA
32951 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32952 EI=KCHG(IABS(I),1)/3D0
32958 IF(IABS(I).LE.10) FCOI=FACA/3D0
32960 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32961 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32962 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32963 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32965 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32966 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32967 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32968 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32973 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32976 ELSEIF(ISUB.EQ.23) THEN
32977 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32978 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32979 FACZW=FACZW*WIDS(23,2)
32980 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32981 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32982 DO 290 I=MMIN1,MMAX1
32984 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32985 DO 280 J=MMIN2,MMAX2
32987 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32988 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32989 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32991 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32993 AI=SIGN(1D0,EI+0.1D0)
32996 AJ=SIGN(1D0,EJ+0.1D0)
32998 IF(VI+AI.GT.0) THEN
33007 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33009 IF(IA.LE.10) FCOI=FACA/3D0
33014 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33015 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33016 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33017 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33018 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33019 & WIDS(24,(5-KCHW)/2)
33020 C***Protect against slightly negative cross sections. (Reason yet to be
33021 C***sorted out. One possibility: addition of width to the W propagator.)
33022 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33026 ELSEIF(ISUB.EQ.25) THEN
33027 C...f + fbar -> W+ + W-
33028 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33030 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33031 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33032 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33033 GMMW3=SQRT(SQM3)*WDTP(0)
33034 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33035 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33036 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33037 GMMW4=SQRT(SQM4)*WDTP(0)
33038 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33039 C...Kinematical functions
33040 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33041 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33042 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33043 GT=THUH34+4D0*THUH/TH2
33044 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33045 GU=THUH34+4D0*THUH/UH2
33046 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33047 C...Common factors and couplings
33048 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33049 FACWW=FACWW*WIDS(24,1)
33051 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33052 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33053 CNG=AEM**2/(4D0*XW)
33054 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33055 CNN=AEM**2/(16D0*XW**2)
33056 C...Coulomb factor for W+W- pair
33057 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33058 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33059 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33060 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33061 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33062 & PMAS(24,2)**2)-COULE))
33064 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33066 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33067 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33068 & PMAS(24,2)**2)+COULE))
33070 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33073 IF(MSTP(40).EQ.1) THEN
33074 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33075 & MAX(1D-10,2D0*COULP*COULP1))
33076 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33077 ELSEIF(MSTP(40).EQ.2) THEN
33078 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33079 COULCP=DCMPLX(0D0,DBLE(COULP))
33080 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33081 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33082 & (4D0*COULCP)*LOG(COULCD)
33083 COULCS=DCMPLX(0D0,0D0)
33086 COULXX=(ISTP-0.5)/NSTP
33087 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33088 & (1D0+COULXX/COULCD))
33090 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33092 FACCOU=ABS(COULCR)**2
33093 ELSEIF(MSTP(40).EQ.3) THEN
33094 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33095 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33096 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33098 ELSEIF(MSTP(40).EQ.4) THEN
33099 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33105 C...Loop over allowed flavours
33106 DO 310 I=MMINA,MMAXA
33107 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33108 EI=KCHG(IABS(I),1)/3D0
33109 AI=SIGN(1D0,EI+0.1D0)
33112 IF(IABS(I).LE.10) FCOI=FACA/3D0
33113 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33115 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33116 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33118 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33119 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33122 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33123 BET=SQRT(1D0-4D0*XMW02/SH)
33124 GAT=1D0/SQRT(1D0-BET**2)
33126 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33127 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33128 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33129 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33130 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33131 & (1D0-2D0*BET*CTH+BET**2))
33132 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33133 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33134 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33135 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33136 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33137 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33138 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33145 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33148 ELSEIF(ISUB.EQ.30) THEN
33149 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33150 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33152 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33156 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33157 DO 320 I=1,MIN(16,MDCY(23,3))
33159 IF(MDME(IDC,1).LT.0) GOTO 320
33161 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33165 AF=SIGN(1D0,EF+0.1D0)
33167 ELSEIF(I.LE.16) THEN
33169 AF=SIGN(1D0,EF+0.1D0)
33172 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33173 IF(4D0*RM1.LT.1D0) THEN
33175 IF(I.LE.8) FCOF=3D0*RADC4
33176 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33178 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33179 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33180 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33181 & AF**2*(1D0-4D0*RM1))*BE34
33185 C...Propagators: as simulated in PYOFSH and as desired
33186 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33190 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33192 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33193 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33194 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33195 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33196 C...Loop over flavours; consider full gamma/Z structure
33197 DO 340 I=MMINA,MMAXA
33198 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33199 EI=KCHG(IABS(I),1)/3D0
33202 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33203 & (VI**2+AI**2)*HFZZ)/HBW4
33205 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33206 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33209 ISIG(NCHN,3-ISDE)=21
33215 ELSEIF(ISUB.EQ.31) THEN
33216 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33217 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33218 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33219 C...Propagators: as simulated in PYOFSH and as desired
33220 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33221 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33222 GMMWC=SQRT(SQM4)*WDTP(0)
33223 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33224 FACWQ=FACWQ*HBW4C/HBW4
33225 DO 360 I=MMINA,MMAXA
33226 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33228 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33229 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33231 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33232 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33235 ISIG(NCHN,3-ISDE)=21
33237 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33241 ELSEIF(ISUB.EQ.35) THEN
33242 C...f + gamma -> f + (gamma*/Z0)
33243 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33244 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33245 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33246 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33247 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33248 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33250 FZQN=SH2+UH2+2D0*SQM4*TH
33253 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33254 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33258 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33259 DO 370 I=1,MIN(16,MDCY(23,3))
33261 IF(MDME(IDC,1).LT.0) GOTO 370
33263 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33267 AF=SIGN(1D0,EF+0.1D0)
33269 ELSEIF(I.LE.16) THEN
33271 AF=SIGN(1D0,EF+0.1D0)
33274 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33275 IF(4D0*RM1.LT.1D0) THEN
33277 IF(I.LE.8) FCOF=3D0*RADC4
33278 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33280 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33281 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33282 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33283 & AF**2*(1D0-4D0*RM1))*BE34
33287 C...Propagators: as simulated in PYOFSH and as desired
33288 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33292 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33294 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33295 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33296 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33297 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33298 C...Loop over flavours; consider full gamma/Z structure
33299 DO 390 I=MMINA,MMAXA
33300 IF(I.EQ.0) GOTO 390
33301 EI=KCHG(IABS(I),1)/3D0
33304 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33305 & (VI**2+AI**2)*HFZZ)/HBW4
33306 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33308 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33309 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33312 ISIG(NCHN,3-ISDE)=22
33314 SIGH(NCHN)=FACZQ*FZQN/FZQD
33318 ELSEIF(ISUB.EQ.36) THEN
33319 C...f + gamma -> f' + W+/-
33320 FWQ=COMFAC*AEM**2/(2D0*XW)*
33321 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33322 C...Propagators: as simulated in PYOFSH and as desired
33323 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33324 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33325 GMMWC=SQRT(SQM4)*WDTP(0)
33326 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33328 DO 410 I=MMINA,MMAXA
33329 IF(I.EQ.0) GOTO 410
33331 EIA=ABS(KCHG(IABS(I),1)/3D0)
33332 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33333 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33334 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33336 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
33337 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
33340 ISIG(NCHN,3-ISDE)=22
33342 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33347 ELSEIF(ISUB.LE.100) THEN
33348 IF(ISUB.EQ.69) THEN
33349 C...gamma + gamma -> W+ + W-
33350 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33351 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
33352 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
33353 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
33354 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
33362 ELSEIF(ISUB.EQ.70) THEN
33363 C...gamma + W+/- -> Z0 + W+/-
33364 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33365 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
33366 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
33367 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
33368 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
33369 DO 440 KCHW=1,-1,-2
33371 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
33374 ISIG(NCHN,3-ISDE)=24*KCHW
33376 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
33385 C*********************************************************************
33388 C...Subprocess cross sections for Higgs processes,
33389 C...except Higgs pairs in PYSGSU, but including WW scattering.
33390 C...Auxiliary to PYSIGH.
33392 SUBROUTINE PYSGHG(NCHN,SIGS)
33394 C...Double precision and integer declarations
33395 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33396 IMPLICIT INTEGER(I-N)
33397 INTEGER PYK,PYCHGE,PYCOMP
33398 C...Parameter statement to help give large particle numbers.
33399 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33400 &KEXCIT=4000000,KDIMEN=5000000)
33402 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33403 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33404 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33405 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33406 COMMON/PYINT1/MINT(400),VINT(400)
33407 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33408 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33409 COMMON/PYINT4/MWID(500),WIDS(500,5)
33410 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33411 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33412 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33413 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33414 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33415 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33416 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
33417 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
33418 C...Local arrays and complex variables
33419 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33420 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33421 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33423 C...Convert H or A process into equivalent h one
33426 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
33427 KFHIGG=KFPR(ISUB,1)
33429 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
33430 &ISUB.LE.190)) THEN
33432 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
33434 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
33435 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
33436 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
33437 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
33438 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
33439 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
33440 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
33441 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
33442 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
33443 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
33444 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
33445 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
33447 SQMH=PMAS(KFHIGG,1)**2
33448 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
33450 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33451 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
33452 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
33453 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33454 IF(MSTP(46).LE.4) THEN
33455 HDTLH=LOG(PMAS(25,1)/PARP(44))
33456 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
33457 HDTNR=-1D0/18D0+HDTLH/6D0
33459 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
33460 HDTLQ=LOG(PARP(45)/PARP(44))
33461 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
33462 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
33465 C...Calculate lowest and next-to-lowest order partial wave amplitudes
33466 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
33470 HDTLS=LOG(SH/PARP(44)**2)
33471 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33472 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
33473 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
33474 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33475 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
33476 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
33477 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
33478 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
33480 C...Unitarize partial wave amplitudes with Pade or K-matrix method
33481 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
33482 A00U=A00L/(1D0-A004/A00L)
33483 A20U=A20L/(1D0-A204/A20L)
33484 A11U=A11L/(1D0-A114/A11L)
33486 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
33487 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
33488 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
33492 C...Differential cross section expressions.
33494 IF(ISUB.LE.60) THEN
33496 C...f + fbar -> h0 (or H0, or A0)
33497 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33499 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33500 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33502 HP=AEM/(8D0*XW)*SH/SQMW*SH
33503 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33504 DO 100 I=MMINA,MMAXA
33505 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33507 RMQ=PYMRUN(IA,SH)**2/SH
33509 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
33510 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33512 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33513 IF(IA.GT.10) IKFI=3
33514 HI=HI*PARU(150+10*IHIGG+IKFI)**2
33515 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33516 HI=HI/(1D0+RMSS(41))**2
33517 IF(IHIGG.NE.3) THEN
33518 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33519 & PARU(151+10*IHIGG))**2
33527 SIGH(NCHN)=HI*FACBW*HF
33530 ELSEIF(ISUB.EQ.5) THEN
33532 CALL PYWIDT(25,SH,WDTP,WDTE)
33534 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33535 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33536 HP=AEM/(8D0*XW)*SH/SQMW*SH
33537 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33539 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
33540 DO 120 I=MMIN1,MMAX1
33541 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33542 DO 110 J=MMIN2,MMAX2
33543 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33544 EI=KCHG(IABS(I),1)/3D0
33547 EJ=KCHG(IABS(J),1)/3D0
33554 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
33558 ELSEIF(ISUB.EQ.8) THEN
33560 CALL PYWIDT(25,SH,WDTP,WDTE)
33562 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33563 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33564 HP=AEM/(8D0*XW)*SH/SQMW*SH
33565 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33567 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
33568 DO 140 I=MMIN1,MMAX1
33569 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
33570 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33571 DO 130 J=MMIN2,MMAX2
33572 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
33573 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33574 IF(EI*EJ.GT.0D0) GOTO 130
33579 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
33583 ELSEIF(ISUB.EQ.24) THEN
33584 C...f + fbar -> Z0 + h0 (or H0, or A0)
33585 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33586 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33587 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33588 GMMZ3=SQRT(SQM3)*WDTP(0)
33589 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
33590 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33591 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33592 GMMH4=SQRT(SQM4)*WDTP(0)
33593 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33594 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33595 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
33596 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
33597 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
33598 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
33599 & PARU(154+10*IHIGG)**2
33600 DO 150 I=MMINA,MMAXA
33601 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
33602 EI=KCHG(IABS(I),1)/3D0
33606 IF(IABS(I).LE.10) FCOI=FACA/3D0
33611 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
33614 ELSEIF(ISUB.EQ.26) THEN
33615 C...f + fbar' -> W+/- + h0 (or H0, or A0)
33616 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33617 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33618 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33619 GMMW3=SQRT(SQM3)*WDTP(0)
33620 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33621 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33622 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33623 GMMH4=SQRT(SQM4)*WDTP(0)
33624 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33625 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33626 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
33627 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
33628 FACHW=FACHW*WIDS(KFHIGG,2)
33629 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
33630 & PARU(155+10*IHIGG)**2
33631 DO 170 I=MMIN1,MMAX1
33633 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
33634 DO 160 J=MMIN2,MMAX2
33636 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
33637 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
33638 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33640 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33642 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33644 IF(IA.LE.10) FCOI=FACA/3D0
33649 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
33653 ELSEIF(ISUB.EQ.32) THEN
33654 C...f + g -> f + h0 (q + g -> q + h0 only)
33655 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
33656 C...H propagator: as simulated in PYOFSH and as desired
33657 SQMHC=PMAS(25,1)**2
33658 GMMHC=PMAS(25,1)*PMAS(25,2)
33659 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33660 CALL PYWIDT(25,SQM4,WDTP,WDTE)
33661 GMMHCC=SQRT(SQM4)*WDTP(0)
33662 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33663 FHCQ=FHCQ*HBW4C/HBW4
33664 DO 190 I=MMINA,MMAXA
33666 IF(IA.NE.5) GOTO 190
33667 SQML=PYMRUN(IA,SH)**2
33669 FACHCQ=FHCQ*SQML/SQMW*
33670 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33671 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
33672 & (SQM4-SQMQ-SH)/SH)
33674 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
33675 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
33678 ISIG(NCHN,3-ISDE)=21
33680 SIGH(NCHN)=FACHCQ*WIDS(25,2)
33685 ELSEIF(ISUB.LE.80) THEN
33686 IF(ISUB.EQ.71) THEN
33687 C...Z0 + Z0 -> Z0 + Z0
33688 IF(SH.LE.4.01D0*SQMZ) GOTO 220
33690 IF(MSTP(46).LE.2) THEN
33691 C...Exact scattering ME:s for on-mass-shell gauge bosons
33692 BE2=1D0-4D0*SQMZ/SH
33693 TH=-0.5D0*SH*BE2*(1D0-CTH)
33694 UH=-0.5D0*SH*BE2*(1D0+CTH)
33695 IF(MAX(TH,UH).GT.-1D0) GOTO 220
33696 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
33697 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33698 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33699 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
33700 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33701 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33702 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
33703 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33704 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33705 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33706 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33707 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33708 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
33709 & (ASHIM+ATHIM+AUHIM)**2)
33710 IF(MSTP(46).EQ.2) FACZZ=0D0
33713 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33714 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33715 & ABS(A00U+2D0*A20U)**2
33717 FACZZ=FACZZ*WIDS(23,1)
33719 DO 210 I=MMIN1,MMAX1
33720 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
33721 EI=KCHG(IABS(I),1)/3D0
33725 DO 200 J=MMIN2,MMAX2
33726 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
33727 EJ=KCHG(IABS(J),1)/3D0
33735 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
33740 ELSEIF(ISUB.EQ.72) THEN
33741 C...Z0 + Z0 -> W+ + W-
33742 IF(SH.LE.4.01D0*SQMZ) GOTO 250
33744 IF(MSTP(46).LE.2) THEN
33745 C...Exact scattering ME:s for on-mass-shell gauge bosons
33746 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33748 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33749 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33750 IF(MAX(TH,UH).GT.-1D0) GOTO 250
33751 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33752 & (1D0-2D0*SQMZ/SH)
33753 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33754 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33755 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33756 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33757 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33758 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33759 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33761 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33762 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33763 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33764 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33765 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33767 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33769 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33770 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33771 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
33772 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33773 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33774 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
33775 & (ATWIM+AUWIM+A4IM)**2)
33778 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33779 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33780 & ABS(A00U-A20U)**2
33782 FACWW=FACWW*WIDS(24,1)
33784 DO 240 I=MMIN1,MMAX1
33785 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
33786 EI=KCHG(IABS(I),1)/3D0
33790 DO 230 J=MMIN2,MMAX2
33791 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
33792 EJ=KCHG(IABS(J),1)/3D0
33800 SIGH(NCHN)=FACWW*AVI*AVJ
33805 ELSEIF(ISUB.EQ.73) THEN
33806 C...Z0 + W+/- -> Z0 + W+/-
33807 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
33809 IF(MSTP(46).LE.2) THEN
33810 C...Exact scattering ME:s for on-mass-shell gauge bosons
33811 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
33812 EP1=1D0-(SQMZ-SQMW)/SH
33813 EP2=1D0+(SQMZ-SQMW)/SH
33814 TH=-0.5D0*SH*BE2*(1D0-CTH)
33815 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
33816 IF(MAX(TH,UH).GT.-1D0) GOTO 280
33817 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
33818 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33819 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33820 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
33821 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
33822 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
33823 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
33825 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
33826 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
33827 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
33828 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
33829 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
33830 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
33831 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
33832 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
33833 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
33834 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
33835 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
33836 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
33838 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
33839 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
33841 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
33842 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
33843 IF(MSTP(46).LE.0) FACZW=0D0
33844 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
33845 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
33846 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
33847 & (ASWIM+AUWIM+A4IM)**2)
33850 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33851 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
33852 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
33854 FACZW=FACZW*WIDS(23,2)
33856 DO 270 I=MMIN1,MMAX1
33857 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33858 EI=KCHG(IABS(I),1)/3D0
33862 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33863 DO 260 J=MMIN2,MMAX2
33864 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33865 EJ=KCHG(IABS(J),1)/3D0
33869 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33874 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33879 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33884 ELSEIF(ISUB.EQ.75) THEN
33885 C...W+ + W- -> gamma + gamma
33887 ELSEIF(ISUB.EQ.76) THEN
33888 C...W+ + W- -> Z0 + Z0
33889 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33891 IF(MSTP(46).LE.2) THEN
33892 C...Exact scattering ME:s for on-mass-shell gauge bosons
33893 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33895 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33896 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33897 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33898 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33899 & (1D0-2D0*SQMZ/SH)
33900 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33901 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33902 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33903 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33904 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33905 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33906 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33908 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33909 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33910 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33911 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33912 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33914 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33916 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33918 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33919 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33920 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33921 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33922 & (ATWIM+AUWIM+A4IM)**2)
33925 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33926 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33927 & ABS(A00U-A20U)**2
33929 FACZZ=FACZZ*WIDS(23,1)
33931 DO 300 I=MMIN1,MMAX1
33932 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33933 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33934 DO 290 J=MMIN2,MMAX2
33935 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33936 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33937 IF(EI*EJ.GT.0D0) GOTO 290
33942 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33947 ELSEIF(ISUB.EQ.77) THEN
33948 C...W+/- + W+/- -> W+/- + W+/-
33949 IF(SH.LE.4.01D0*SQMW) GOTO 340
33951 IF(MSTP(46).LE.2) THEN
33952 C...Exact scattering ME:s for on-mass-shell gauge bosons
33953 BE2=1D0-4D0*SQMW/SH
33957 TH=-0.5D0*SH*BE2*(1D0-CTH)
33958 UH=-0.5D0*SH*BE2*(1D0+CTH)
33959 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33961 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33962 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33964 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33965 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33967 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33968 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33969 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33972 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33974 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33975 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33976 ATGRE=0.5D0*XW*SH/TH*TGZANG
33978 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33980 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33981 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33982 AUGRE=0.5D0*XW*SH/UH*UGZANG
33984 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33986 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33988 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33990 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33992 IF(MSTP(46).LE.0) THEN
33997 ELSEIF(MSTP(46).EQ.1) THEN
33998 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33999 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34000 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34001 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34003 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34004 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34005 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34006 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34008 AWWA2=AWWARE**2+AWWAIM**2
34009 AWWS2=AWWSRE**2+AWWSIM**2
34012 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34013 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34014 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34015 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34018 DO 330 I=MMIN1,MMAX1
34019 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34020 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34021 DO 320 J=MMIN2,MMAX2
34022 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34023 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34024 IF(EI*EJ.LT.0D0) THEN
34026 IF(MSTP(45).EQ.1) GOTO 320
34027 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34028 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34031 IF(MSTP(45).EQ.2) GOTO 320
34032 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34033 IF(MSTP(46).GE.3) FACWW=FWWS
34034 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34035 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34041 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34042 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34048 ELSEIF(ISUB.LE.120) THEN
34049 IF(ISUB.EQ.102) THEN
34050 C...g + g -> h0 (or H0, or A0)
34051 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34053 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34054 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34055 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34057 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34058 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34060 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34061 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34062 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34064 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34065 & '(PYSGHG:) did not find Higgs -> g g channel')
34068 HI=SHR*WDTP(13)/32D0
34070 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34075 SIGH(NCHN)=HI*FACBW*HF
34078 ELSEIF(ISUB.EQ.103) THEN
34079 C...gamma + gamma -> h0 (or H0, or A0)
34080 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34082 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34083 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34084 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34086 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34087 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34089 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34090 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34091 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34093 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34094 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34097 HI=SHR*WDTP(14)*2D0
34099 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34104 SIGH(NCHN)=HI*FACBW*HF
34107 ELSEIF(ISUB.EQ.110) THEN
34108 C...f + fbar -> gamma + h0
34109 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34110 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34111 FACHG=FACHG*WIDS(KFHIGG,2)
34112 C...Calculate loop contributions for intermediate gamma* and Z0
34113 CIGTOT=DCMPLX(0D0,0D0)
34114 CIZTOT=DCMPLX(0D0,0D0)
34117 IF(J.LE.2*MSTP(1)) THEN
34120 AJ=SIGN(1D0,EJ+0.1D0)
34122 BALP=SQM4/(2D0*PMAS(J,1))**2
34123 BBET=SH/(2D0*PMAS(J,1))**2
34124 ELSEIF(J.LE.3*MSTP(1)) THEN
34126 JL=2*(J-2*MSTP(1))-1
34127 EJ=KCHG(10+JL,1)/3D0
34128 AJ=SIGN(1D0,EJ+0.1D0)
34130 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34131 BBET=SH/(2D0*PMAS(10+JL,1))**2
34133 BALP=SQM4/(2D0*PMAS(24,1))**2
34134 BBET=SH/(2D0*PMAS(24,1))**2
34136 BABI=1D0/(BALP-BBET)
34137 IF(BALP.LT.1D0) THEN
34138 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34141 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34142 & -DBLE(0.5D0*PARU(1)))
34145 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34146 IF(BBET.LT.1D0) THEN
34147 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34150 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34151 & -DBLE(0.5D0*PARU(1)))
34154 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34155 IF(J.LE.3*MSTP(1)) THEN
34156 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34157 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34158 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34159 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34162 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34163 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34164 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34165 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34166 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34167 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34171 CIGTOT=CIGTOT/DBLE(SH)
34172 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34173 C...Loop over initial flavours
34174 DO 380 I=MMINA,MMAXA
34175 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34176 EI=KCHG(IABS(I),1)/3D0
34180 IF(IABS(I).LE.10) FCOI=FACA/3D0
34185 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34186 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34189 ELSEIF(ISUB.EQ.111) THEN
34190 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34191 IF(MSTP(38).NE.0) THEN
34192 C...Simple case: only do gg <-> h exactly.
34193 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34194 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34195 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34197 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34198 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34199 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34201 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34202 & '(PYSGHG:) did not find Higgs -> g g channel')
34203 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34204 & (TH**2+UH**2)/(SH*SQM4)
34206 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34207 & (TH**2+UH**2)/(SH*SQM4)
34209 C...Propagators: as simulated in PYOFSH and as desired
34210 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34211 GMMHC=SQRT(SQM4)*WDTP(0)
34212 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34213 & ((SQM4-SQMH)**2+GMMHC**2)
34214 FACGH=FACGH*HBW4C/HBW4
34216 C...Messy case: do full loop integrals
34219 DO 390 I=1,2*MSTP(1)
34223 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34224 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34225 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34226 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34227 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34228 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34229 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34230 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34232 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34233 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34234 FACGH=FACGH*WIDS(25,2)
34236 DO 400 I=MMINA,MMAXA
34237 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34238 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34246 ELSEIF(ISUB.EQ.112) THEN
34247 C...f + g -> f + h0 (q + g -> q + h0 only)
34248 IF(MSTP(38).NE.0) THEN
34249 C...Simple case: only do gg <-> h exactly.
34250 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34251 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34252 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34254 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34255 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34256 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34258 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34259 & '(PYSGHG:) did not find Higgs -> g g channel')
34260 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34261 & (SH**2+UH**2)/(-TH*SQM4)
34263 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34264 & (SH**2+UH**2)/(-TH*SQM4)
34266 C...Propagators: as simulated in PYOFSH and as desired
34267 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34268 GMMHC=SQRT(SQM4)*WDTP(0)
34269 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34270 & ((SQM4-SQMH)**2+GMMHC**2)
34271 FACQH=FACQH*HBW4C/HBW4
34273 C...Messy case: do full loop integrals
34276 DO 410 I=1,2*MSTP(1)
34280 CALL PYWAUX(1,EPST,W1TR,W1TI)
34281 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34282 CALL PYWAUX(2,EPST,W2TR,W2TI)
34283 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34284 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34285 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34286 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34287 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34289 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34290 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34291 FACQH=FACQH*WIDS(25,2)
34293 DO 430 I=MMINA,MMAXA
34294 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34296 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34297 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34300 ISIG(NCHN,3-ISDE)=21
34306 ELSEIF(ISUB.EQ.113) THEN
34307 C...g + g -> g + h0
34308 IF(MSTP(38).NE.0) THEN
34309 C...Simple case: only do gg <-> h exactly.
34310 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34311 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34312 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34314 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34315 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34316 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34318 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34319 & '(PYSGHG:) did not find Higgs -> g g channel')
34320 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34321 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34323 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34324 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34326 C...Propagators: as simulated in PYOFSH and as desired
34327 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34328 GMMHC=SQRT(SQM4)*WDTP(0)
34329 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34330 & ((SQM4-SQMH)**2+GMMHC**2)
34331 FACGH=FACGH*HBW4C/HBW4
34333 C...Messy case: do full loop integrals
34342 DO 440 I=1,2*MSTP(1)
34348 IF(EPSH.LT.1D-6) GOTO 440
34349 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34350 CALL PYWAUX(1,EPST,W1TR,W1TI)
34351 CALL PYWAUX(1,EPSU,W1UR,W1UI)
34352 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34353 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34354 CALL PYWAUX(2,EPST,W2TR,W2TI)
34355 CALL PYWAUX(2,EPSU,W2UR,W2UI)
34356 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34357 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
34358 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
34359 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
34360 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
34361 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
34362 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
34363 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
34364 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
34365 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
34366 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
34367 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
34368 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
34369 W3STUR=YHSTUR-Y3STUR-Y3UTSR
34370 W3STUI=YHSTUI-Y3STUI-Y3UTSI
34371 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
34372 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
34373 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
34374 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
34375 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
34376 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
34377 W3USTR=YHUSTR-Y3USTR-Y3TSUR
34378 W3USTI=YHUSTI-Y3USTI-Y3TSUI
34379 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
34380 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
34381 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
34382 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
34383 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
34384 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
34385 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
34386 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
34387 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
34388 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
34389 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
34390 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
34391 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
34392 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
34393 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
34394 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
34395 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
34396 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
34397 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
34398 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
34399 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
34400 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
34401 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
34402 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
34403 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
34404 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
34405 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
34406 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
34407 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
34408 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
34409 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
34410 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
34411 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
34412 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
34413 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
34414 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
34415 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
34416 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
34417 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
34418 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
34419 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
34420 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
34421 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
34422 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
34423 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
34424 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
34425 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
34426 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
34427 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
34428 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
34429 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
34430 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
34431 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
34432 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
34433 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
34434 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
34435 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
34436 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
34437 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
34438 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
34439 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
34440 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
34441 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34442 & (W2SR-W2HR+W3STUR))
34443 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
34444 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34445 & (W2TR-W2HR+W3TUSR))
34446 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
34447 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34448 & (W2UR-W2HR+W3USTR))
34449 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
34450 A2STUR=A2STUR+B2STUR+B2SUTR
34451 A2STUI=A2STUI+B2STUI+B2SUTI
34452 A2USTR=A2USTR+B2USTR+B2UTSR
34453 A2USTI=A2USTI+B2USTI+B2UTSI
34454 A2TUSR=A2TUSR+B2TUSR+B2TSUR
34455 A2TUSI=A2TUSI+B2TUSI+B2TSUI
34456 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
34457 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
34459 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
34460 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
34461 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
34462 FACGH=FACGH*WIDS(25,2)
34464 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
34473 ELSEIF(ISUB.LE.170) THEN
34474 IF(ISUB.EQ.121) THEN
34475 C...g + g -> Q + Qbar + h0
34476 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
34479 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34480 & (0.5D0*PMF/PMAS(24,1))**2
34482 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34484 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34486 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34487 IF(IA.GT.10) IKFI=3
34488 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34489 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34490 FACQQH=FACQQH/(1D0+RMSS(41))**2
34491 IF(IHIGG.NE.3) THEN
34492 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34493 & PARU(151+10*IHIGG))**2
34497 CALL PYQQBH(WTQQBH)
34498 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34500 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34501 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34502 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34508 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34511 ELSEIF(ISUB.EQ.122) THEN
34512 C...q + qbar -> Q + Qbar + h0
34515 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34516 & (0.5D0*PMF/PMAS(24,1))**2
34518 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34520 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34522 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34523 IF(IA.GT.10) IKFI=3
34524 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34525 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34526 FACQQH=FACQQH/(1D0+RMSS(41))**2
34527 IF(IHIGG.NE.3) THEN
34528 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34529 & PARU(151+10*IHIGG))**2
34533 CALL PYQQBH(WTQQBH)
34534 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34536 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34537 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34538 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34540 DO 470 I=MMINA,MMAXA
34541 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34542 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
34547 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34550 ELSEIF(ISUB.EQ.123) THEN
34551 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34553 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
34554 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34555 & PARU(154+10*IHIGG)**2
34556 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34557 & (VINT(216)-VINT(209)**2))**2
34558 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34559 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
34560 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34562 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34563 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34564 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34566 DO 490 I=MMIN1,MMAX1
34567 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
34569 DO 480 J=MMIN2,MMAX2
34570 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
34572 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
34573 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
34575 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
34576 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
34578 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
34579 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
34584 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
34588 ELSEIF(ISUB.EQ.124) THEN
34589 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34591 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
34592 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34593 & PARU(155+10*IHIGG)**2
34594 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34595 & (VINT(216)-VINT(209)**2))**2
34596 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34597 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34599 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34600 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34601 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34603 DO 510 I=MMIN1,MMAX1
34604 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
34605 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34606 DO 500 J=MMIN2,MMAX2
34607 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
34608 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34609 IF(EI*EJ.GT.0D0) GOTO 500
34610 FACLR=VINT(180+I)*VINT(180+J)
34615 SIGH(NCHN)=FACLR*FACWW*FACBW
34619 ELSEIF(ISUB.EQ.143) THEN
34620 C...f + fbar' -> H+/-
34621 SQMHC=PMAS(37,1)**2
34622 CALL PYWIDT(37,SH,WDTP,WDTE)
34624 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
34625 HP=AEM/(8D0*XW)*SH/SQMW*SH
34626 DO 530 I=MMIN1,MMAX1
34627 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
34629 IM=(MOD(IA,10)+1)/2
34630 DO 520 J=MMIN2,MMAX2
34631 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
34633 JM=(MOD(JA,10)+1)/2
34634 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
34635 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34637 IF(MOD(IA,2).EQ.0) THEN
34644 RML=PYMRUN(IL,SH)**2/SH
34645 RMU=PYMRUN(IU,SH)**2/SH
34646 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
34647 IF(IA.LE.10) HI=HI*FACA/3D0
34648 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34649 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
34654 SIGH(NCHN)=HI*FACBW*HF
34658 ELSEIF(ISUB.EQ.161) THEN
34659 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34660 C...(choice of only b and t to avoid kinematics problems)
34661 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
34662 C...H propagator: as simulated in PYOFSH and as desired
34663 SQMHC=PMAS(37,1)**2
34664 GMMHC=PMAS(37,1)*PMAS(37,2)
34665 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34666 CALL PYWIDT(37,SQM4,WDTP,WDTE)
34667 GMMHCC=SQRT(SQM4)*WDTP(0)
34668 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34669 FHCQ=FHCQ*HBW4C/HBW4
34671 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
34672 DO 550 I=MMINA,MMAXA
34674 IF(IA.NE.5) GOTO 550
34675 SQML=PYMRUN(IA,Q2RM)**2
34677 SQMQ=PYMRUN(IUA,Q2RM)**2
34678 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
34679 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34680 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
34681 & (SQMHC-SQMQ-SH)/SH)
34682 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34684 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
34685 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
34688 ISIG(NCHN,3-ISDE)=21
34690 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
34691 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
34696 ELSEIF(ISUB.LE.402) THEN
34697 IF(ISUB.EQ.401) THEN
34698 C... g + g -> t + bbar + H-
34699 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
34702 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34704 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34705 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34711 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34712 c Since we don't know yet if H+ or H-, assume H+
34713 c when calculating suppression due to closed channels.
34714 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34715 IF(ABS(WIDS(37,2)-WIDS(37,3))
34716 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
34717 & ABS(WIDS(6,2)-WIDS(6,3))
34718 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
34719 WRITE(*,*)'Error: Process 401 cannot handle different'
34720 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34721 WRITE(*,*)'Execution stopped.'
34726 ELSEIF(ISUB.EQ.402) THEN
34727 C... q + qbar -> t + bbar + H-
34730 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34732 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34733 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34735 DO 570 I=MMINA,MMAXA
34736 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34737 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
34742 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34743 c Since we don't know yet if H+ or H-, assume H+
34744 c when calculating suppression due to closed channels.
34745 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34746 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
34748 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
34750 WRITE(*,*)'Error: Process 402 cannot handle different'
34751 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34752 WRITE(*,*)'Execution stopped.'
34762 C*********************************************************************
34765 C...Subprocess cross sections for SUSY processes,
34766 C...including Higgs pair production.
34767 C...Auxiliary to PYSIGH.
34769 SUBROUTINE PYSGSU(NCHN,SIGS)
34771 C...Double precision and integer declarations
34772 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34773 IMPLICIT INTEGER(I-N)
34774 INTEGER PYK,PYCHGE,PYCOMP
34775 C...Parameter statement to help give large particle numbers.
34776 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34777 &KEXCIT=4000000,KDIMEN=5000000)
34779 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34780 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34781 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34782 COMMON/PYINT1/MINT(400),VINT(400)
34783 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34784 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34785 COMMON/PYINT4/MWID(500),WIDS(500,5)
34786 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34787 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34788 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34789 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34790 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34791 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34792 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34793 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
34794 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
34795 C...Local arrays and complex variables
34796 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34797 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34798 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34799 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34802 C...Z and W width, combinations of weak mixing angle
34806 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34808 C...Convert almost equivalent SUSY processes into each other
34809 C...Extract differences in flavours and couplings
34811 C...Sleptons and sneutrinos
34812 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
34813 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34816 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
34817 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34820 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
34821 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34823 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
34824 IF(ISUB.EQ.210) THEN
34826 ELSEIF(ISUB.EQ.211) THEN
34828 ELSEIF(ISUB.EQ.212) THEN
34832 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
34833 IF(ISUB.EQ.213) THEN
34834 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34836 ELSEIF(ISUB.EQ.214) THEN
34843 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
34844 IF(ISUB.EQ.216) THEN
34847 ELSEIF(ISUB.EQ.217) THEN
34850 ELSEIF(ISUB.EQ.218) THEN
34853 ELSEIF(ISUB.EQ.219) THEN
34856 ELSEIF(ISUB.EQ.220) THEN
34859 ELSEIF(ISUB.EQ.221) THEN
34862 ELSEIF(ISUB.EQ.222) THEN
34865 ELSEIF(ISUB.EQ.223) THEN
34868 ELSEIF(ISUB.EQ.224) THEN
34871 ELSEIF(ISUB.EQ.225) THEN
34878 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
34879 IF(ISUB.EQ.226) THEN
34882 ELSEIF(ISUB.EQ.227) THEN
34885 ELSEIF(ISUB.EQ.228) THEN
34891 C...Neutralino + chargino
34892 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34893 IF(ISUB.EQ.229) THEN
34896 ELSEIF(ISUB.EQ.230) THEN
34899 ELSEIF(ISUB.EQ.231) THEN
34902 ELSEIF(ISUB.EQ.232) THEN
34905 ELSEIF(ISUB.EQ.233) THEN
34908 ELSEIF(ISUB.EQ.234) THEN
34911 ELSEIF(ISUB.EQ.235) THEN
34914 ELSEIF(ISUB.EQ.236) THEN
34920 C...Gluino + neutralino
34921 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34922 IF(ISUB.EQ.237) THEN
34924 ELSEIF(ISUB.EQ.238) THEN
34926 ELSEIF(ISUB.EQ.239) THEN
34928 ELSEIF(ISUB.EQ.240) THEN
34933 C...Gluino + chargino
34934 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34935 IF(ISUB.EQ.241) THEN
34937 ELSEIF(ISUB.EQ.242) THEN
34942 C...Squark + neutralino
34943 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34945 IF(MOD(ISUB,2).NE.0) ILR=1
34946 IF(ISUB.LE.247) THEN
34948 ELSEIF(ISUB.LE.249) THEN
34950 ELSEIF(ISUB.LE.251) THEN
34952 ELSEIF(ISUB.LE.253) THEN
34958 C...Squark + chargino
34959 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34960 IF(ISUB.LE.255) THEN
34962 ELSEIF(ISUB.LE.257) THEN
34965 IF(MOD(ISUB,2).EQ.0) THEN
34973 C...Squark + gluino
34974 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34979 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34981 IF(ISUB.EQ.262) ILR=1
34983 ELSEIF(ISUB.EQ.265) THEN
34987 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34989 IF(ISUB.LE.273) THEN
34990 IF(ISUB.EQ.273) ILR=1
34993 ELSEIF(ISUB.LE.276) THEN
34994 IF(ISUB.EQ.276) ILR=1
34997 ELSEIF(ISUB.LE.278) THEN
34998 IF(ISUB.EQ.278) ILR=1
35002 IF(ISUB.EQ.280) ILR=1
35007 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35009 IF(ISUB.LE.283) THEN
35010 IF(ISUB.EQ.283) ILR=1
35013 ELSEIF(ISUB.LE.286) THEN
35014 IF(ISUB.EQ.286) ILR=1
35017 ELSEIF(ISUB.LE.288) THEN
35018 IF(ISUB.EQ.288) ILR=1
35021 ELSEIF(ISUB.LE.290) THEN
35022 IF(ISUB.EQ.290) ILR=1
35025 ELSEIF(ISUB.LE.293) THEN
35026 IF(ISUB.EQ.293) ILR=1
35029 ELSEIF(ISUB.EQ.296) THEN
35033 C...Squark + gluino
35034 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35039 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35040 IF(ISUB.EQ.297) THEN
35041 RKF=.5D0*PARU(195)**2
35042 ELSEIF(ISUB.EQ.298) THEN
35043 RKF=.5D0*(1D0-PARU(195)**2)
35047 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35048 IF(ISUB.EQ.299) THEN
35051 ELSEIF(ISUB.EQ.300) THEN
35057 ELSEIF(ISUB.EQ.301) THEN
35063 C...Supersymmetric processes - all of type 2 -> 2 :
35064 C...correct final-state Breit-Wigners from fixed to running width.
35065 IF(MSTP(42).GT.0) THEN
35067 KFLW=KFPR(ISUBSV,I)
35069 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35070 IF(I.EQ.1) SQMI=SQM3
35071 IF(I.EQ.2) SQMI=SQM4
35072 SQMS=PMAS(KCW,1)**2
35073 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35074 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35075 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35076 GMMI=SQRT(SQMI)*WDTP(0)
35077 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35078 COMFAC=COMFAC*(HBWI/HBWS)
35082 C...Differential cross section expressions.
35084 IF(ISUB.LE.210) THEN
35085 IF(ISUB.EQ.201) THEN
35086 C...f + fbar -> e_L + e_Lbar
35087 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35088 DO 130 I=MMIN1,MMAX1
35090 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35092 TT3I=SIGN(1D0,EI+1D-6)/2D0
35096 C...Color factor for e+ e-
35097 IF(IA.GE.11) FCOL=3D0
35098 IF(ISUBSV.EQ.301) THEN
35101 ELSEIF(ILR.EQ.1) THEN
35102 A1=SFMIX(KFID,3)**2
35103 A2=SFMIX(KFID,4)**2
35104 ELSEIF(ILR.EQ.0) THEN
35105 A1=SFMIX(KFID,1)**2
35106 A2=SFMIX(KFID,2)**2
35108 XLQ=(TT3J-EJ*XW)*A1
35112 TAA=(EI*EJ)**2*(POLL+POLR)
35113 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35114 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35115 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35116 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35120 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35126 DK=1D0/(TH-SMZ(II)**2)
35127 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35129 FREK=FAC2*TANW*EI*ZMIX(II,1)
35130 TNN1=TNN1+FLEK**2*DK
35131 TNN2=TNN2+FREK**2*DK
35133 DL=1D0/(TH-SMZ(JJ)**2)
35134 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35136 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35137 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35140 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35141 & A2**2*TNN2**2*POLR)
35142 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35143 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35144 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35145 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35146 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35149 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35152 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35153 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35154 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35159 SIGH(NCHN)=FACQQ1+FACQQ2
35162 ELSEIF(ISUB.EQ.203) THEN
35163 C...f + fbar -> e_L + e_Rbar
35164 DO 160 I=MMIN1,MMAX1
35166 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35167 EI=KCHG(IABS(I),1)/3D0
35168 TT3I=SIGN(1D0,EI)/2D0
35172 C...Color factor for e+ e-
35173 IF(IA.GE.11) FCOL=3D0
35174 A1=SFMIX(KFID,1)**2
35175 A2=SFMIX(KFID,2)**2
35180 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35181 & /XW**2/XW1**2*A1*A2
35182 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35187 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35193 DK=1D0/(TH-SMZ(II)**2)
35194 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35196 FREK=FAC2*TANW*EI*ZMIX(II,1)
35197 TNN1=TNN1+FLEK**2*DK
35198 TNN2=TNN2+FREK**2*DK
35200 DL=1D0/(TH-SMZ(JJ)**2)
35201 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35203 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35204 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35207 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35208 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35209 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35210 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35211 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35212 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35215 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35216 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35217 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35223 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35224 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35229 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35230 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35233 ELSEIF(ISUB.EQ.210) THEN
35234 C...q + qbar' -> W*- > ~l_L + ~nu_L
35235 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35236 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35237 DO 180 I=MMIN1,MMAX1
35239 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35240 DO 170 J=MMIN2,MMAX2
35242 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35243 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35245 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35246 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35248 IF(KCHSUM.LT.0) KCHW=3
35253 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35254 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35255 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35257 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35258 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35260 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35265 ELSEIF(ISUB.LE.220) THEN
35266 IF(ISUB.EQ.213) THEN
35267 C...f + fbar -> ~nu_L + ~nu_Lbar
35268 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35269 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35270 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35272 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35275 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35278 DO 190 I=MMIN1,MMAX1
35280 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35283 C...Color factor for e+ e-
35284 IF(IA.GE.11) FCOL=3D0
35285 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35289 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35290 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35293 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35295 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35301 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35302 & *AEM**2*FCOL/3D0/XW**2
35305 ELSEIF(ISUB.EQ.216) THEN
35306 C...q + qbar -> ~chi0_1 + ~chi0_1
35307 IF(IZID1.EQ.IZID2) THEN
35308 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35310 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35311 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35313 FACXX=COMFAC*AEM**2/3D0/XW**2
35314 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35317 WU2 = (UH-ZM12)*(UH-ZM22)
35318 WT2 = (TH-ZM12)*(TH-ZM22)
35319 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35320 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35321 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35323 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35324 IF(IZID2.NE.IZID1) THEN
35325 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35328 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35329 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35331 DO 210 I=MMINA,MMAXA
35332 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35333 EI=KCHG(IABS(I),1)/3D0
35334 T3I=SIGN(1D0,EI+1D-6)/2D0
35335 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
35336 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
35337 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
35338 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
35339 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
35340 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
35341 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
35343 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
35344 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
35345 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
35347 IF(IABS(I).GE.11) FCOL=3D0
35348 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35349 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35350 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35351 & QRL*DCONJG(QRR)*POLR)*WS2
35356 SIGH(NCHN)=FACXX*FACGG1*FCOL
35360 ELSEIF(ISUB.LE.230) THEN
35361 IF(ISUB.EQ.226) THEN
35362 C...f + fbar -> ~chi+_1 + ~chi-_1
35363 FACXX=COMFAC*AEM**2/3D0
35366 WU2 = (UH-ZM12)*(UH-ZM22)
35367 WT2 = (TH-ZM12)*(TH-ZM22)
35368 WS2 = SMW(IZID1)*SMW(IZID2)*SH
35369 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35370 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35372 IF(IZID1.EQ.IZID2) DIFF=1D0
35374 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35375 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35376 IF(IZID2.NE.IZID1) THEN
35377 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
35378 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
35381 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
35382 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
35383 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
35384 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
35385 DO 230 I=MMINA,MMAXA
35386 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
35387 EI=KCHG(IABS(I),1)/3D0
35388 T3I=SIGN(1D0,EI+1D-6)/2D0
35389 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
35390 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
35391 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
35392 IF(MOD(I,2).EQ.0) THEN
35393 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
35394 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35395 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
35396 & DCMPLX(T3I/XW/(TH-XML2))
35398 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
35399 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35400 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
35401 & DCMPLX(T3I/XW/(TH-XML2))
35404 IF(IABS(I).GE.11) FCOL=3D0
35405 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35406 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35407 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35408 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
35413 IF(IZID1.EQ.IZID2) THEN
35414 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35416 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35417 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35422 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35423 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35427 ELSEIF(ISUB.EQ.229) THEN
35428 C...q + qbar' -> ~chi0_1 + ~chi+-_1
35429 FACXX=COMFAC*AEM**2/6D0/XW**2
35432 WU2 = (UH-ZM12)*(UH-ZM22)
35433 WT2 = (TH-ZM12)*(TH-ZM22)
35434 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
35435 RT2I = 1D0/SQRT(2D0)
35436 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
35437 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
35439 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35440 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35443 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35445 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
35446 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
35447 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
35448 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
35450 DO 270 I=MMIN1,MMAX1
35452 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
35454 T3I=SIGN(1D0,EI+1D-6)/2D0
35455 DO 260 J=MMIN2,MMAX2
35457 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
35458 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
35460 T3J=SIGN(1D0,EJ+1D-6)/2D0
35462 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35463 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35465 IF(KCHSUM.LT.0) KCHW=3
35466 IF(MOD(IA,2).EQ.0) THEN
35467 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35468 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35469 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
35470 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
35471 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35472 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
35475 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35476 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35477 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
35478 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
35479 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35480 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
35483 ZINTR=DBLE(QLR*DCONJG(QLL))
35484 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
35490 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35491 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35496 ELSEIF(ISUB.LE.240) THEN
35497 IF(ISUB.EQ.237) THEN
35498 C...q + qbar -> gluino + ~chi0_1
35499 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35500 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35502 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
35505 DO 280 I=MMINA,MMAXA
35506 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
35507 EI=KCHG(IABS(I),1)/3D0
35509 XLQC = -TANW*EI*ZMIX(IZID,1)
35510 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35511 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35514 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
35515 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
35516 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
35517 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
35518 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
35519 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35520 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
35521 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
35522 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
35523 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35528 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
35532 ELSEIF(ISUB.LE.250) THEN
35533 IF(ISUB.EQ.241) THEN
35534 C...q + qbar' -> ~chi+-_1 + gluino
35535 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
35538 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
35539 FAC0=UMIX(IZID,1)**2
35540 FAC1=VMIX(IZID,1)**2
35541 DO 300 I=MMIN1,MMAX1
35543 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
35544 DO 290 J=MMIN2,MMAX2
35546 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
35547 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
35549 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35550 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35552 IF(KCHSUM.LT.0) KCHW=3
35553 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
35554 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
35555 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
35556 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
35557 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
35558 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
35559 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
35560 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
35561 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
35562 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
35563 & SH/(TH-XMU2)/(UH-XMD2))/2D0
35568 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
35569 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35570 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35574 ELSEIF(ISUB.EQ.243) THEN
35575 C...q + qbar -> gluino + gluino
35576 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35579 DO 310 I=MMINA,MMAXA
35580 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35581 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
35583 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
35584 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
35585 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35586 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35587 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35588 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35589 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
35590 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
35591 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35592 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35593 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35594 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35598 C...1/2 for identical particles
35599 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
35602 ELSEIF(ISUB.EQ.244) THEN
35603 C...g + g -> gluino + gluino
35604 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35607 FACQQ1=COMFAC*AS**2*9D0/4D0*(
35608 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
35609 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
35610 FACQQ2=COMFAC*AS**2*9D0/4D0*(
35611 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
35612 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
35613 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
35614 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
35615 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
35620 SIGH(NCHN)=FACQQ1/2D0
35625 SIGH(NCHN)=FACQQ2/2D0
35630 SIGH(NCHN)=FACQQ3/2D0
35633 ELSEIF(ISUB.EQ.246) THEN
35634 C...g + q_j -> ~chi0_1 + ~q_j
35635 FAC0=COMFAC*AS*AEM/6D0/XW
35638 FACZQ0=FAC0*( (ZM2-TH)/SH +
35639 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35640 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35641 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35642 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
35643 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
35644 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
35645 EI=KCHG(IABS(I),1)/3D0
35647 XRQZ = -TANW*EI*ZMIX(IZID,1)
35648 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35649 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35651 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
35653 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
35659 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
35660 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
35663 ISIG(NCHN,3-ISDE)=21
35665 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35666 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35671 ELSEIF(ISUB.LE.260) THEN
35672 IF(ISUB.EQ.254) THEN
35673 C...g + q_j -> ~chi1_1 + ~q_i
35674 FAC0=COMFAC*AS*AEM/12D0/XW
35679 FACZQ0=FAC0*( (ZM2-TH)/SH +
35680 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35681 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35682 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
35683 IF(MOD(KFNSQ1,2).EQ.0) THEN
35690 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
35691 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
35692 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
35694 IF(MOD(IA,2).EQ.0) THEN
35699 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
35703 IF(I.LT.0) KCHWQ=5-KCHW
35705 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
35706 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
35709 ISIG(NCHN,3-ISDE)=21
35711 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35712 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
35716 ELSEIF(ISUB.EQ.258) THEN
35717 C...g + q_j -> gluino + ~q_i
35724 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
35725 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
35726 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
35727 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
35728 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
35730 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
35731 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
35732 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
35734 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
35735 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
35736 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35737 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
35738 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
35739 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
35742 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35743 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35745 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
35746 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
35749 ISIG(NCHN,3-ISDE)=21
35751 SIGH(NCHN)=FACQG1*FACSEL
35754 ISIG(NCHN,3-ISDE)=21
35756 SIGH(NCHN)=FACQG2*FACSEL
35761 ELSEIF(ISUB.LE.270) THEN
35762 IF(ISUB.EQ.261) THEN
35763 C...q_i + q_ibar -> ~t_1 + ~t_1bar
35764 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
35765 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35766 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35768 DO 390 I=MMIN1,MMAX1
35770 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
35771 IF(IA.GE.11.AND.IA.LE.18) THEN
35773 EJ=KCHG(KFNSQ,1)/3D0
35774 T3I=SIGN(1D0,EI)/2D0
35775 T3J=SIGN(1D0,EJ)/2D0
35776 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
35777 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
35778 XLF=2D0*(T3I-EI*XW)
35780 TAA=0.5D0*(EI*EJ)**2
35781 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35782 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35783 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35784 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35785 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35791 SIGH(NCHN)=FACQQ1*FAC0
35794 ELSEIF(ISUB.EQ.263) THEN
35795 C...f + fbar -> ~t1 + ~t2bar
35796 DO 400 I=MMIN1,MMAX1
35798 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
35799 EI=KCHG(IABS(I),1)/3D0
35800 TT3I=SIGN(1D0,EI)/2D0
35804 C...Color factor for e+ e-
35805 IF(IA.GE.11) FCOL=3D0
35806 XLQ=2D0*(TT3J-EJ*XW)
35808 XLF=2D0*(TT3I-EI*XW)
35810 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
35811 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
35812 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35813 C...Factor of 2 for t1 t2bar + t2 t1bar
35814 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
35815 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
35820 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35821 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35826 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35827 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35830 ELSEIF(ISUB.EQ.264) THEN
35831 C...g + g -> ~t_1 + ~t_1bar
35834 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
35835 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35836 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35837 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35838 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
35852 ELSEIF(ISUB.LE.280) THEN
35853 IF(ISUB.EQ.271) THEN
35854 C...q + q' -> ~q + ~q' (~g exchange)
35855 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35864 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
35865 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
35868 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
35869 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
35870 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
35873 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35874 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35875 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
35876 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
35878 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35881 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35882 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35884 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35885 IF(I*J.LT.0) GOTO 420
35890 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35891 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35894 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35895 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35897 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35898 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35899 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35906 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35907 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35909 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35910 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35911 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35917 ELSEIF(ISUB.EQ.274) THEN
35918 C...q + qbar' -> ~q + ~qbar'
35919 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35923 C...Mrenna...Normalization.and.1/XMT
35924 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35925 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35926 FACQQB=COMFAC*AS**2*4D0/9D0*(
35927 & (UH*TH-SQM3*SQM4)/SH2 )
35928 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35929 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35930 FACQQB=FACQQB+FACQQ1+FACQQI
35932 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35935 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35936 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35937 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35938 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35940 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35943 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35944 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35946 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35947 IF(I*J.GT.0) GOTO 440
35952 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35953 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35954 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35955 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35959 ELSEIF(ISUB.EQ.277) THEN
35960 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35961 C...if i .eq. j covered in 274
35962 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35963 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35965 DO 460 I=MMIN1,MMAX1
35967 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35968 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35969 IF(IA.EQ.KFNSQ) GOTO 460
35970 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35972 EJ=KCHG(KFNSQ,1)/3D0
35974 T3I=SIGN(1D0,EI)/2D0
35976 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35977 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35979 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35980 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35982 XLF=2D0*(T3I-EI*XW)
35989 TAA=0.5D0*(EI*EJ)**2
35990 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35991 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35992 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35993 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35994 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35995 ELSEIF(IA.LE.6) THEN
35996 FAC0=AS**2*8D0/9D0/2D0
36002 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36005 ELSEIF(ISUB.EQ.279) THEN
36006 C...g + g -> ~q_j + ~q_jbar
36009 C...5=RKF because ~t ~tbar treated separately
36010 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36011 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36012 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36013 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36018 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36023 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36033 C*********************************************************************
36036 C...Subprocess cross sections for Technicolor processes.
36037 C...Auxiliary to PYSIGH.
36039 SUBROUTINE PYSGTC(NCHN,SIGS)
36041 C...Double precision and integer declarations
36042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36043 IMPLICIT INTEGER(I-N)
36044 INTEGER PYK,PYCHGE,PYCOMP
36045 C...Parameter statement to help give large particle numbers.
36046 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36047 &KEXCIT=4000000,KDIMEN=5000000)
36049 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36050 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36051 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36052 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36053 COMMON/PYINT1/MINT(400),VINT(400)
36054 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36055 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36056 COMMON/PYINT4/MWID(500),WIDS(500,5)
36057 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36058 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36059 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36060 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36061 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36062 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36063 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36064 C...Local arrays and complex variables
36065 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36066 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36067 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36068 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36069 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36070 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36071 COMPLEX*16 DVVS,DVVT,DVVU
36074 C...Combinations of weak mixing angle.
36076 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36078 C...Convert almost equivalent technicolor processes into
36079 C...a few basic processes, and set distinguishing parameters.
36080 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36083 SN2W=2D0*SQRT(XW*XW1)
36086 CSXI=COS(ASIN(RTCM(3)))
36087 CSXIP=COS(ASIN(RTCM(4)))
36088 QUPD=2D0*RTCM(2)-1D0
36089 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36100 C... rho_tc0, etc. -> W_L W_L, W_L W_T
36101 IF(ISUB.EQ.361) THEN
36105 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36106 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36107 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36108 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36109 AXGP = SQRT(2D0)*AXGP
36110 ARGP = SQRT(2D0)*ARGP
36111 VOGP = SQRT(2D0)*VOGP
36112 C... rho_tc0 -> W_L pi_tc-
36113 ELSEIF(ISUB.EQ.362) THEN
36117 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36119 ELSEIF(ISUB.EQ.363) THEN
36123 CAB2=(1D0-RTCM(3)**2)**2
36124 C... rho_tc0/omega_tc -> gamma pi_tc
36125 ELSEIF(ISUB.EQ.364) THEN
36132 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36134 ELSEIF(ISUB.EQ.365) THEN
36138 VRGP=CSXIP/RTCM(12)
36140 VAGP=2D0*Q2UD*CSXIP
36141 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36143 ELSEIF(ISUB.EQ.366) THEN
36147 VOGP=CSXI*CT2W/RTCM(12)
36148 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36149 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36150 VZGP=-QUPD*CSXI*CS2W/XW1
36152 ELSEIF(ISUB.EQ.367) THEN
36156 C...RTCM(48) is the M_V for the techni-a
36157 VXGP=-CSXIP/SN2W/RTCM(48)
36158 VRGP=CSXIP*CT2W/RTCM(12)
36159 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36160 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36161 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36163 ELSEIF(ISUB.EQ.368) THEN
36167 C...RTCM(49) is the M_A for the techni-a
36168 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36169 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36170 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36171 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36172 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36173 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36174 ELSEIF(ISUB.EQ.370) THEN
36178 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36179 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36181 ELSEIF(ISUB.EQ.371) THEN
36185 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36187 ELSEIF(ISUB.EQ.372) THEN
36191 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36193 ELSEIF(ISUB.EQ.373) THEN
36197 CAB2=(1D0-RTCM(3)**2)**2
36199 ELSEIF(ISUB.EQ.374) THEN
36203 VRGP=QUPD*CSXI/RTCM(12)
36204 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36205 AXGP=-CSXI/RTCM(49)
36207 ELSEIF(ISUB.EQ.375) THEN
36211 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36212 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36213 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36214 AXGP=-CSXI*CT2W/RTCM(49)
36216 ELSEIF(ISUB.EQ.376) THEN
36221 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36222 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36224 ELSEIF(ISUB.EQ.377) THEN
36228 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36229 VWGP=CSXIP/(2D0*XW)
36230 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36232 ELSEIF(ISUB.EQ.378) THEN
36236 VRGP=QUPD*RTCM(3)/RTCM(12)
36237 AXGP=-RTCM(3)/RTCM(49)
36239 ELSEIF(ISUB.EQ.379) THEN
36243 VOGP=RTCM(3)/RTCM(12)
36244 VRGP=QUPD*RTCM(3)/RTCM(12)
36245 ELSEIF(ISUB.EQ.380) THEN
36249 VOGP=RTCM(3)*CT2W/RTCM(12)
36250 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36254 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36255 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36256 IF(ITCM(5).LE.4) THEN
36274 ELSEIF(ITCM(5).EQ.5) THEN
36276 IF(ITCM(2).EQ.0) THEN
36281 ALPRHT=2.16D0*(3D0/ITCM(1))
36282 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36283 SINT3=TANT3/SQRT(TANT3**2+1D0)
36284 XIG=SQRT(PYALPS(SH)/ALPRHT)
36285 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36286 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36287 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36288 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36289 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36290 & SINT3**2)*2D0/SIN2T
36291 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36292 & SINT3**2)*2D0/SIN2T
36294 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36295 SM1112=X12*RTCM(28)**2*SIN2T
36296 SM1121=-X21*RTCM(28)**2*SIN2T
36299 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36300 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36303 ZTC(1,1)=DCMPLX(SH,0D0)
36304 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36305 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36306 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36307 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36308 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36309 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36310 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36311 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36312 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36313 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36314 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36316 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36320 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36321 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36322 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36323 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36336 CALL PYLDCM(ZTC,6,6,INDX,D)
36340 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36345 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36351 XIG=SQRT(PYALPS(-TH)/ALPRHT)
36353 ZTC(1,1)=DCMPLX(TH)
36354 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
36355 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
36356 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
36357 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
36358 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
36360 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
36364 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
36365 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
36366 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
36367 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
36379 CALL PYLDCM(ZTC,6,6,INDX,D)
36383 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36387 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36393 XIG=SQRT(PYALPS(-UH)/ALPRHT)
36395 ZTC(1,1)=DCMPLX(UH,0D0)
36396 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
36397 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
36398 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
36399 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
36400 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
36402 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
36406 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
36407 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
36408 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
36409 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
36421 CALL PYLDCM(ZTC,6,6,INDX,D)
36425 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36429 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36436 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
36437 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
36438 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
36439 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
36440 DQGS=DGGS-DGVS*DCMPLX(TANT3)
36441 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36443 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36444 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
36445 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
36446 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36447 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36448 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36451 SQDQTS=ABS(DQTS)**2
36452 SQDQQS=ABS(DQQS)**2
36453 SQDQQT=ABS(DQQT)**2
36454 SQDQQU=ABS(DQQU)**2
36455 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
36457 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
36459 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
36461 SQDGGS=ABS(DGGS)**2
36462 SQDGGT=ABS(DGGT)**2
36463 SQDGGU=ABS(DGGU)**2
36467 REDGTU=DBLE(DGGU*DCONJG(DGGT))
36468 REDGSU=DBLE(DGGU*DCONJG(DGGS))
36469 REDGST=DBLE(DGGS*DCONJG(DGGT))
36470 REDQST=DBLE(DQQS*DCONJG(DQQT))
36471 REDQTU=DBLE(DQQT*DCONJG(DQQU))
36476 C...Differential cross section expressions.
36478 IF(ISUB.LE.190) THEN
36479 IF(ISUB.EQ.149) THEN
36480 C...g + g -> eta_tc
36481 KCTC=PYCOMP(KTECHN+331)
36482 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
36484 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
36485 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36487 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
36489 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36494 SIGH(NCHN)=HI*FACBW*HF
36497 ELSEIF(ISUB.EQ.165) THEN
36498 C...q + qbar -> l+ + l- (including contact term for compositeness)
36499 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36500 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36501 KFF=IABS(KFPR(ISUB,1))
36503 AF=SIGN(1D0,EF+0.1D0)
36508 IF(KFF.LE.10) FCOF=3D0
36510 IF(KFF.EQ.6) WID2=WIDS(6,1)
36511 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
36512 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36513 DO 260 I=MMINA,MMAXA
36514 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
36515 EI=KCHG(IABS(I),1)/3D0
36516 AI=SIGN(1D0,EI+0.1D0)
36521 IF(IABS(I).LE.10) FCOI=FACA/3D0
36522 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
36523 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
36524 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
36525 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36527 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
36528 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36530 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
36531 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
36532 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
36533 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
36534 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
36539 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
36542 ELSEIF(ISUB.EQ.166) THEN
36543 C...q + q'bar -> l + nu_l (including contact term for compositeness)
36544 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
36545 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
36546 KFF=IABS(KFPR(ISUB,1))
36548 IF(KFF.LE.10) FCOF=3D0
36549 DO 280 I=MMIN1,MMAX1
36550 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
36552 DO 270 J=MMIN2,MMAX2
36553 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
36555 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
36556 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36559 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36561 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
36562 & MOD(J,2).EQ.0)) THEN
36563 IF(KFF.EQ.5) WID2=WIDS(6,2)
36564 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
36565 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
36567 IF(KFF.EQ.5) WID2=WIDS(6,3)
36568 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
36569 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
36575 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
36576 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
36577 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
36582 ELSEIF(ISUB.LE.200) THEN
36583 IF(ISUB.EQ.191) THEN
36584 C...q + qbar -> rho_tc0.
36585 KCTC=PYCOMP(KTECHN+113)
36586 SQMRHT=PMAS(KCTC,1)**2
36587 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36589 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36590 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36591 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36592 ALPRHT=2.16D0*(3D0/ITCM(1))
36593 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
36594 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
36595 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36596 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36597 DO 290 I=MMINA,MMAXA
36598 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
36600 EI=KCHG(IABS(I),1)/3D0
36601 AI=SIGN(1D0,EI+0.1D0)
36605 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
36606 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
36607 IF(IA.LE.10) HI=HI*FACA/3D0
36612 SIGH(NCHN)=HI*FACBW*HF
36615 ELSEIF(ISUB.EQ.192) THEN
36616 C...q + qbar' -> rho_tc+/-.
36617 KCTC=PYCOMP(KTECHN+213)
36618 SQMRHT=PMAS(KCTC,1)**2
36619 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36621 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36622 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36623 ALPRHT=2.16D0*(3D0/ITCM(1))
36624 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
36625 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
36626 DO 310 I=MMIN1,MMAX1
36627 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
36629 DO 300 J=MMIN2,MMAX2
36630 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
36632 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
36633 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36635 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36636 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
36638 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36643 SIGH(NCHN)=HI*FACBW*HF
36647 ELSEIF(ISUB.EQ.193) THEN
36648 C...q + qbar -> omega_tc0.
36649 KCTC=PYCOMP(KTECHN+223)
36650 SQMOMT=PMAS(KCTC,1)**2
36651 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36653 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
36654 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36655 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36656 ALPRHT=2.16D0*(3D0/ITCM(1))
36657 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
36658 & (2D0*RTCM(2)-1D0)**2
36659 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36660 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36661 DO 320 I=MMINA,MMAXA
36662 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36664 EI=KCHG(IABS(I),1)/3D0
36665 AI=SIGN(1D0,EI+0.1D0)
36669 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
36670 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
36671 IF(IA.LE.10) HI=HI*FACA/3D0
36676 SIGH(NCHN)=HI*FACBW*HF
36679 ELSEIF(ISUB.EQ.194) THEN
36680 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36681 C...Default final state is e+e-
36683 ALPRHT=2.16D0*(3D0/ITCM(1))
36686 SN2W=2D0*SQRT(XW*XW1)
36687 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36688 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36690 QUPD=2D0*RTCM(2)-1D0
36691 FAR=SQRT(AEM/ALPRHT)
36695 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36696 FZX=-FAR/SN2W*RTCM(47)
36702 CALL PYWIDT(23,SH,WDTP,WDTE)
36703 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36704 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36705 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36706 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36707 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36708 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36709 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36710 C...Propagator including a_T^0
36711 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36712 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36713 C...Add in techni-a contribution
36714 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36715 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36716 $ SFZX*SSMR*SSMO)/DETD/SH
36717 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36718 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36720 XWRHT=1D0/(4D0*XW*(1D0-XW))
36721 KFF=IABS(KFPR(ISUB,1))
36723 AF=SIGN(1D0,EF+0.1D0)
36728 IF(KFF.LE.10) FCOF=3D0
36731 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
36732 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36733 DZZ=DZZ*DCMPLX(XWRHT,0D0)
36734 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
36736 DO 330 I=MMINA,MMAXA
36737 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
36738 EI=KCHG(IABS(I),1)/3D0
36739 AI=SIGN(1D0,EI+0.1D0)
36744 IF(IABS(I).LE.10) FCOI=FCOI/3D0
36745 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
36746 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
36747 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
36748 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
36749 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
36750 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
36755 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
36758 ELSEIF(ISUB.EQ.195) THEN
36759 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36762 ALPRHT=2.16D0*(3D0/ITCM(1))
36763 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
36765 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36766 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36768 C...Propagator including a_T^+
36770 CALL PYWIDT(24,SH,WDTP,WDTE)
36771 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36772 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36773 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36774 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36775 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36776 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36777 & DCMPLX(FWX**2,0D0)*SSMR
36778 DWW=SSMR*SSMX/DETD/SH
36780 IF(KFA.LE.8) FCOF=3D0
36781 HP=FACTC*ABS(DWW)**2*FCOF
36783 DO 350 I=MMIN1,MMAX1
36784 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
36786 DO 340 J=MMIN2,MMAX2
36787 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
36789 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
36790 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36792 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36794 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36799 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
36804 ELSEIF(ISUB.LE.380) THEN
36805 ALPRHT=2.16D0*(3D0/ITCM(1))
36806 IF(ISUB.EQ.361) THEN
36807 FAR=SQRT(AEM/ALPRHT)
36811 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36812 FZX=-FAR/SN2W*RTCM(47)
36818 CALL PYWIDT(23,SH,WDTP,WDTE)
36819 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36820 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36821 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36822 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36823 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36824 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36825 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36826 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36827 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36828 C...Add in techni-a contribution
36829 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36830 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
36831 $ SFZX*FAR*SSMO)/DETD/SH
36832 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
36833 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
36834 $ SFZX*FAO*SSMR)/DETD/SH
36835 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
36836 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
36837 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
36838 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36839 $ SFZX*SSMR*SSMO)/DETD/SH
36840 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36841 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36843 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36844 C...W+W-, W pi_tc, pi_T pi_T, etc.
36845 FACA=(SH**2*BE34**2-(TH-UH)**2)
36846 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36847 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36848 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36849 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
36850 DO 370 I=MMINA,MMAXA
36851 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
36853 EI=KCHG(IABS(I),1)/3D0
36854 AI=SIGN(1D0,EI+0.1D0)
36856 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
36857 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
36858 C...........Eqs. (5) and (6) in LSTC-rates.pdf
36859 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
36860 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
36861 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
36862 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
36863 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
36864 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
36865 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
36866 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
36867 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
36868 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
36869 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
36870 C...........Eqs. (5) and (7) in LSTC-rates.pdf
36871 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
36872 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
36873 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
36874 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
36875 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
36876 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
36877 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
36879 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36881 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36882 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36883 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36884 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36885 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36886 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36887 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36889 IF(IA.LE.10) HI=HI/3D0
36894 IF(KFA.EQ.KFB) THEN
36895 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36896 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36897 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36902 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36904 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36908 ELSEIF(ISUB.EQ.370) THEN
36909 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
36910 C...f + fbar' -> gamma pi_tc, etc.
36911 FACA=(SH**2*BE34**2-(TH-UH)**2)
36912 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36913 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36914 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36915 ALPRHT=2.16D0*(3D0/ITCM(1))
36916 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36917 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36918 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36920 CALL PYWIDT(24,SH,WDTP,WDTE)
36921 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36922 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36923 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36924 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36925 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36926 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36927 & DCMPLX(FWX**2,0D0)*SSMR
36928 DWW=SSMR*SSMX/DETD/SH
36929 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36930 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36931 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36932 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36934 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36936 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36937 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36938 C...Add in W_L Z_T axial and vector contributions.
36939 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36940 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36941 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36942 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36943 DO 410 I=MMIN1,MMAX1
36944 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36946 DO 400 J=MMIN2,MMAX2
36947 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36949 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36950 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36952 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36954 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36959 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36960 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36962 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36963 & WIDS(PYCOMP(KFB),2)
36969 ELSEIF(ISUB.LE.390) THEN
36970 IF(ISUB.EQ.381) THEN
36971 C...f + f' -> f + f' (g exchange)
36972 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36973 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36974 & MSTP(34)*2D0/3D0*UH2*REDQST)
36975 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36976 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36977 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36978 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36979 C...Modifications from contact interactions (compositeness)
36980 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36981 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36982 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36983 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36984 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36985 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36986 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36987 ELSEIF(ITCM(5).EQ.5) THEN
36992 CSM.......Check this change from
36996 DO 430 I=MMIN1,MMAX1
36998 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36999 DO 420 J=MMIN2,MMAX2
37001 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
37006 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37009 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37012 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37013 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37020 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37021 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37022 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37024 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37025 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37031 ELSEIF(ISUB.EQ.382) THEN
37032 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37033 CALL PYWIDT(21,SH,WDTP,WDTE)
37034 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37035 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37036 IF(ITCM(5).EQ.1) THEN
37037 C...Modifications from contact interactions (compositeness)
37040 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37041 & WDTE(I,2)+WDTE(I,4))
37043 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37044 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37045 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37046 ELSEIF(ITCM(5).EQ.5) THEN
37047 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37048 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37049 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37051 DO 450 I=MMINA,MMAXA
37052 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37053 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37058 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37060 ELSEIF(ITCM(5).EQ.5) THEN
37072 ELSEIF(ISUB.EQ.383) THEN
37073 C...f + fbar -> g + g (q + qbar -> g + g only)
37074 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37075 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37076 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37077 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37078 IF(ITCM(5).EQ.5) THEN
37079 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37080 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37081 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37082 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37084 DO 460 I=MMINA,MMAXA
37085 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37086 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37091 SIGH(NCHN)=0.5D0*FACGG1
37092 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37097 SIGH(NCHN)=0.5D0*FACGG2
37098 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37101 ELSEIF(ISUB.EQ.384) THEN
37102 C...f + g -> f + g (q + g -> q + g only)
37103 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37104 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37105 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37106 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37107 DO 480 I=MMINA,MMAXA
37108 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37110 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37111 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37114 ISIG(NCHN,3-ISDE)=21
37119 ISIG(NCHN,3-ISDE)=21
37125 ELSEIF(ISUB.EQ.385) THEN
37126 C...g + g -> f + fbar (g + g -> q + qbar only)
37127 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37129 C...Begin by d, u, s flavours.
37131 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37132 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37133 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37134 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37135 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37136 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37137 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37138 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37139 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37140 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37151 C...Next c and b flavours: modified that and uhat for fixed
37152 C...cos(theta-hat).
37154 SQMAVG=PMAS(IFL,1)**2
37155 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37156 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37157 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37158 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37159 THUHQ=THQ*UHQ-SQMAVG*SH
37160 IF(MSTP(34).EQ.0) THEN
37161 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37162 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37164 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37165 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37166 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37167 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37169 IF(ITCM(5).GE.5) THEN
37171 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37172 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37173 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37174 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37176 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37177 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37178 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37179 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37182 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37183 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37187 ISIG(NCHN,3)=1+2*(IFL-3)
37192 ISIG(NCHN,3)=2+2*(IFL-3)
37198 ELSEIF(ISUB.EQ.386) THEN
37200 IF(ITCM(5).LE.4) THEN
37201 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37202 & 2D0*TH/SH+TH2/SH2)*FACA
37203 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37204 & 2D0*SH/UH+SH2/UH2)*FACA
37205 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37206 & 2D0*UH/TH+UH2/TH2)
37208 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37209 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37210 & 4D0*REDGST*(SH + 2D0*TH)*
37211 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37212 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37213 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37214 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37215 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37216 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37217 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37218 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37219 & 4D0*REDGSU*(SH + 2D0*UH)*
37220 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37221 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37222 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37223 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37224 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37225 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37226 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37227 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37228 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37229 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37230 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37231 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37232 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37233 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37234 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37235 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37236 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37237 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37238 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37239 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37240 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37241 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37243 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37248 SIGH(NCHN)=0.5D0*FACGG1
37253 SIGH(NCHN)=0.5D0*FACGG2
37258 SIGH(NCHN)=0.5D0*FACGG3
37261 ELSEIF(ISUB.EQ.387) THEN
37262 C...q + qbar -> Q + Qbar
37263 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37264 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37265 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37266 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37268 IF(ITCM(5).GE.5) THEN
37269 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37270 FACQQB=FACQQB*SH2*SQDQTS
37272 FACQQB=FACQQB*SH2*SQDQQS
37275 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37277 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37278 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37280 DO 520 I=MMINA,MMAXA
37281 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37282 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37290 ELSEIF(ISUB.EQ.388) THEN
37291 C...g + g -> Q + Qbar
37292 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37293 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37294 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37295 THUHQ=THQ*UHQ-SQMAVG*SH
37296 IF(MSTP(34).EQ.0) THEN
37297 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37298 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37300 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37301 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37302 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37303 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37305 IF(ITCM(5).GE.5) THEN
37306 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37307 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37308 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37309 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37310 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37312 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37313 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37314 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37315 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37318 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37319 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37320 IF(MSTP(35).GE.1) THEN
37321 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37322 FACQQ1=FACQQ1*FATRE
37323 FACQQ2=FACQQ2*FATRE
37326 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37327 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37330 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37350 C*********************************************************************
37353 C...Subprocess cross sections for assorted exotic processes,
37354 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37355 C...Auxiliary to PYSIGH.
37357 SUBROUTINE PYSGEX(NCHN,SIGS)
37359 C...Double precision and integer declarations
37360 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37361 IMPLICIT INTEGER(I-N)
37362 INTEGER PYK,PYCHGE,PYCOMP
37363 C...Parameter statement to help give large particle numbers.
37364 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37365 &KEXCIT=4000000,KDIMEN=5000000)
37367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37368 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37369 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
37370 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37371 COMMON/PYINT1/MINT(400),VINT(400)
37372 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
37373 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
37374 COMMON/PYINT4/MWID(500),WIDS(500,5)
37375 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
37376 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
37377 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
37378 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
37379 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
37380 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
37381 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
37383 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
37385 C...Differential cross section expressions.
37387 IF(ISUB.LE.160) THEN
37388 IF(ISUB.EQ.141) THEN
37389 C...f + fbar -> gamma*/Z0/Z'0
37390 SQMZP=PMAS(32,1)**2
37392 CALL PYWIDT(32,SH,WDTP,WDTE)
37398 FACZP=4D0*COMFAC*3D0
37399 DO 100 I=MMINA,MMAXA
37400 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
37401 EI=KCHG(IABS(I),1)/3D0
37407 VPI=PARU(123-2*MOD(IABS(I),2))
37408 API=PARU(124-2*MOD(IABS(I),2))
37409 ELSEIF(IA.LE.4) THEN
37410 VPI=PARJ(182-2*MOD(IABS(I),2))
37411 API=PARJ(183-2*MOD(IABS(I),2))
37413 VPI=PARJ(190-2*MOD(IABS(I),2))
37414 API=PARJ(191-2*MOD(IABS(I),2))
37418 VPI=PARU(127-2*MOD(IABS(I),2))
37419 API=PARU(128-2*MOD(IABS(I),2))
37420 ELSEIF(IA.LE.14) THEN
37421 VPI=PARJ(186-2*MOD(IABS(I),2))
37422 API=PARJ(187-2*MOD(IABS(I),2))
37424 VPI=PARJ(194-2*MOD(IABS(I),2))
37425 API=PARJ(195-2*MOD(IABS(I),2))
37429 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
37431 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
37433 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
37438 C...Special case: if only branching ratios known then use them.
37439 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
37442 HI=SHR*WDTP(IA)*FACA/9D0
37443 ELSEIF(IA.LT.20) THEN
37446 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37447 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
37449 C...Normal cross section.
37450 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
37451 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
37452 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
37453 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
37454 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
37455 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
37456 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
37457 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
37461 ELSEIF(ISUB.EQ.142) THEN
37462 C...f + fbar' -> W'+/-
37463 SQMWP=PMAS(34,1)**2
37464 CALL PYWIDT(34,SH,WDTP,WDTE)
37466 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
37467 HP=AEM/(24D0*XW)*SH
37468 DO 120 I=MMIN1,MMAX1
37469 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
37471 DO 110 J=MMIN2,MMAX2
37472 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
37474 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
37475 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37477 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37478 C...Special case: if only branching ratios known then use them.
37479 IF(MWID(34).EQ.2) THEN
37481 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
37482 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
37483 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
37484 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
37485 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
37487 IF(IA.LT.10) HI=HI*FACA/9D0
37489 C...Normal cross section.
37490 HI=HP*(PARU(133)**2+PARU(134)**2)
37491 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
37492 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37498 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37499 SIGH(NCHN)=HI*FACBW*HF
37503 ELSEIF(ISUB.EQ.144) THEN
37506 CALL PYWIDT(41,SH,WDTP,WDTE)
37508 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
37509 HP=AEM/(12D0*XW)*SH
37510 DO 140 I=MMIN1,MMAX1
37511 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
37513 DO 130 J=MMIN2,MMAX2
37514 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
37516 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
37518 IF(IA.LE.10) HI=HI*FACA/3D0
37519 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
37524 SIGH(NCHN)=HI*FACBW*HF
37528 ELSEIF(ISUB.EQ.145) THEN
37529 C...q + l -> LQ (leptoquark)
37530 SQMLQ=PMAS(42,1)**2
37531 CALL PYWIDT(42,SH,WDTP,WDTE)
37533 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
37534 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
37536 KFLQQ=KFDP(MDCY(42,2),1)
37537 KFLQL=KFDP(MDCY(42,2),2)
37538 DO 160 I=MMIN1,MMAX1
37539 IF(KFAC(1,I).EQ.0) GOTO 160
37541 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
37542 DO 150 J=MMIN2,MMAX2
37543 IF(KFAC(2,J).EQ.0) GOTO 150
37545 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
37546 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
37547 IF(JA.EQ.IA) GOTO 150
37548 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
37549 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
37551 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
37556 SIGH(NCHN)=HI*FACBW*HF
37560 ELSEIF(ISUB.EQ.146) THEN
37561 C...e + gamma* -> e* (excited lepton)
37562 KFQSTR=KFPR(ISUB,1)
37563 KCQSTR=PYCOMP(KFQSTR)
37564 KFQEXC=MOD(KFQSTR,KEXCIT)
37565 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37567 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37568 QF=-RTCM(43)/2D0-RTCM(44)/2D0
37569 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
37570 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37573 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
37575 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
37576 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
37578 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37579 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37582 ISIG(NCHN,3-ISDE)=22
37584 SIGH(NCHN)=HI*FACBW*HF
37588 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
37589 C...d + g -> d* and u + g -> u* (excited quarks)
37590 KFQSTR=KFPR(ISUB,1)
37591 KCQSTR=PYCOMP(KFQSTR)
37592 KFQEXC=MOD(KFQSTR,KEXCIT)
37593 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37595 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37596 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
37597 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37600 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
37602 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
37603 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
37605 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37606 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37609 ISIG(NCHN,3-ISDE)=21
37611 SIGH(NCHN)=HI*FACBW*HF
37616 ELSEIF(ISUB.LE.190) THEN
37617 IF(ISUB.EQ.162) THEN
37618 C...q + g -> LQ + lbar; LQ=leptoquark
37619 SQMLQ=PMAS(42,1)**2
37620 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
37621 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
37622 KFLQQ=KFDP(MDCY(42,2),1)
37623 DO 220 I=MMINA,MMAXA
37624 IF(IABS(I).NE.KFLQQ) GOTO 220
37627 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
37628 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
37631 ISIG(NCHN,3-ISDE)=21
37633 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
37637 ELSEIF(ISUB.EQ.163) THEN
37638 C...g + g -> LQ + LQbar; LQ=leptoquark
37639 SQMLQ=PMAS(42,1)**2
37640 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
37641 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
37642 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
37643 & ((TH-SQMLQ)*(UH-SQMLQ)))
37644 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
37648 C...Since don't know proper colour flow, randomize between alternatives
37649 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
37653 ELSEIF(ISUB.EQ.164) THEN
37654 C...q + qbar -> LQ + LQbar; LQ=leptoquark
37655 DELTA=0.25D0*(SQM3-SQM4)**2/SH
37656 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
37659 C SQMLQ=PMAS(42,1)**2
37660 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
37661 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
37662 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
37663 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
37664 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
37665 KFLQQ=KFDP(MDCY(42,2),1)
37666 DO 240 I=MMINA,MMAXA
37667 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37668 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
37674 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
37677 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
37678 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37679 KFQSTR=KFPR(ISUB,2)
37680 KCQSTR=PYCOMP(KFQSTR)
37681 KFQEXC=MOD(KFQSTR,KEXCIT)
37682 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
37683 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37684 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37685 C...Propagators: as simulated in PYOFSH and as desired
37686 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37687 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37688 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37689 GMMQC=SQRT(SQM4)*WDTP(0)
37690 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37691 FACQSA=FACQSA*HBW4C/HBW4
37692 FACQSB=FACQSB*HBW4C/HBW4
37693 C...Branching ratios.
37694 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37695 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37696 DO 260 I=MMIN1,MMAX1
37698 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
37699 DO 250 J=MMIN2,MMAX2
37701 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
37702 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
37707 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37708 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37713 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37714 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37715 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
37720 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37721 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
37722 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
37723 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
37728 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37729 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37734 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37735 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37736 ELSEIF(I.EQ.-J) THEN
37741 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37742 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37747 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37748 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37749 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
37754 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37755 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
37756 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
37761 ELSEIF(ISUB.EQ.169) THEN
37762 C...q + qbar -> e + e* (excited lepton)
37763 KFQSTR=KFPR(ISUB,2)
37764 KCQSTR=PYCOMP(KFQSTR)
37765 KFQEXC=MOD(KFQSTR,KEXCIT)
37766 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37767 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37768 C...Propagators: as simulated in PYOFSH and as desired
37769 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37770 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37771 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37772 GMMQC=SQRT(SQM4)*WDTP(0)
37773 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37774 FACQSB=FACQSB*HBW4C/HBW4
37775 C...Branching ratios.
37776 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37777 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37778 DO 270 I=MMIN1,MMAX1
37780 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
37783 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
37788 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37789 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37794 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37795 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37799 ELSEIF(ISUB.LE.360) THEN
37800 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
37801 C...l + l -> H_L++/-- or H_R++/--.
37803 KFREC=PYCOMP(KFRES)
37804 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37806 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
37807 DO 290 I=MMIN1,MMAX1
37809 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
37811 DO 280 J=MMIN2,MMAX2
37813 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
37815 IF(I*J.LT.0) GOTO 280
37816 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37821 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
37822 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37823 SIGH(NCHN)=HI*FACBW*HF
37827 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
37828 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37830 KFREC=PYCOMP(KFRES)
37831 C...Propagators: as simulated in PYOFSH and as desired
37832 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
37833 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
37834 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37835 GMMC=SQRT(SQM3)*WDTP(0)
37836 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
37837 FHCC=COMFAC*AEM*HBW3C/HBW3
37838 DO 310 I=MMINA,MMAXA
37840 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
37842 J=ISIGN(KFPR(ISUB,2),-I)
37843 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
37844 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
37845 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
37847 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
37848 & (TH-SQM4)*SH)/(TH-SQM4)**2
37849 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
37851 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
37852 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
37853 & ((UH-SQM3)*(TH-SQM4))
37854 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
37855 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
37856 & ((UH-SQM3)*(SH-SQML))
37857 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
37858 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
37859 & ((SH-SQML)*(TH-SQM4))
37860 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
37861 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
37863 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
37864 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
37867 ISIG(NCHN,3-ISDE)=22
37869 SIGH(NCHN)=FHCC*SMM*WIDSC
37873 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
37874 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37876 KFREC=PYCOMP(KFRES)
37877 SQMH=PMAS(KFREC,1)**2
37878 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
37879 C...Propagators: H++/-- as simulated in PYOFSH and as desired
37880 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
37881 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37882 GMMH3=SQRT(SQM3)*WDTP(0)
37883 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
37884 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
37885 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
37886 GMMH4=SQRT(SQM4)*WDTP(0)
37887 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
37888 C...Kinematical and coupling functions
37889 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
37890 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
37891 C...Loop over allowed flavours
37892 DO 320 I=MMINA,MMAXA
37893 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37894 EI=KCHG(IABS(I),1)/3D0
37895 AI=SIGN(1D0,EI+0.1D0)
37898 IF(IABS(I).LE.10) FCOI=FACA/3D0
37899 IF(ISUB.EQ.349) THEN
37900 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
37901 IF(IABS(I).LT.10) THEN
37902 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37903 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37904 & (VI**2+AI**2)*XWHH**2*HBWZ)
37906 IAOFF=181+3*((IABS(I)-11)/2)
37907 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37909 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37910 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37911 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37912 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37913 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37917 IF(IABS(I).LT.10) THEN
37918 DSIGHH=8D0*AEM**2*EI**2/SH2
37920 IAOFF=181+3*((IABS(I)-11)/2)
37921 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37923 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37931 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37934 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37935 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37937 KFREC=PYCOMP(KFRES)
37938 SQMH=PMAS(KFREC,1)**2
37939 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37940 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37941 & PMAS(PYCOMP(9900024),1)**2
37942 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37943 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37944 & (VINT(209)**2-VINT(216)))
37945 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37946 & (VINT(209)**2+2D0*VINT(218)))
37947 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37949 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37950 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37952 DO 340 I=MMIN1,MMAX1
37953 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37954 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37955 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37956 DO 330 J=MMIN2,MMAX2
37957 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37958 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37959 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37961 IF(IABS(KCHH).NE.2) GOTO 330
37962 FACLR=VINT(180+I)*VINT(180+J)
37963 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37964 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37965 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37973 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37977 ELSEIF(ISUB.EQ.353) THEN
37978 C...f + fbar -> Z_R0
37979 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37980 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37982 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37983 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37984 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37985 DO 350 I=MMINA,MMAXA
37986 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37987 IF(IABS(I).LE.8) THEN
37988 EI=KCHG(IABS(I),1)/3D0
37989 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37990 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37995 HI=HP*(VI**2+AI**2)
37996 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38001 SIGH(NCHN)=HI*FACBW*HF
38004 ELSEIF(ISUB.EQ.354) THEN
38005 C...f + fbar' -> W_R+/-
38006 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38007 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38009 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38010 HP=AEM/(24D0*XW)*SH
38011 DO 370 I=MMIN1,MMAX1
38012 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38014 DO 360 J=MMIN2,MMAX2
38015 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38017 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38018 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38020 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38022 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38027 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38028 SIGH(NCHN)=HI*FACBW*HF
38033 ELSEIF(ISUB.LE.400) THEN
38034 IF(ISUB.EQ.391) THEN
38035 C...f + fbar -> G*.
38036 KFGSTR=KFPR(ISUB,1)
38037 KCGSTR=PYCOMP(KFGSTR)
38038 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38040 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38041 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38042 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38043 C...Modify cross section in wings of peak.
38044 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38045 DO 380 I=MMINA,MMAXA
38046 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38048 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38056 ELSEIF(ISUB.EQ.392) THEN
38058 KFGSTR=KFPR(ISUB,1)
38059 KCGSTR=PYCOMP(KFGSTR)
38060 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38062 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38063 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38064 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38065 C...Modify cross section in wings of peak.
38066 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38067 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38075 ELSEIF(ISUB.EQ.393) THEN
38076 C...q + qbar -> g + G*.
38077 KFGSTR=KFPR(ISUB,2)
38078 KCGSTR=PYCOMP(KFGSTR)
38079 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38080 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38081 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38083 C...Propagators: as simulated in PYOFSH and as desired
38084 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38085 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38086 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38087 HS=SQRT(SQM4)*WDTP(0)
38088 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38089 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38090 FACG=FACG*HBW4C/HBW4
38091 DO 400 I=MMINA,MMAXA
38092 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38093 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38101 ELSEIF(ISUB.EQ.394) THEN
38102 C...q + g -> q + G*.
38103 KFGSTR=KFPR(ISUB,2)
38104 KCGSTR=PYCOMP(KFGSTR)
38105 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38106 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38107 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38108 & 2D0*TH2*TH/(UH*SH2))
38109 C...Propagators: as simulated in PYOFSH and as desired
38110 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38111 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38112 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38113 HS=SQRT(SQM4)*WDTP(0)
38114 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38115 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38116 FACG=FACG*HBW4C/HBW4
38117 DO 420 I=MMINA,MMAXA
38118 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38120 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38121 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38124 ISIG(NCHN,3-ISDE)=21
38130 ELSEIF(ISUB.EQ.395) THEN
38131 C...g + g -> g + G*.
38132 KFGSTR=KFPR(ISUB,2)
38133 KCGSTR=PYCOMP(KFGSTR)
38134 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38135 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38136 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38137 C...Propagators: as simulated in PYOFSH and as desired
38138 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38139 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38140 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38141 HS=SQRT(SQM4)*WDTP(0)
38142 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38143 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38144 FACG=FACG*HBW4C/HBW4
38145 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38158 C*********************************************************************
38161 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38162 C...parton distributions according to a few different parametrizations.
38163 C...Note that what is coded is x times the probability distribution,
38164 C...i.e. xq(x,Q2) etc.
38166 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38168 C...Double precision and integer declarations.
38169 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38170 IMPLICIT INTEGER(I-N)
38171 INTEGER PYK,PYCHGE,PYCOMP
38173 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38175 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38176 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38177 COMMON/PYINT1/MINT(400),VINT(400)
38178 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38180 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38181 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38182 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38183 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38184 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38187 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38188 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38191 C...Interface to PDFLIB.
38192 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38194 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38195 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38196 CHARACTER*20 PARM(20)
38197 DATA VALUE/20*0D0/,PARM/20*' '/
38199 C...Data related to Schuler-Sjostrand photon distributions.
38200 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38202 C...Valence PDF momentum integral parametrizations PER PARTON!
38203 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38204 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38205 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38206 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38208 C...Reset parton distributions.
38217 C...Check x and particle species.
38218 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38219 WRITE(MSTU(11),5000) X
38223 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38224 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38225 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38226 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38227 &KFA.NE.310.AND.KFA.NE.130) THEN
38228 WRITE(MSTU(11),5100) KF
38232 C...Electron (or muon or tau) parton distribution call.
38233 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38234 CALL PYPDEL(KFA,X,Q2,XPEL)
38239 C...Photon parton distribution call (VDM+anomalous).
38240 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38241 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38242 CALL PYPDGA(X,Q2,XPGA)
38246 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38249 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38250 XPVAL(4)=MIN(XPQ(4),XPVU)
38251 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38257 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38260 IF(MSTP(55).GE.7) P2MX=4.0D0
38261 IF(MSTP(57).EQ.0) Q2MX=P2MX
38263 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38264 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38267 XPVAL(KFL)=VXPDGM(KFL)
38270 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38273 IF(MSTP(55).GE.11) P2MX=4.0D0
38274 IF(MSTP(57).EQ.0) Q2MX=P2MX
38276 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38277 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38279 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38280 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38283 ELSEIF(MSTP(56).EQ.2) THEN
38284 C...Call PDFLIB parton distributions.
38288 VALUE(2)=MSTP(55)/1000
38290 VALUE(3)=MOD(MSTP(55),1000)
38291 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38292 CALL PDFSET_ALICE(PARM,VALUE)
38293 MINT(93)=3000000+MSTP(55)
38296 QQ2=MAX(0D0,Q2MIN,Q2)
38297 IF(MSTP(57).EQ.0) QQ2=Q2MIN
38299 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38301 IF(MSTP(55).EQ.5004) THEN
38302 IF(5D0*P2.LT.QQ2.AND.
38303 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
38304 & P2.GE.0D0.AND.P2.LT.10D0.AND.
38305 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
38306 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38321 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38349 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38352 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38353 XPVAL(4)=MIN(XPQ(4),XPVU)
38354 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38361 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
38364 C...Pion/gammaVDM parton distribution call.
38365 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
38366 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38367 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
38368 & MSTP(55).LE.12) THEN
38369 ISET=1+MOD(MSTP(55)-1,4)
38372 IF(ISET.GE.3) P2MX=4.0D0
38373 IF(MSTP(57).EQ.0) Q2MX=P2MX
38375 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38376 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38378 XPQ(KFL)=XPVMD(KFL)
38379 XPVAL(KFL)=VXPVMD(KFL)
38382 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
38383 CALL PYPDPI(X,Q2,XPPI)
38387 XPVAL(2)=XPQ(2)-XPQ(-2)
38388 XPVAL(-1)=XPQ(-1)-XPQ(1)
38389 ELSEIF(MSTP(54).EQ.2) THEN
38390 C...Call PDFLIB parton distributions.
38394 VALUE(2)=MSTP(53)/1000
38396 VALUE(3)=MOD(MSTP(53),1000)
38397 IF(MINT(93).NE.2000000+MSTP(53)) THEN
38398 CALL PDFSET_ALICE(PARM,VALUE)
38399 MINT(93)=2000000+MSTP(53)
38402 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38403 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38405 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38423 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
38426 C...Anomalous photon parton distribution call.
38427 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
38430 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
38431 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
38432 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
38433 IF(MSTP(57).EQ.0) Q2MX=P2MX
38435 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38436 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38438 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
38439 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
38442 ELSEIF(MSTP(56).EQ.1) THEN
38443 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
38444 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
38445 IF(MSTP(57).EQ.0) Q2MX=P2MX
38447 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38448 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38450 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38451 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38454 ELSEIF(MSTP(56).EQ.2) THEN
38455 IF(MSTP(57).EQ.0) Q2MX=P2MX
38456 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
38459 XPVAL(KFL)=VXPGA(KFL)
38462 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
38463 IF(MSTP(57).EQ.0) Q2MX=P2MX
38464 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38467 XPVAL(KFL)=VXPGA(KFL)
38471 220 RKF=11D0*PYR(0)
38473 IF(RKF.GT.1D0) KFR=2
38474 IF(RKF.GT.5D0) KFR=3
38475 IF(RKF.GT.6D0) KFR=4
38476 IF(RKF.GT.10D0) KFR=5
38477 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
38478 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
38479 IF(MSTP(57).EQ.0) Q2MX=P2MX
38480 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38483 XPVAL(KFL)=VXPGA(KFL)
38488 C...Proton parton distribution call.
38490 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
38491 CALL PYPDPR(X,Q2,XPPR)
38495 C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38496 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
38497 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
38498 ELSEIF(MSTP(52).EQ.2) THEN
38499 C...Call PDFLIB parton distributions.
38503 VALUE(2)=MSTP(51)/1000
38505 VALUE(3)=MOD(MSTP(51),1000)
38506 IF(MINT(93).NE.1000000+MSTP(51)) THEN
38507 CALL PDFSET_ALICE(PARM,VALUE)
38508 MINT(93)=1000000+MSTP(51)
38511 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38512 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38513 CALL STRUCTM_ALICE(
38514 & XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38532 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
38536 C...Isospin average for pi0/gammaVDM.
38537 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38538 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
38543 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38544 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38548 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
38549 & XPVAL(3)+XPVAL(4)+XPVAL(5)
38553 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
38554 XPQ(1)=XPQ(1)+0.2D0*XPV
38555 XPQ(2)=XPQ(2)+0.8D0*XPV
38556 XPVAL(1)=0.2D0*XPVL
38557 XPVAL(2)=0.8D0*XPVL
38558 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
38561 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
38564 IF(MSTP(55).GE.9) THEN
38570 XPQ(1)=XPQ(1)+0.5D0*XPV
38571 XPQ(2)=XPQ(2)+0.5D0*XPV
38572 XPVAL(1)=0.5D0*XPVL
38573 XPVAL(2)=0.5D0*XPVL
38577 XPVAL(-KFL)=XPVAL(KFL)
38580 C...Rescale for gammaVDM by effective gamma -> rho coupling.
38581 C+++Do not rescale?
38582 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
38583 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
38585 XPQ(KFL)=VINT(281)*XPQ(KFL)
38586 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
38588 VINT(232)=VINT(281)*XPV
38591 C...Simple recipes for kaons.
38592 ELSEIF(KFA.EQ.321) THEN
38593 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
38595 XPVAL(-3)=XPVAL(-1)
38597 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
38598 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38599 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38602 XPQ(1)=XPQ(1)+0.5D0*XPV
38603 XPQ(-1)=XPQ(-1)+0.5D0*XPV
38604 XPQ(3)=XPQ(3)+0.5D0*XPV
38605 XPQ(-3)=XPQ(-3)+0.5D0*XPV
38606 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
38610 XPVAL(-1)=0.5D0*XPV
38612 XPVAL(-3)=0.5D0*XPV
38614 C...Isospin conjugation for neutron.
38615 ELSEIF(KFA.EQ.2112) THEN
38626 C...Simple recipes for hyperon (average valence parton distribution).
38627 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
38628 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
38629 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
38630 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
38635 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
38636 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
38637 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
38638 XPV=(XPVAL(1)+XPVAL(2))/3D0
38641 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
38642 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
38643 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
38646 C...Charge conjugation for antiparticle.
38649 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
38656 XPVAL(KFL)=XPVAL(-KFL)
38661 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38664 C...Only reshape PDFs for the non-first interactions;
38665 C...But need valence/sea separation already from first interaction.
38666 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
38667 KFVSEL=KFIVAL(JS,1)
38668 C...If valence quark kicked out of pi0 or gamma then that decides
38669 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38670 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
38673 XPVL=XPVL+XPVAL(KFL)
38674 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
38677 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
38678 XPVAL(IABS(KFVSEL))=XPVL
38681 XPVAL(-KFL)=XPVAL(KFL)
38684 C...If valence quark kicked out of K0S or K0S then that decides whether
38685 C...we should consider state as d sbar or s dbar.
38686 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
38688 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
38689 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38690 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38691 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38694 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38695 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38696 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38700 C...XPQ distributions are nominal for a (signed) beam particle
38701 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38709 IF(IFL.EQ.0) GOTO 350
38711 C...Count up number of original IFL valence quarks.
38713 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
38714 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
38715 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
38716 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38717 C...bookkeep as if d dbar (for total momentum sum in valence sector).
38718 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
38719 C...Count down number of remaining IFL valence quarks. Skip current
38720 C...interaction initiator.
38722 DO 330 I1=1,NMI(JS)
38723 IF (I1.EQ.MINT(36)) GOTO 330
38724 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
38728 C...Separate out original VALENCE and SEA content.
38730 SEA=MAX(0D0,XPQ(IFL)-VAL)
38734 C...Rescale valence content if changed.
38735 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
38736 & (VAL*IVREM)/IVORG
38738 C...Momentum integrals of original and removed valence quarks.
38739 IF(IVORG.NE.0) THEN
38740 C...For p/n/pbar/nbar beams can split into d_val and u_val.
38741 C...Isospin conjugation for neutrons
38742 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
38744 IF (KFA.EQ.2112) IAFLP=3-IAFLP
38745 VPAVG=PAVG(IAFLP,Q2)
38746 C...For other baryons average d_val and u_val, like for PDFs.
38747 ELSEIF(KFA.GT.1000) THEN
38748 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
38749 C...For mesons and photon average d_val and u_val and scale by 3/2.
38750 C...Very crude, especially for photon.
38752 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
38754 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
38755 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
38758 C...Now add companions (at X with partner having been at Z=XASSOC).
38759 C...NOTE: due to the assumed simple x scaling, the partner was at what
38760 C...corresponds to a higher Z than XASSOC, if there were intermediate
38761 C...scatterings. Nothing done about that for the moment.
38762 DO 340 IVC=1,NVC(JS,IFL)
38763 C...Skip companions that have been kicked out
38764 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
38768 C...Momentum fraction of the partner quark.
38769 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38770 XS=XASSOC(JS,IFL,IVC)
38773 C...Momentum fraction of the companion quark.
38774 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38776 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
38777 C...Add to momentum sum, with rescaling compensation factor.
38778 XCFAC=(XREM+XS)/XREM*CMPFAC
38779 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
38784 C...Wait until all flavours treated, then rescale seas and gluon.
38787 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
38788 IF (RSFAC.LE.0D0) THEN
38789 C...First calculate factor needed to exactly restore pz cons.
38790 IF (NRESC.EQ.1) CMPFAC =
38791 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
38792 C...Add a bit of headroom
38794 C...Try a few times if more headroom is needed, then print error message.
38795 IF (NRESC.LE.10) GOTO 345
38797 & '(PYPDFU:) Negative reshaping factor persists!')
38798 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
38802 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
38803 C...Also store resulting distributions in XPQ
38805 DO 360 ISVC=-1,NVC(JS,IFL)
38806 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
38809 C...Save companion reweighting factor for PYPTIS.
38814 C...Allow gluon also in position 21.
38817 C...Check positivity and reset above maximum allowed flavour.
38819 XPQ(KFL)=MAX(0D0,XPQ(KFL))
38820 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
38823 C...Formats for error printouts.
38824 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38825 5100 FORMAT(' Error: illegal particle code for parton distribution;',
38827 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38829 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
38830 & ' Removed valence momentum fraction : ',F6.3/
38831 & ' Added companion momentum fraction : ',F6.3/
38832 & ' Resulting rescale factor : ',F6.3)
38834 C...Reset side pointer and return
38840 C*********************************************************************
38843 C...Gives proton parton distribution at small x and/or Q^2 according to
38844 C...correct limiting behaviour.
38846 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
38848 C...Double precision and integer declarations.
38849 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38850 IMPLICIT INTEGER(I-N)
38851 INTEGER PYK,PYCHGE,PYCOMP
38853 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38854 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38855 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38856 COMMON/PYINT1/MINT(400),VINT(400)
38857 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38859 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
38860 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
38862 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38866 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
38867 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
38868 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
38870 CALL PYPDFU(KF,X,Q2,XPQ)
38874 C...Reset. Check x.
38878 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38879 WRITE(MSTU(11),5000) X
38883 C...Define valence content.
38887 IF(KF.EQ.2212) THEN
38890 ELSEIF(KF.EQ.-2212) THEN
38893 ELSEIF(KF.EQ.2112) THEN
38896 ELSEIF(KF.EQ.-2112) THEN
38899 ELSEIF(KF.EQ.211) THEN
38903 ELSEIF(KF.EQ.-211) THEN
38907 ELSEIF(MINT(105).LE.223) THEN
38912 ELSEIF(MINT(105).EQ.333) THEN
38917 ELSEIF(MINT(105).EQ.443) THEN
38924 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38926 CALL PYPDFU(KFC,X,Q2,XPA)
38927 Q2MN=MAX(3D0,VINT(231))
38928 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38929 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38931 C...Large Q2 and large x: naive call is enough.
38932 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38938 C...Small Q2 and large x: dampen boundary value.
38939 ELSEIF(X.GT.XMN) THEN
38941 C...Evaluate at boundary and define dampening factors.
38943 CALL PYPDFU(KFC,X,Q2MN,XPA)
38944 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38945 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38947 C...Separate valence and sea parts of parton distribution.
38949 XFV1=XPA(KFV1)-XPA(-KFV1)
38950 XPA(KFV1)=XPA(-KFV1)
38951 XFV2=XPA(KFV2)-XPA(-KFV2)
38952 XPA(KFV2)=XPA(-KFV2)
38954 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38955 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38956 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38957 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38960 C...Dampen valence and sea separately. Put back together.
38962 XPQ(KFL)=FS*XPA(KFL)
38965 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38966 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38968 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38969 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38970 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38971 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38975 C...Large Q2 and small x: interpolate behaviour.
38976 ELSEIF(Q2.GT.Q2MN) THEN
38978 C...Evaluate at extremes and define coefficients for interpolation.
38980 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38983 CALL PYPDFU(KFC,X,Q2B,XPB)
38985 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38986 FVA=(X/XMN)**0.45D0*FLA
38987 FSA=(X/XMN)**(-0.08D0)*FLA
38990 C...Separate valence and sea parts of parton distribution.
38992 XFVA1=XPA(KFV1)-XPA(-KFV1)
38993 XPA(KFV1)=XPA(-KFV1)
38994 XFVA2=XPA(KFV2)-XPA(-KFV2)
38995 XPA(KFV2)=XPA(-KFV2)
38996 XFVB1=XPB(KFV1)-XPB(-KFV1)
38997 XPB(KFV1)=XPB(-KFV1)
38998 XFVB2=XPB(KFV2)-XPB(-KFV2)
38999 XPB(KFV2)=XPB(-KFV2)
39001 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
39002 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
39003 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
39004 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
39005 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
39006 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39007 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39008 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39011 C...Interpolate for valence and sea. Put back together.
39013 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39016 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39017 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39019 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39020 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39021 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39022 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39026 C...Small Q2 and small x: dampen boundary value and add term.
39029 C...Evaluate at boundary and define dampening factors.
39031 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39032 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39034 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39035 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39036 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39037 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39038 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39039 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39041 C...Separate valence and sea parts of parton distribution.
39043 XFV1=XPA(KFV1)-XPA(-KFV1)
39044 XPA(KFV1)=XPA(-KFV1)
39045 XFV2=XPA(KFV2)-XPA(-KFV2)
39046 XPA(KFV2)=XPA(-KFV2)
39048 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39049 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39050 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39051 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39054 C...Dampen valence and sea separately. Add constant terms.
39055 C...Put back together.
39057 XPQ(KFL)=FSA*XPA(KFL)
39061 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39063 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39064 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39067 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39069 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39070 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39071 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39072 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39078 C...Format for error printout.
39079 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39084 C*********************************************************************
39087 C...Gives electron (or muon, or tau) parton distribution.
39089 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39091 C...Double precision and integer declarations.
39092 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39093 IMPLICIT INTEGER(I-N)
39094 INTEGER PYK,PYCHGE,PYCOMP
39096 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39097 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39098 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39099 COMMON/PYINT1/MINT(400),VINT(400)
39100 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39102 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39104 C...Interface to PDFLIB.
39105 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39107 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39108 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39109 CHARACTER*20 PARM(20)
39110 DATA VALUE/20*0D0/,PARM/20*' '/
39112 C...Some common constants.
39118 IF(KFA.EQ.13) PME=PMAS(13,1)
39119 IF(KFA.EQ.15) PME=PMAS(15,1)
39120 XL=LOG(MAX(1D-10,X))
39121 X1L=LOG(MAX(1D-10,1D0-X))
39122 HLE=LOG(MAX(3D0,Q2/PME**2))
39123 HBE2=(AEM/PARU(1))*(HLE-1D0)
39125 C...Electron inside electron, see R. Kleiss et al., in Z physics at
39126 C...LEP 1, CERN 89-08, p. 34
39127 IF(MSTP(59).LE.1) THEN
39128 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39129 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39130 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39131 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39132 & 4D0*XL/(1D0-X)-5D0-X)
39134 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39135 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39136 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39138 C...Zero distribution for very large x and rescale it for intermediate.
39139 IF(X.GT.1D0-1D-10) THEN
39141 ELSEIF(X.GT.1D0-1D-7) THEN
39142 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39146 C...Photon and (transverse) W- inside electron.
39147 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39148 IF(MSTP(13).LE.1) THEN
39151 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39153 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39154 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39155 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39157 C...Electron or positron inside photon inside electron.
39158 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39159 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39160 & 2D0*X*(1D0+X)*XL)
39161 XPEL(11)=XPEL(11)+XFSEA
39164 C...Initialize PDFLIB photon parton distributions.
39165 IF(MSTP(56).EQ.2) THEN
39169 VALUE(2)=MSTP(55)/1000
39171 VALUE(3)=MOD(MSTP(55),1000)
39172 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39173 CALL PDFSET_ALICE(PARM,VALUE)
39174 MINT(93)=3000000+MSTP(55)
39178 C...Quarks and gluons inside photon inside electron:
39179 C...numerical convolution required.
39188 IF(ITER.EQ.0) NSTP=2
39190 SXP(KFL)=0.5D0*SXP(KFL)
39193 IF(ITER.EQ.0) WTSTP=0.5D0
39194 C...Pick grid of x_{gamma} values logarithmically even.
39199 XLE=XL*(ISTP-0.5D0)/NSTP
39201 XE=MIN(1D0-1D-10,EXP(XLE))
39202 XG=MIN(1D0-1D-10,X/XE)
39203 C...Evaluate photon inside electron parton distribution for convolution.
39204 XPGP=1D0+(1D0-XE)**2
39205 IF(MSTP(13).LE.1) THEN
39208 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39210 C...Evaluate photon parton distributions for convolution.
39211 IF(MSTP(56).EQ.1) THEN
39212 IF(MSTP(55).EQ.1) THEN
39213 CALL PYPDGA(XG,Q2,XPGA)
39214 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39217 IF(MSTP(55).GE.7) 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)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39223 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39226 IF(MSTP(55).GE.11) P2MX=4.0D0
39227 IF(MSTP(57).EQ.0) Q2MX=P2MX
39229 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39230 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39234 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39236 ELSEIF(MSTP(56).EQ.2) THEN
39237 C...Call PDFLIB parton distributions.
39239 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39240 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39242 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39243 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39244 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39245 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39246 SXP(3)=SXP(3)+WTSTP*XPGP*STR
39247 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
39248 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
39249 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
39252 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
39253 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
39254 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
39256 C...Put convolution into output arrays.
39258 XPEL(0)=FCONV*SXP(0)
39260 XPEL(KFL)=FCONV*SXP(KFL)
39261 XPEL(-KFL)=XPEL(KFL)
39268 C*********************************************************************
39271 C...Gives photon parton distribution.
39273 SUBROUTINE PYPDGA(X,Q2,XPGA)
39275 C...Double precision and integer declarations.
39276 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39277 IMPLICIT INTEGER(I-N)
39278 INTEGER PYK,PYCHGE,PYCOMP
39280 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39281 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39282 COMMON/PYINT1/MINT(400),VINT(400)
39283 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39285 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
39286 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
39287 &DGCS(4,3),DGDS(4,3),DGES(4,3)
39289 C...The following data lines are coefficients needed in the
39290 C...Drees and Grassie photon parton distribution parametrization.
39291 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
39292 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
39293 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
39294 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
39295 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
39296 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
39297 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
39298 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
39299 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
39300 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
39301 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
39302 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
39303 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
39304 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
39305 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
39306 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
39307 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
39308 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
39309 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
39310 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
39311 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
39312 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
39313 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
39314 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
39315 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
39316 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
39318 C...Photon parton distribution from Drees and Grassie.
39319 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39324 IF(MSTP(57).LE.0) THEN
39327 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
39331 IF(Q2.GT.25D0) NF=4
39332 IF(Q2.GT.300D0) NF=5
39336 C...Evaluate gluon content.
39337 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
39338 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
39339 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
39340 XPGL=DGA*X**DGB*X1**DGC
39342 C...Evaluate up- and down-type quark content.
39343 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
39344 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
39345 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
39346 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
39347 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
39348 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39349 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
39350 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
39351 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
39352 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
39353 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
39355 IF(NF.EQ.4) DGF=10D0
39356 IF(NF.EQ.5) DGF=55D0/6D0
39357 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39359 XPQU=(XPQS+9D0*XPQN)/6D0
39360 XPQD=(XPQS-4.5D0*XPQN)/6D0
39361 ELSEIF(NF.EQ.4) THEN
39362 XPQU=(XPQS+6D0*XPQN)/8D0
39363 XPQD=(XPQS-6D0*XPQN)/8D0
39365 XPQU=(XPQS+7.5D0*XPQN)/10D0
39366 XPQD=(XPQS-5D0*XPQN)/10D0
39369 C...Put into output arrays.
39374 IF(NF.GE.4) XPGA(4)=AEM*XPQU
39375 IF(NF.GE.5) XPGA(5)=AEM*XPQD
39377 XPGA(-KFL)=XPGA(KFL)
39383 C*********************************************************************
39386 C...Constructs the F2 and parton distributions of the photon
39387 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39388 C...For F2, c and b are included by the Bethe-Heitler formula;
39389 C...in the 'MSbar' scheme additionally a Cgamma term is added.
39390 C...Contains the SaS sets 1D, 1M, 2D and 2M.
39391 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39393 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39395 C...Double precision and integer declarations.
39396 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39397 IMPLICIT INTEGER(I-N)
39398 INTEGER PYK,PYCHGE,PYCOMP
39400 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
39402 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
39403 SAVE /PYINT8/,/PYINT9/
39405 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
39406 C...Charm and bottom masses (low to compensate for J/psi etc.).
39407 DATA PMC/1.3D0/, PMB/4.6D0/
39408 C...alpha_em and alpha_em/(2*pi).
39409 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
39410 C...Lambda value for 4 flavours.
39412 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39414 C...VMD couplings f_V**2/(4*pi).
39415 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
39416 C...Masses for rho (=omega) and phi.
39417 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
39418 C...Number of points in integration for IP2=1.
39436 C...Set Q0 cut-off parameter as function of set used.
39444 C...Scale choice for off-shell photon; common factors.
39449 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39450 FACNOR=LOG(Q2/Q02)/NSTEP
39451 ELSEIF(IP2.EQ.2) THEN
39453 ELSEIF(IP2.EQ.3) THEN
39455 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39456 ELSEIF(IP2.EQ.4) THEN
39457 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39458 & ((Q2+P2)*(Q02+P2)))
39459 ELSEIF(IP2.EQ.5) THEN
39460 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39461 & ((Q2+P2)*(Q02+P2)))
39462 P2MX=Q0*SQRT(P2MXA)
39463 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
39464 ELSEIF(IP2.EQ.6) THEN
39465 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39466 & ((Q2+P2)*(Q02+P2)))
39467 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39469 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39470 & ((Q2+P2)*(Q02+P2)))
39471 P2MX=Q0*SQRT(P2MXA)
39473 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39474 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
39475 IF(ABS(Q2-Q02).GT.1D-6) THEN
39476 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
39477 ELSEIF(P2.LT.Q02) THEN
39478 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
39484 C...Call VMD parametrization for d quark and use to give rho, omega,
39485 C...phi. Note dipole dampening for off-shell photon.
39486 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39490 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
39491 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
39493 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
39495 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
39496 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
39497 XPVMD(3)=XPVMD(3)+FACS*XFVAL
39498 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
39499 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
39500 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
39501 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
39502 VXPVMD(2)=FRACU*FACUD*XFVAL
39503 VXPVMD(3)=FACS*XFVAL
39504 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
39505 VXPVMD(-2)=FRACU*FACUD*XFVAL
39506 VXPVMD(-3)=FACS*XFVAL
39509 C...Anomalous parametrizations for different strategies
39510 C...for off-shell photons; except full integration.
39512 C...Call anomalous parametrization for d + u + s.
39513 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39515 XPANL(KFL)=FACNOR*XPGA(KFL)
39516 VXPANL(KFL)=FACNOR*VXPGA(KFL)
39519 C...Call anomalous parametrization for c and b.
39520 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39522 XPANH(KFL)=FACNOR*XPGA(KFL)
39523 VXPANH(KFL)=FACNOR*VXPGA(KFL)
39525 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39527 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
39528 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
39532 C...Special option: loop over flavours and integrate over k2.
39534 DO 160 ISTEP=1,NSTEP
39535 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
39536 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
39537 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
39538 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
39539 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
39540 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
39541 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
39543 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
39544 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
39545 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
39546 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
39552 C...Call Bethe-Heitler term expression for charm and bottom.
39553 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
39556 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
39560 C...For MSbar subtraction call C^gamma term expression for d, u, s.
39561 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
39562 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
39564 XPDIR(KFL)=XPGA(KFL)
39568 C...Store result in output array.
39571 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
39572 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39573 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
39574 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
39575 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
39581 C*********************************************************************
39584 C...Evaluates the VMD parton distributions of a photon,
39585 C...evolved homogeneously from an initial scale P2 to Q2.
39586 C...Does not include dipole suppression factor.
39587 C...ISET is parton distribution set, see above;
39588 C...additionally ISET=0 is used for the evolution of an anomalous photon
39589 C...which branched at a scale P2 and then evolved homogeneously to Q2.
39590 C...ALAM is the 4-flavour Lambda, which is automatically converted
39591 C...to 3- and 5-flavour equivalents as needed.
39592 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39594 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39596 C...Double precision and integer declarations.
39597 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39598 IMPLICIT INTEGER(I-N)
39599 INTEGER PYK,PYCHGE,PYCOMP
39600 C...Local arrays and data.
39601 DIMENSION XPGA(-6:6), VXPGA(-6:6)
39602 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39611 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39612 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
39613 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
39614 P2EFF=MAX(P2,1.2D0*ALAM3**2)
39615 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39616 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39617 Q2EFF=MAX(Q2,P2EFF)
39619 C...Find number of flavours at lower and upper scale.
39621 IF(P2EFF.LT.PMC**2) NFP=3
39622 IF(P2EFF.GT.PMB**2) NFP=5
39624 IF(Q2EFF.LT.PMC**2) NFQ=3
39625 IF(Q2EFF.GT.PMB**2) NFQ=5
39627 C...Find s as sum of 3-, 4- and 5-flavour parts.
39631 IF(NFQ.EQ.3) Q2DIV=Q2EFF
39632 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
39634 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
39636 IF(NFP.EQ.3) P2DIV=PMC**2
39638 IF(NFQ.EQ.5) Q2DIV=PMB**2
39639 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
39643 IF(NFP.EQ.5) P2DIV=P2EFF
39644 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
39647 C...Calculate frequent combinations of x and s.
39654 C...Evaluate homogeneous anomalous parton distributions below or
39655 C...above threshold.
39657 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39658 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39659 XVAL = X * 1.5D0 * (X**2+X1**2)
39663 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
39664 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
39665 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
39666 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
39667 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
39668 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
39669 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
39670 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
39671 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
39672 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
39673 & (2D0*X-1D0)*X*XL**2)
39676 C...Evaluate set 1D parton distributions below or above threshold.
39677 ELSEIF(ISET.EQ.1) THEN
39678 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39679 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39680 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
39681 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
39682 XSEA = 0.100D0 * X1**3.76D0
39684 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
39685 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
39686 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
39687 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
39688 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
39689 & X**0.40D0 * X1**(1.76D0+3D0*S)
39690 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
39691 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
39692 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
39693 XSEA0 = 0.100D0 * X1**3.76D0
39696 C...Evaluate set 1M parton distributions below or above threshold.
39697 ELSEIF(ISET.EQ.2) THEN
39698 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39699 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39700 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
39701 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
39704 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
39705 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
39706 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
39707 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
39708 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
39709 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
39710 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
39711 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
39716 C...Evaluate set 2D parton distributions below or above threshold.
39717 ELSEIF(ISET.EQ.3) THEN
39718 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39719 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39720 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
39721 XGLU = 1.925D0 * X1**2
39722 XSEA = 0.242D0 * X1**4
39724 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
39725 & X**(0.46D0+0.25D0*S) *
39726 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
39727 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
39728 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
39729 & EXP(-18.67D0*S) *
39730 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
39731 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
39732 & XL**(9.3D0*S/(1D0+1.7D0*S))
39733 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
39734 & (1D0-0.607D0*S+21.95D0*S2) *
39735 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
39736 XSEA0 = 0.242D0 * X1**4
39739 C...Evaluate set 2M parton distributions below or above threshold.
39740 ELSEIF(ISET.EQ.4) THEN
39741 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39742 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39743 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
39744 XGLU = 1.808D0 * X1**2
39745 XSEA = 0.209D0 * X1**4
39747 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
39748 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
39749 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
39750 & XL**(5.15D0*S/(1D0+2D0*S)) +
39751 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
39752 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
39753 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
39754 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
39755 & XL**(10.9D0*S/(1D0+2.5D0*S))
39756 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
39757 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
39758 & X1**(4D0+S) * XL**(0.45D0*S)
39759 XSEA0 = 0.209D0 * X1**4
39763 C...Threshold factors for c and b sea.
39764 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39766 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39767 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39769 XCHM=XSEA*(1D0-(SCH/SLL)**2)
39771 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
39775 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39776 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39778 XBOT=XSEA*(1D0-(SBT/SLL)**2)
39780 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
39784 C...Fill parton distributions.
39791 XPGA(KFA)=XPGA(KFA)+XVAL
39793 XPGA(-KFL)=XPGA(KFL)
39801 C*********************************************************************
39804 C...Evaluates the parton distributions of the anomalous photon,
39805 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39806 C...KF=0 gives the sum over (up to) 5 flavours,
39807 C...KF<0 limits to flavours up to abs(KF),
39808 C...KF>0 is for flavour KF only.
39809 C...ALAM is the 4-flavour Lambda, which is automatically converted
39810 C...to 3- and 5-flavour equivalents as needed.
39811 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39813 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39815 C...Double precision and integer declarations.
39816 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39817 IMPLICIT INTEGER(I-N)
39818 INTEGER PYK,PYCHGE,PYCOMP
39819 C...Local arrays and data.
39820 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
39821 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39828 IF(Q2.LE.P2) RETURN
39831 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39832 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
39834 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
39835 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
39836 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39837 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39838 Q2EFF=MAX(Q2,P2EFF)
39841 C...Find number of flavours at lower and upper scale.
39843 IF(P2EFF.LT.PMC**2) NFP=3
39844 IF(P2EFF.GT.PMB**2) NFP=5
39846 IF(Q2EFF.LT.PMC**2) NFQ=3
39847 IF(Q2EFF.GT.PMB**2) NFQ=5
39849 C...Define range of flavour loop.
39853 ELSEIF(KF.LT.0) THEN
39861 C...Loop over flavours the photon can branch into.
39862 DO 110 KFL=KFLMN,KFLMX
39864 C...Light flavours: calculate t range and (approximate) s range.
39865 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
39866 TDIFF=LOG(Q2EFF/P2EFF)
39867 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39868 & LOG(P2EFF/ALAMSQ(NFQ)))
39869 IF(NFQ.GT.NFP) THEN
39871 IF(NFQ.EQ.4) Q2DIV=PMC**2
39872 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39873 & LOG(P2EFF/ALAMSQ(NFQ)))
39874 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39875 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39876 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39878 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
39880 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
39881 & LOG(P2EFF/ALAMSQ(4)))
39882 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
39883 & LOG(P2EFF/ALAMSQ(3)))
39884 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
39887 C...u and s quark do not need a separate treatment when d has been done.
39888 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
39890 C...Charm: as above, but only include range above c threshold.
39891 ELSEIF(KFL.EQ.4) THEN
39892 IF(Q2.LE.PMC**2) GOTO 110
39893 P2EFF=MAX(P2EFF,PMC**2)
39894 Q2EFF=MAX(Q2EFF,P2EFF)
39895 TDIFF=LOG(Q2EFF/P2EFF)
39896 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39897 & LOG(P2EFF/ALAMSQ(NFQ)))
39898 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
39900 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39901 & LOG(P2EFF/ALAMSQ(NFQ)))
39902 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39903 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39904 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39907 C...Bottom: as above, but only include range above b threshold.
39908 ELSEIF(KFL.EQ.5) THEN
39909 IF(Q2.LE.PMB**2) GOTO 110
39910 P2EFF=MAX(P2EFF,PMB**2)
39911 Q2EFF=MAX(Q2,P2EFF)
39912 TDIFF=LOG(Q2EFF/P2EFF)
39913 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39914 & LOG(P2EFF/ALAMSQ(NFQ)))
39917 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39919 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39920 FAC=AEM2PI*2D0*CHSQ*TDIFF
39922 C...Evaluate parton distributions (normalized to unit momentum sum).
39923 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39924 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39925 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39926 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39927 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39928 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39929 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39930 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39931 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39932 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39933 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39934 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39936 C...Threshold factors for c and b sea.
39937 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39939 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39940 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39941 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39944 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39945 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39946 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39950 C...Add contribution of each valence flavour.
39951 XPGA(0)=XPGA(0)+FAC*XGLU
39952 XPGA(1)=XPGA(1)+FAC*XSEA
39953 XPGA(2)=XPGA(2)+FAC*XSEA
39954 XPGA(3)=XPGA(3)+FAC*XSEA
39955 XPGA(4)=XPGA(4)+FAC*XCHM
39956 XPGA(5)=XPGA(5)+FAC*XBOT
39957 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39958 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39961 XPGA(-KFL)=XPGA(KFL)
39962 VXPGA(-KFL)=VXPGA(KFL)
39969 C*********************************************************************
39972 C...Evaluates the Bethe-Heitler cross section for heavy flavour
39974 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39976 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39978 C...Double precision and integer declarations.
39979 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39980 IMPLICIT INTEGER(I-N)
39981 INTEGER PYK,PYCHGE,PYCOMP
39984 DATA AEM2PI/0.0011614D0/
39990 C...Check kinematics limits.
39991 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39993 BETA2=1D0-4D0*PM2/W2
39994 IF(BETA2.LT.1D-10) RETURN
39998 C...Simple case: P2 = 0.
39999 IF(P2.LT.1D-4) THEN
40000 IF(BETA.LT.0.99D0) THEN
40001 XBL=LOG((1D0+BETA)/(1D0-BETA))
40003 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
40005 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
40006 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40008 C...Complicated case: P2 > 0, based on approximation of
40009 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40011 RPQ=1D0-4D0*X**2*P2/Q2
40012 IF(RPQ.GT.1D-10) THEN
40013 RPBE=SQRT(RPQ*BETA2)
40014 IF(RPBE.LT.0.99D0) THEN
40015 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40016 XBI=2D0*RPBE/(1D0-RPBE**2)
40018 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40019 XBL=LOG((1D0+RPBE)**2/RPBESN)
40020 XBI=2D0*RPBE/RPBESN
40022 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40023 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40024 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40028 C...Multiply by charge-squared etc. to get parton distribution.
40030 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40031 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40036 C*********************************************************************
40039 C...Evaluates the direct contribution, i.e. the C^gamma term,
40040 C...as needed in MSbar parametrizations.
40041 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40043 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40045 C...Double precision and integer declarations.
40046 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40047 IMPLICIT INTEGER(I-N)
40048 INTEGER PYK,PYCHGE,PYCOMP
40049 C...Local array and data.
40050 DIMENSION XPGA(-6:6)
40051 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40058 C...Evaluate common x-dependent expression.
40059 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40060 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40062 C...d, u, s part by simple charge factor.
40063 XPGA(1)=(1D0/9D0)*CGAM
40064 XPGA(2)=(4D0/9D0)*CGAM
40065 XPGA(3)=(1D0/9D0)*CGAM
40067 C...Also fill for antiquarks.
40075 C*********************************************************************
40078 C...Gives pi+ parton distribution according to two different
40079 C...parametrizations.
40081 SUBROUTINE PYPDPI(X,Q2,XPPI)
40083 C...Double precision and integer declarations.
40084 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40085 IMPLICIT INTEGER(I-N)
40086 INTEGER PYK,PYCHGE,PYCOMP
40088 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40089 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40090 COMMON/PYINT1/MINT(400),VINT(400)
40091 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40093 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40095 C...The following data lines are coefficients needed in the
40096 C...Owens pion parton distribution parametrizations, see below.
40097 C...Expansion coefficients for up and down valence quark distributions.
40098 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40099 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40100 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40101 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40102 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40103 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40104 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40105 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40106 C...Expansion coefficients for gluon distribution.
40107 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40108 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40109 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40110 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40111 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40112 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40113 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40114 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40115 C...Expansion coefficients for (up+down+strange) quark sea distribution.
40116 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40117 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40118 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40119 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40120 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40121 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40122 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40123 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40124 C...Expansion coefficients for charm quark sea distribution.
40125 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40126 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40127 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40128 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40129 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40130 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40131 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40132 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40134 C...Euler's beta function, requires ordinary Gamma function
40135 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40137 C...Reset output array.
40142 IF(MSTP(53).LE.2) THEN
40143 C...Pion parton distributions from Owens.
40144 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40146 C...Determine set, Lambda and s expansion variable.
40148 IF(NSET.EQ.1) ALAM=0.2D0
40149 IF(NSET.EQ.2) ALAM=0.4D0
40151 IF(MSTP(57).LE.0) THEN
40154 Q2IN=MIN(2D3,MAX(4D0,Q2))
40155 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40158 C...Calculate parton distributions.
40161 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40162 & COW(3,IS,KFL,NSET)*SD**2
40165 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40167 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40172 C...Put into output array.
40175 XPPI(2)=XQ(1)+XQ(3)/6D0
40178 XPPI(-1)=XQ(1)+XQ(3)/6D0
40183 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40184 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40188 C...Determine s expansion variable and some x expressions.
40190 IF(MSTP(57).LE.0) THEN
40193 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40194 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40200 C...Evaluate valence, gluon and sea distributions.
40201 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40202 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40203 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40205 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40206 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40208 & (1D0-X)**(0.390D0+1.053D0*SD)
40209 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40211 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40213 & XL**(2.538D0-0.763D0*SD)
40214 IF(SD.LE.0.888D0) THEN
40217 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40219 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40222 IF(SD.LE.1.351D0) THEN
40225 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40226 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40230 C...Put into output array.
40238 XPPI(-KFL)=XPPI(KFL)
40240 XPPI(2)=XPPI(2)+XFVAL
40241 XPPI(-1)=XPPI(-1)+XFVAL
40247 C*********************************************************************
40250 C...Gives proton parton distributions according to a few different
40251 C...parametrizations.
40253 SUBROUTINE PYPDPR(X,Q2,XPPR)
40255 C...Double precision and integer declarations.
40256 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40257 IMPLICIT INTEGER(I-N)
40258 INTEGER PYK,PYCHGE,PYCOMP
40260 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40261 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40262 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40263 COMMON/PYINT1/MINT(400),VINT(400)
40264 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40265 C...Arrays and data.
40266 DIMENSION XPPR(-6:6),Q2MIN(16)
40267 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
40268 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
40270 C...Reset output array.
40275 C...Common preliminaries.
40276 NSET=MAX(1,MIN(16,MSTP(51)))
40277 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
40278 VINT(231)=Q2MIN(NSET)
40279 IF(MSTP(57).EQ.0) THEN
40282 Q2L=MAX(Q2MIN(NSET),Q2)
40285 IF(NSET.GE.1.AND.NSET.LE.3) THEN
40286 C...Interface to the CTEQ 3 parton distributions.
40287 QRT=SQRT(MAX(1D0,Q2L))
40289 C...Loop over flavours.
40292 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
40293 ELSEIF(I.LE.2) THEN
40294 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
40300 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
40301 C...Interface to the GRV 94 distributions.
40303 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40304 ELSEIF(NSET.EQ.5) THEN
40305 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40307 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40310 C...Put into output array.
40312 XPPR(-1)=0.5D0*(UDB+DEL)
40313 XPPR(-2)=0.5D0*(UDB-DEL)
40317 XPPR(1)=DV+XPPR(-1)
40318 XPPR(2)=UV+XPPR(-2)
40323 ELSEIF(NSET.EQ.7) THEN
40324 C...Interface to the CTEQ 5L parton distributions.
40325 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40326 C...freezing x*f(x,Q2) at borders.
40327 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40328 XIN=MAX(1D-6,MIN(1D0,X))
40330 C...Loop over flavours (with u <-> d notation mismatch).
40331 SUMUDB=PYCT5L(-1,XIN,QRT)
40332 RATUDB=PYCT5L(-2,XIN,QRT)
40335 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
40336 ELSEIF(I.EQ.2) THEN
40337 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
40338 ELSEIF(I.EQ.-1) THEN
40339 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40340 ELSEIF(I.EQ.-2) THEN
40341 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40343 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
40344 IF(I.LT.0) XPPR(-I)=XPPR(I)
40348 ELSEIF(NSET.EQ.8) THEN
40349 C...Interface to the CTEQ 5M1 parton distributions.
40350 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40351 XIN=MAX(1D-6,MIN(1D0,X))
40353 C...Loop over flavours (with u <-> d notation mismatch).
40354 SUMUDB=PYCT5M(-1,XIN,QRT)
40355 RATUDB=PYCT5M(-2,XIN,QRT)
40358 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
40359 ELSEIF(I.EQ.2) THEN
40360 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
40361 ELSEIF(I.EQ.-1) THEN
40362 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40363 ELSEIF(I.EQ.-2) THEN
40364 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40366 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
40367 IF(I.LT.0) XPPR(-I)=XPPR(I)
40371 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
40372 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40373 C...obsolete but offers backwards compatibility.
40374 CALL PYPDPO(X,Q2L,XPPR)
40376 C...Symmetric choice for debugging only
40377 ELSEIF(NSET.EQ.16) THEN
40395 C*********************************************************************
40398 C...Gives the CTEQ 3 parton distribution function sets in
40399 C...parametrized form, of October 24, 1994.
40400 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40401 C...J. Qiu, W.K. Tung and H. Weerts.
40403 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
40405 C...Double precision declaration.
40406 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40407 IMPLICIT INTEGER(I-N)
40409 C...Data on Lambda values of fits, minimum Q and quark masses.
40410 DIMENSION ALM(3), QMS(4:6)
40411 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
40412 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
40414 C....Check flavour thresholds. Set up QI for SB.
40417 IF(Q .LE. QMS(IP)) THEN
40426 C...Use "standard lambda" of parametrization program for expansion.
40428 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
40433 C...Expansion for CTEQ3L.
40434 IF(ISET .EQ. 1) THEN
40435 IF(IPRT .EQ. 2) THEN
40436 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
40438 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
40439 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
40440 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
40441 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
40442 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
40443 ELSEIF(IPRT .EQ. 1) THEN
40444 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
40446 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
40447 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
40448 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
40449 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
40450 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
40451 ELSEIF(IPRT .EQ. 0) THEN
40452 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
40454 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
40455 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
40456 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
40457 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
40458 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
40459 ELSEIF(IPRT .EQ. -1) THEN
40460 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
40462 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
40463 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
40464 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
40465 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
40466 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
40467 ELSEIF(IPRT .EQ. -2) THEN
40468 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
40470 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
40471 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
40472 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
40473 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
40474 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
40475 ELSEIF(IPRT .EQ. -3) THEN
40476 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
40478 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
40479 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
40480 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
40481 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
40482 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
40483 ELSEIF(IPRT .EQ. -4) THEN
40484 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
40486 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
40487 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
40488 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
40489 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
40490 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
40491 ELSEIF(IPRT .EQ. -5) THEN
40492 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
40494 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
40495 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
40496 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
40497 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
40498 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
40499 ELSEIF(IPRT .EQ. -6) THEN
40500 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
40502 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
40503 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
40504 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
40505 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
40506 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
40509 C...Expansion for CTEQ3M.
40510 ELSEIF(ISET .EQ. 2) THEN
40511 IF(IPRT .EQ. 2) THEN
40512 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
40514 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
40515 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
40516 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
40517 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
40518 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
40519 ELSEIF(IPRT .EQ. 1) THEN
40520 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
40522 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
40523 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
40524 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
40525 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
40526 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
40527 ELSEIF(IPRT .EQ. 0) THEN
40528 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
40530 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
40531 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
40532 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
40533 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
40534 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
40535 ELSEIF(IPRT .EQ. -1) THEN
40536 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
40538 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
40539 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
40540 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
40541 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
40542 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
40543 ELSEIF(IPRT .EQ. -2) THEN
40544 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
40546 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
40547 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
40548 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
40549 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
40550 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
40551 ELSEIF(IPRT .EQ. -3) THEN
40552 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
40554 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
40555 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
40556 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
40557 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
40558 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
40559 ELSEIF(IPRT .EQ. -4) THEN
40560 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
40562 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
40563 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
40564 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
40565 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
40566 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
40567 ELSEIF(IPRT .EQ. -5) THEN
40568 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
40570 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
40571 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
40572 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
40573 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
40574 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
40575 ELSEIF(IPRT .EQ. -6) THEN
40576 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
40578 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
40579 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
40580 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
40581 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
40582 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
40585 C...Expansion for CTEQ3D.
40586 ELSEIF(ISET .EQ. 3) THEN
40587 IF(IPRT .EQ. 2) THEN
40588 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
40590 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
40591 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
40592 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
40593 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
40594 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
40595 ELSEIF(IPRT .EQ. 1) THEN
40596 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
40598 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
40599 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
40600 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
40601 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
40602 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
40603 ELSEIF(IPRT .EQ. 0) THEN
40604 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
40606 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
40607 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
40608 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
40609 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
40610 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
40611 ELSEIF(IPRT .EQ. -1) THEN
40612 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
40614 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
40615 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
40616 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
40617 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
40618 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
40619 ELSEIF(IPRT .EQ. -2) THEN
40620 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
40622 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
40623 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
40624 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
40625 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
40626 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
40627 ELSEIF(IPRT .EQ. -3) THEN
40628 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
40630 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
40631 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
40632 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
40633 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
40634 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
40635 ELSEIF(IPRT .EQ. -4) THEN
40636 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
40638 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
40639 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
40640 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
40641 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
40642 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
40643 ELSEIF(IPRT .EQ. -5) THEN
40644 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
40646 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
40647 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
40648 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
40649 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
40650 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
40651 ELSEIF(IPRT .EQ. -6) THEN
40652 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
40654 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
40655 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
40656 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
40657 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
40658 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
40662 C...Calculation of x * f(x, Q).
40663 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
40664 & *(LOG(1D0+1D0/X))**A5 )
40669 C*********************************************************************
40672 C...Gives the GRV 94 L (leading order) parton distribution function set
40673 C...in parametrized form.
40674 C...Authors: M. Glueck, E. Reya and A. Vogt.
40676 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40678 C...Double precision declaration.
40679 IMPLICIT DOUBLE PRECISION (A - Z)
40681 C...Common expressions.
40683 LAM2 = 0.2322D0 * 0.2322D0
40684 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40690 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
40691 AKU = 0.590D0 - 0.024D0 * S
40692 BKU = 0.131D0 + 0.063D0 * S
40693 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
40694 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
40695 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
40696 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
40697 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40700 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
40702 BKD = 0.486D0 + 0.062D0 * S
40703 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
40704 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
40705 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
40706 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
40707 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40710 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
40711 AKE = 0.409D0 - 0.005D0 * S
40712 BKE = 0.799D0 + 0.071D0 * S
40713 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
40714 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
40716 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
40717 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40722 AKX = 0.410D0 - 0.232D0 * S
40723 BKX = 0.534D0 - 0.457D0 * S
40724 AGX = 0.890D0 - 0.140D0 * S
40726 CX = 0.320D0 + 0.683D0 * S
40727 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
40728 EX = 4.119D0 + 1.713D0 * S
40729 ESX = 0.682D0 + 2.978D0 * S
40730 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40737 AKS = 1.798D0 - 0.596D0 * S
40738 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
40739 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
40740 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
40741 EST = 3.981D0 + 1.638D0 * S
40743 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40751 BC = 4.24D0 - 0.804D0 * S
40752 DCT = 3.46D0 - 1.076D0 * S
40753 ECT = 4.61D0 + 1.49D0 * S
40754 ESC = 2.555D0 + 1.961D0 * S
40755 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40764 DBT = 2.929D0 + 1.396D0 * S
40765 EBT = 4.71D0 + 1.514D0 * S
40766 ESB = 4.02D0 + 1.239D0 * S
40767 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40772 AKG = 1.742D0 - 0.930D0 * S
40773 BKG = - 0.399D0 * S2
40774 AG = 7.486D0 - 2.185D0 * S
40775 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
40776 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
40777 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
40778 EG = 0.807D0 + 2.005D0 * S
40779 ESG = 3.841D0 + 0.316D0 * S
40780 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
40786 C*********************************************************************
40789 C...Gives the GRV 94 M (MSbar) parton distribution function set
40790 C...in parametrized form.
40791 C...Authors: M. Glueck, E. Reya and A. Vogt.
40793 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40795 C...Double precision declaration.
40796 IMPLICIT DOUBLE PRECISION (A - Z)
40798 C...Common expressions.
40800 LAM2 = 0.248D0 * 0.248D0
40801 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40807 NU = 1.304D0 + 0.863D0 * S
40808 AKU = 0.558D0 - 0.020D0 * S
40810 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
40811 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
40812 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
40813 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
40814 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40817 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
40818 AKD = 0.270D0 - 0.019D0 * S
40820 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
40821 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
40822 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
40823 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
40824 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40827 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
40828 AKE = 0.409D0 - 0.007D0 * S
40829 BKE = 0.782D0 + 0.082D0 * S
40830 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
40831 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
40833 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
40834 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40842 BGX = 3.210D0 - 1.866D0 * S
40844 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
40845 EX = 3.077D0 + 1.446D0 * S
40846 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
40847 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40854 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
40855 AS = -4.329D0 + 1.131D0 * S
40856 BS = 9.568D0 - 1.744D0 * S
40857 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
40858 EST = 3.031D0 + 1.639D0 * S
40859 ESS = 5.837D0 + 0.815D0 * S
40860 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40866 AKC = -0.625D0 - 0.523D0 * S
40868 BC = 1.896D0 + 1.616D0 * S
40869 DCT = 4.12D0 + 0.683D0 * S
40870 ECT = 4.36D0 + 1.328D0 * S
40871 ESC = 0.677D0 + 0.679D0 * S
40872 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40878 AKB = - 0.193D0 * S
40881 DBT = 3.447D0 + 0.927D0 * S
40882 EBT = 4.68D0 + 1.259D0 * S
40883 ESB = 1.892D0 + 2.199D0 * S
40884 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40889 AKG = 1.724D0 + 0.157D0 * S
40890 BKG = 0.800D0 + 1.016D0 * S
40891 AG = 7.517D0 - 2.547D0 * S
40892 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
40893 CG = 4.039D0 + 1.491D0 * S
40894 DG = 3.404D0 + 0.830D0 * S
40895 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
40896 ESG = 3.256D0 - 0.436D0 * S
40897 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40902 C*********************************************************************
40905 C...Gives the GRV 94 D (DIS) parton distribution function set
40906 C...in parametrized form.
40907 C...Authors: M. Glueck, E. Reya and A. Vogt.
40909 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40911 C...Double precision declaration.
40912 IMPLICIT DOUBLE PRECISION (A - Z)
40914 C...Common expressions.
40916 LAM2 = 0.248D0 * 0.248D0
40917 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40923 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40924 AKU = 0.563D0 - 0.025D0 * S
40925 BKU = 0.054D0 + 0.154D0 * S
40926 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40927 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40928 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40929 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40930 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40933 ND = 0.156D0 - 0.017D0 * S
40934 AKD = 0.299D0 - 0.022D0 * S
40935 BKD = 0.259D0 - 0.015D0 * S
40936 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40937 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40938 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40939 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40940 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40943 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40944 AKE = 0.419D0 - 0.013D0 * S
40945 BKE = 1.064D0 - 0.038D0 * S
40946 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40947 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40948 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40949 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40950 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40955 AKX = 0.326D0 + 0.150D0 * S
40956 BKX = 0.956D0 + 0.405D0 * S
40958 BGX = 3.794D0 - 2.359D0 * DS
40960 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40961 EX = 3.049D0 + 1.597D0 * S
40962 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40963 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40970 AKS = 1.415D0 - 0.641D0 * DS
40971 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40972 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40973 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40974 EST = 4.546D0 + 0.372D0 * S2
40975 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40976 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40982 AKC = -0.625D0 - 0.523D0 * S
40984 BC = 1.896D0 + 1.616D0 * S
40985 DCT = 4.12D0 + 0.683D0 * S
40986 ECT = 4.36D0 + 1.328D0 * S
40987 ESC = 0.677D0 + 0.679D0 * S
40988 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40994 AKB = - 0.193D0 * S
40997 DBT = 3.447D0 + 0.927D0 * S
40998 EBT = 4.68D0 + 1.259D0 * S
40999 ESB = 1.892D0 + 2.199D0 * S
41000 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41006 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
41007 AG = 25.09D0 - 7.935D0 * S
41008 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41009 CG = 590.3D0 - 173.8D0 * S
41010 DG = 5.196D0 + 1.857D0 * S
41011 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41012 ESG = 3.232D0 - 0.542D0 * S
41013 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41018 C*********************************************************************
41021 C...Auxiliary for the GRV 94 parton distribution functions
41022 C...for u and d valence and d-u sea.
41023 C...Authors: M. Glueck, E. Reya and A. Vogt.
41025 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41027 C...Double precision declaration.
41028 IMPLICIT DOUBLE PRECISION (A - Z)
41032 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41038 C*********************************************************************
41041 C...Auxiliary for the GRV 94 parton distribution functions
41042 C...for d+u sea and gluon.
41043 C...Authors: M. Glueck, E. Reya and A. Vogt.
41045 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41047 C...Double precision declaration.
41048 IMPLICIT DOUBLE PRECISION (A - Z)
41052 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41053 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41058 C*********************************************************************
41061 C...Auxiliary for the GRV 94 parton distribution functions
41062 C...for s, c and b sea.
41063 C...Authors: M. Glueck, E. Reya and A. Vogt.
41065 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41067 C...Double precision declaration.
41068 IMPLICIT DOUBLE PRECISION (A - Z)
41076 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41077 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41083 C*********************************************************************
41086 C...Auxiliary function for parametrization of CTEQ5L.
41087 C...Author: J. Pumplin 9/99.
41089 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41090 C...in Parametrized Form
41091 C... September 15, 1999
41093 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41094 C... CTEQ5 PPARTON DISTRIBUTIONS"
41097 C...The CTEQ5M1 set given here is an updated version of the original
41098 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41099 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41100 C...almost all applications.
41101 C...The improvement is in the QCD evolution which is now more
41102 C...accurate, and which agrees completely with the benchmark work
41103 C...of the HERA 96/97 Workshop.
41104 C...The differences between the parametrized and the corresponding
41105 C...table versions (on which it is based) are of similar order as
41106 C...between the two version.
41108 C...!! Because accurate parametrizations over a wide range of (x,Q)
41109 C...is hard to obtain, only the most widely used sets CTEQ5M and
41110 C...CTEQ5L are available in parametrized form for now.
41112 C...These parametrizations were obtained by Jon Pumplin.
41114 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41115 C -------------------------------------------------------------------
41116 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41117 C 3 CTEQ5L Leading Order 0.127 192 146
41118 C -------------------------------------------------------------------
41119 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41120 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41123 C...The two Iset value are adopted to agree with the standard table
41126 C...Range of validity:
41127 C...The range of (x, Q) covered by this parametrization of the QCD
41128 C...evolved parton distributions is 1E-6 < x < 1 ;
41129 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41130 C...data only in a subset of that region; and the assumed DGLAP
41131 C...evolution is unlikely to be valid for all of it either.
41133 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41134 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41135 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41136 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41138 FUNCTION PYCT5L(IFL,X,Q)
41140 C...Double precision declaration.
41141 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41142 IMPLICIT INTEGER(I-N)
41144 PARAMETER (NEX=8, NLF=2)
41145 DIMENSION AM(0:NEX,0:NLF,-5:2)
41146 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41147 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41148 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41149 DIMENSION AF(0:NEX)
41151 DATA MEXVEC( 2) / 8 /
41152 DATA MLFVEC( 2) / 2 /
41153 DATA UT1VEC( 2) / 0.4971265E+01 /
41154 DATA UT2VEC( 2) / -0.1105128E+01 /
41155 DATA ALFVEC( 2) / 0.2987216E+00 /
41156 DATA QMAVEC( 2) / 0.0000000E+00 /
41157 DATA (AM( 0,K, 2),K=0, 2)
41158 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41159 DATA (AM( 1,K, 2),K=0, 2)
41160 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41161 DATA (AM( 2,K, 2),K=0, 2)
41162 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41163 DATA (AM( 3,K, 2),K=0, 2)
41164 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41165 DATA (AM( 4,K, 2),K=0, 2)
41166 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41167 DATA (AM( 5,K, 2),K=0, 2)
41168 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41169 DATA (AM( 6,K, 2),K=0, 2)
41170 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41171 DATA (AM( 7,K, 2),K=0, 2)
41172 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41173 DATA (AM( 8,K, 2),K=0, 2)
41174 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41176 DATA MEXVEC( 1) / 8 /
41177 DATA MLFVEC( 1) / 2 /
41178 DATA UT1VEC( 1) / 0.2612618E+01 /
41179 DATA UT2VEC( 1) / -0.1258304E+06 /
41180 DATA ALFVEC( 1) / 0.3407552E+00 /
41181 DATA QMAVEC( 1) / 0.0000000E+00 /
41182 DATA (AM( 0,K, 1),K=0, 2)
41183 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41184 DATA (AM( 1,K, 1),K=0, 2)
41185 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41186 DATA (AM( 2,K, 1),K=0, 2)
41187 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41188 DATA (AM( 3,K, 1),K=0, 2)
41189 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41190 DATA (AM( 4,K, 1),K=0, 2)
41191 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41192 DATA (AM( 5,K, 1),K=0, 2)
41193 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41194 DATA (AM( 6,K, 1),K=0, 2)
41195 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41196 DATA (AM( 7,K, 1),K=0, 2)
41197 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41198 DATA (AM( 8,K, 1),K=0, 2)
41199 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41201 DATA MEXVEC( 0) / 8 /
41202 DATA MLFVEC( 0) / 2 /
41203 DATA UT1VEC( 0) / -0.4656819E+00 /
41204 DATA UT2VEC( 0) / -0.2742390E+03 /
41205 DATA ALFVEC( 0) / 0.4491863E+00 /
41206 DATA QMAVEC( 0) / 0.0000000E+00 /
41207 DATA (AM( 0,K, 0),K=0, 2)
41208 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41209 DATA (AM( 1,K, 0),K=0, 2)
41210 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41211 DATA (AM( 2,K, 0),K=0, 2)
41212 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41213 DATA (AM( 3,K, 0),K=0, 2)
41214 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41215 DATA (AM( 4,K, 0),K=0, 2)
41216 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41217 DATA (AM( 5,K, 0),K=0, 2)
41218 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41219 DATA (AM( 6,K, 0),K=0, 2)
41220 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41221 DATA (AM( 7,K, 0),K=0, 2)
41222 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41223 DATA (AM( 8,K, 0),K=0, 2)
41224 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41226 DATA MEXVEC(-1) / 8 /
41227 DATA MLFVEC(-1) / 2 /
41228 DATA UT1VEC(-1) / 0.3862583E+01 /
41229 DATA UT2VEC(-1) / -0.1265969E+01 /
41230 DATA ALFVEC(-1) / 0.2457668E+00 /
41231 DATA QMAVEC(-1) / 0.0000000E+00 /
41232 DATA (AM( 0,K,-1),K=0, 2)
41233 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41234 DATA (AM( 1,K,-1),K=0, 2)
41235 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41236 DATA (AM( 2,K,-1),K=0, 2)
41237 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41238 DATA (AM( 3,K,-1),K=0, 2)
41239 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41240 DATA (AM( 4,K,-1),K=0, 2)
41241 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41242 DATA (AM( 5,K,-1),K=0, 2)
41243 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41244 DATA (AM( 6,K,-1),K=0, 2)
41245 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41246 DATA (AM( 7,K,-1),K=0, 2)
41247 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
41248 DATA (AM( 8,K,-1),K=0, 2)
41249 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
41251 DATA MEXVEC(-2) / 7 /
41252 DATA MLFVEC(-2) / 2 /
41253 DATA UT1VEC(-2) / 0.1895615E+00 /
41254 DATA UT2VEC(-2) / -0.3069097E+01 /
41255 DATA ALFVEC(-2) / 0.5293999E+00 /
41256 DATA QMAVEC(-2) / 0.0000000E+00 /
41257 DATA (AM( 0,K,-2),K=0, 2)
41258 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
41259 DATA (AM( 1,K,-2),K=0, 2)
41260 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
41261 DATA (AM( 2,K,-2),K=0, 2)
41262 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
41263 DATA (AM( 3,K,-2),K=0, 2)
41264 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
41265 DATA (AM( 4,K,-2),K=0, 2)
41266 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
41267 DATA (AM( 5,K,-2),K=0, 2)
41268 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
41269 DATA (AM( 6,K,-2),K=0, 2)
41270 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
41271 DATA (AM( 7,K,-2),K=0, 2)
41272 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
41274 DATA MEXVEC(-3) / 7 /
41275 DATA MLFVEC(-3) / 2 /
41276 DATA UT1VEC(-3) / 0.3753257E+01 /
41277 DATA UT2VEC(-3) / -0.1113085E+01 /
41278 DATA ALFVEC(-3) / 0.3713141E+00 /
41279 DATA QMAVEC(-3) / 0.0000000E+00 /
41280 DATA (AM( 0,K,-3),K=0, 2)
41281 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
41282 DATA (AM( 1,K,-3),K=0, 2)
41283 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
41284 DATA (AM( 2,K,-3),K=0, 2)
41285 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
41286 DATA (AM( 3,K,-3),K=0, 2)
41287 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
41288 DATA (AM( 4,K,-3),K=0, 2)
41289 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
41290 DATA (AM( 5,K,-3),K=0, 2)
41291 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
41292 DATA (AM( 6,K,-3),K=0, 2)
41293 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
41294 DATA (AM( 7,K,-3),K=0, 2)
41295 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
41297 DATA MEXVEC(-4) / 7 /
41298 DATA MLFVEC(-4) / 2 /
41299 DATA UT1VEC(-4) / 0.4400772E+01 /
41300 DATA UT2VEC(-4) / -0.1356116E+01 /
41301 DATA ALFVEC(-4) / 0.3712017E-01 /
41302 DATA QMAVEC(-4) / 0.1300000E+01 /
41303 DATA (AM( 0,K,-4),K=0, 2)
41304 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
41305 DATA (AM( 1,K,-4),K=0, 2)
41306 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
41307 DATA (AM( 2,K,-4),K=0, 2)
41308 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
41309 DATA (AM( 3,K,-4),K=0, 2)
41310 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
41311 DATA (AM( 4,K,-4),K=0, 2)
41312 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
41313 DATA (AM( 5,K,-4),K=0, 2)
41314 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
41315 DATA (AM( 6,K,-4),K=0, 2)
41316 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
41317 DATA (AM( 7,K,-4),K=0, 2)
41318 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
41320 DATA MEXVEC(-5) / 6 /
41321 DATA MLFVEC(-5) / 2 /
41322 DATA UT1VEC(-5) / 0.5562568E+01 /
41323 DATA UT2VEC(-5) / -0.1801317E+01 /
41324 DATA ALFVEC(-5) / 0.4952010E-02 /
41325 DATA QMAVEC(-5) / 0.4500000E+01 /
41326 DATA (AM( 0,K,-5),K=0, 2)
41327 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
41328 DATA (AM( 1,K,-5),K=0, 2)
41329 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
41330 DATA (AM( 2,K,-5),K=0, 2)
41331 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
41332 DATA (AM( 3,K,-5),K=0, 2)
41333 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
41334 DATA (AM( 4,K,-5),K=0, 2)
41335 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
41336 DATA (AM( 5,K,-5),K=0, 2)
41337 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
41338 DATA (AM( 6,K,-5),K=0, 2)
41339 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
41341 IF(Q .LE. QMAVEC(IFL)) THEN
41346 IF(X .GE. 1.D0) THEN
41351 TMP = LOG(Q/ALFVEC(IFL))
41352 IF(TMP .LE. 0.D0) THEN
41364 DO 100 K = 0, MLFVEC(IFL)
41365 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41371 U = LOG(X/0.00001D0)
41373 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41374 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41375 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41376 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41377 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41379 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41381 C...Include threshold factor.
41382 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
41387 C*********************************************************************
41390 C...Auxiliary function for parametrization of CTEQ5M1.
41391 C...Author: J. Pumplin 9/99.
41393 FUNCTION PYCT5M(IFL,X,Q)
41395 C...Double precision declaration.
41396 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41397 IMPLICIT INTEGER(I-N)
41399 PARAMETER (NEX=8, NLF=2)
41400 DIMENSION AM(0:NEX,0:NLF,-5:2)
41401 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41402 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41403 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41404 DIMENSION AF(0:NEX)
41406 DATA MEXVEC( 2) / 8 /
41407 DATA MLFVEC( 2) / 2 /
41408 DATA UT1VEC( 2) / 0.5141718E+01 /
41409 DATA UT2VEC( 2) / -0.1346944E+01 /
41410 DATA ALFVEC( 2) / 0.5260555E+00 /
41411 DATA QMAVEC( 2) / 0.0000000E+00 /
41412 DATA (AM( 0,K, 2),K=0, 2)
41413 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
41414 DATA (AM( 1,K, 2),K=0, 2)
41415 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
41416 DATA (AM( 2,K, 2),K=0, 2)
41417 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
41418 DATA (AM( 3,K, 2),K=0, 2)
41419 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
41420 DATA (AM( 4,K, 2),K=0, 2)
41421 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
41422 DATA (AM( 5,K, 2),K=0, 2)
41423 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
41424 DATA (AM( 6,K, 2),K=0, 2)
41425 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
41426 DATA (AM( 7,K, 2),K=0, 2)
41427 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
41428 DATA (AM( 8,K, 2),K=0, 2)
41429 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
41431 DATA MEXVEC( 1) / 8 /
41432 DATA MLFVEC( 1) / 2 /
41433 DATA UT1VEC( 1) / 0.4138426E+01 /
41434 DATA UT2VEC( 1) / -0.3221374E+01 /
41435 DATA ALFVEC( 1) / 0.4960962E+00 /
41436 DATA QMAVEC( 1) / 0.0000000E+00 /
41437 DATA (AM( 0,K, 1),K=0, 2)
41438 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
41439 DATA (AM( 1,K, 1),K=0, 2)
41440 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
41441 DATA (AM( 2,K, 1),K=0, 2)
41442 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
41443 DATA (AM( 3,K, 1),K=0, 2)
41444 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
41445 DATA (AM( 4,K, 1),K=0, 2)
41446 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
41447 DATA (AM( 5,K, 1),K=0, 2)
41448 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
41449 DATA (AM( 6,K, 1),K=0, 2)
41450 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
41451 DATA (AM( 7,K, 1),K=0, 2)
41452 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
41453 DATA (AM( 8,K, 1),K=0, 2)
41454 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
41456 DATA MEXVEC( 0) / 8 /
41457 DATA MLFVEC( 0) / 2 /
41458 DATA UT1VEC( 0) / -0.1026789E+01 /
41459 DATA UT2VEC( 0) / -0.9051707E+01 /
41460 DATA ALFVEC( 0) / 0.9462977E+00 /
41461 DATA QMAVEC( 0) / 0.0000000E+00 /
41462 DATA (AM( 0,K, 0),K=0, 2)
41463 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
41464 DATA (AM( 1,K, 0),K=0, 2)
41465 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
41466 DATA (AM( 2,K, 0),K=0, 2)
41467 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
41468 DATA (AM( 3,K, 0),K=0, 2)
41469 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
41470 DATA (AM( 4,K, 0),K=0, 2)
41471 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
41472 DATA (AM( 5,K, 0),K=0, 2)
41473 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
41474 DATA (AM( 6,K, 0),K=0, 2)
41475 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
41476 DATA (AM( 7,K, 0),K=0, 2)
41477 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
41478 DATA (AM( 8,K, 0),K=0, 2)
41479 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
41481 DATA MEXVEC(-1) / 8 /
41482 DATA MLFVEC(-1) / 2 /
41483 DATA UT1VEC(-1) / 0.5243571E+01 /
41484 DATA UT2VEC(-1) / -0.2870513E+01 /
41485 DATA ALFVEC(-1) / 0.6701448E+00 /
41486 DATA QMAVEC(-1) / 0.0000000E+00 /
41487 DATA (AM( 0,K,-1),K=0, 2)
41488 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
41489 DATA (AM( 1,K,-1),K=0, 2)
41490 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
41491 DATA (AM( 2,K,-1),K=0, 2)
41492 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
41493 DATA (AM( 3,K,-1),K=0, 2)
41494 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
41495 DATA (AM( 4,K,-1),K=0, 2)
41496 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
41497 DATA (AM( 5,K,-1),K=0, 2)
41498 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
41499 DATA (AM( 6,K,-1),K=0, 2)
41500 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
41501 DATA (AM( 7,K,-1),K=0, 2)
41502 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
41503 DATA (AM( 8,K,-1),K=0, 2)
41504 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
41506 DATA MEXVEC(-2) / 7 /
41507 DATA MLFVEC(-2) / 2 /
41508 DATA UT1VEC(-2) / 0.4782210E+01 /
41509 DATA UT2VEC(-2) / -0.1976856E+02 /
41510 DATA ALFVEC(-2) / 0.7558374E+00 /
41511 DATA QMAVEC(-2) / 0.0000000E+00 /
41512 DATA (AM( 0,K,-2),K=0, 2)
41513 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
41514 DATA (AM( 1,K,-2),K=0, 2)
41515 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
41516 DATA (AM( 2,K,-2),K=0, 2)
41517 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
41518 DATA (AM( 3,K,-2),K=0, 2)
41519 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
41520 DATA (AM( 4,K,-2),K=0, 2)
41521 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
41522 DATA (AM( 5,K,-2),K=0, 2)
41523 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
41524 DATA (AM( 6,K,-2),K=0, 2)
41525 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
41526 DATA (AM( 7,K,-2),K=0, 2)
41527 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
41529 DATA MEXVEC(-3) / 7 /
41530 DATA MLFVEC(-3) / 2 /
41531 DATA UT1VEC(-3) / 0.4518239E+01 /
41532 DATA UT2VEC(-3) / -0.2690590E+01 /
41533 DATA ALFVEC(-3) / 0.6124079E+00 /
41534 DATA QMAVEC(-3) / 0.0000000E+00 /
41535 DATA (AM( 0,K,-3),K=0, 2)
41536 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
41537 DATA (AM( 1,K,-3),K=0, 2)
41538 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
41539 DATA (AM( 2,K,-3),K=0, 2)
41540 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
41541 DATA (AM( 3,K,-3),K=0, 2)
41542 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
41543 DATA (AM( 4,K,-3),K=0, 2)
41544 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
41545 DATA (AM( 5,K,-3),K=0, 2)
41546 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
41547 DATA (AM( 6,K,-3),K=0, 2)
41548 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
41549 DATA (AM( 7,K,-3),K=0, 2)
41550 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
41552 DATA MEXVEC(-4) / 7 /
41553 DATA MLFVEC(-4) / 2 /
41554 DATA UT1VEC(-4) / 0.2783230E+01 /
41555 DATA UT2VEC(-4) / -0.1746328E+01 /
41556 DATA ALFVEC(-4) / 0.1115653E+01 /
41557 DATA QMAVEC(-4) / 0.1300000E+01 /
41558 DATA (AM( 0,K,-4),K=0, 2)
41559 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
41560 DATA (AM( 1,K,-4),K=0, 2)
41561 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
41562 DATA (AM( 2,K,-4),K=0, 2)
41563 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
41564 DATA (AM( 3,K,-4),K=0, 2)
41565 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
41566 DATA (AM( 4,K,-4),K=0, 2)
41567 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
41568 DATA (AM( 5,K,-4),K=0, 2)
41569 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
41570 DATA (AM( 6,K,-4),K=0, 2)
41571 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
41572 DATA (AM( 7,K,-4),K=0, 2)
41573 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
41575 DATA MEXVEC(-5) / 6 /
41576 DATA MLFVEC(-5) / 2 /
41577 DATA UT1VEC(-5) / 0.1619654E+02 /
41578 DATA UT2VEC(-5) / -0.3367346E+01 /
41579 DATA ALFVEC(-5) / 0.5109891E-02 /
41580 DATA QMAVEC(-5) / 0.4500000E+01 /
41581 DATA (AM( 0,K,-5),K=0, 2)
41582 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
41583 DATA (AM( 1,K,-5),K=0, 2)
41584 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
41585 DATA (AM( 2,K,-5),K=0, 2)
41586 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
41587 DATA (AM( 3,K,-5),K=0, 2)
41588 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
41589 DATA (AM( 4,K,-5),K=0, 2)
41590 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
41591 DATA (AM( 5,K,-5),K=0, 2)
41592 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
41593 DATA (AM( 6,K,-5),K=0, 2)
41594 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
41596 IF(Q .LE. QMAVEC(IFL)) THEN
41601 IF(X .GE. 1.D0) THEN
41606 TMP = LOG(Q/ALFVEC(IFL))
41607 IF(TMP .LE. 0.D0) THEN
41619 DO 100 K = 0, MLFVEC(IFL)
41620 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41626 U = LOG(X/0.00001D0)
41628 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41629 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41630 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41631 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41632 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41634 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41636 C...Include threshold factor.
41637 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
41642 C*********************************************************************
41645 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41646 C...a few older parametrizations, now obsolete but convenient for
41647 C...backwards checks.
41649 SUBROUTINE PYPDPO(X,Q2,XPPR)
41651 C...Double precision and integer declarations.
41652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41653 IMPLICIT INTEGER(I-N)
41654 INTEGER PYK,PYCHGE,PYCOMP
41656 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41657 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41658 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41659 COMMON/PYINT1/MINT(400),VINT(400)
41660 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41661 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
41662 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
41665 C...The following data lines are coefficients needed in the
41666 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41667 C...parametrizations, see below.
41668 C...Powers of 1-x in different cases.
41669 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41670 C...Expansion coefficients for up valence quark distribution.
41671 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
41672 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
41673 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
41674 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
41675 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
41676 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
41677 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
41678 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
41679 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
41680 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
41681 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
41682 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
41683 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
41684 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
41685 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
41686 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
41687 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
41688 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
41689 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
41690 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
41691 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
41692 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
41693 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
41694 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
41695 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
41696 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
41697 C...Expansion coefficients for down valence quark distribution.
41698 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
41699 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
41700 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
41701 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
41702 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
41703 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
41704 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
41705 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
41706 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
41707 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
41708 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
41709 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
41710 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
41711 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
41712 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
41713 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
41714 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
41715 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
41716 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
41717 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
41718 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
41719 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
41720 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
41721 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
41722 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
41723 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
41724 C...Expansion coefficients for up and down sea quark distributions.
41725 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
41726 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
41727 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
41728 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
41729 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
41730 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
41731 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
41732 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
41733 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
41734 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
41735 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
41736 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
41737 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
41738 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
41739 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
41740 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
41741 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
41742 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
41743 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
41744 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
41745 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
41746 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
41747 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
41748 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
41749 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
41750 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
41751 C...Expansion coefficients for gluon distribution.
41752 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
41753 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
41754 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
41755 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
41756 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
41757 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
41758 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
41759 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
41760 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
41761 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
41762 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
41763 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
41764 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
41765 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
41766 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
41767 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
41768 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
41769 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
41770 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
41771 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
41772 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
41773 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
41774 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
41775 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
41776 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
41777 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
41778 C...Expansion coefficients for strange sea quark distribution.
41779 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
41780 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
41781 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
41782 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
41783 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
41784 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
41785 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
41786 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
41787 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
41788 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
41789 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
41790 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
41791 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
41792 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
41793 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
41794 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
41795 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
41796 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
41797 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
41798 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
41799 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
41800 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
41801 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
41802 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
41803 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
41804 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
41805 C...Expansion coefficients for charm sea quark distribution.
41806 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
41807 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
41808 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
41809 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
41810 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
41811 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
41812 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
41813 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
41814 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
41815 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
41816 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
41817 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
41818 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
41819 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
41820 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
41821 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
41822 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
41823 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
41824 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
41825 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
41826 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
41827 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
41828 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
41829 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
41830 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
41831 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
41832 C...Expansion coefficients for bottom sea quark distribution.
41833 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
41834 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
41835 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
41836 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
41837 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
41838 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
41839 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
41840 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
41841 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
41842 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
41843 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
41844 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
41845 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
41846 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
41847 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
41848 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
41849 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
41850 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
41851 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
41852 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
41853 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
41854 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
41855 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
41856 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
41857 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
41858 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
41859 C...Expansion coefficients for top sea quark distribution.
41860 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
41861 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
41862 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
41863 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
41864 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41865 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
41866 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41867 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
41868 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
41869 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
41870 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
41871 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
41872 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
41873 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
41874 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
41875 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
41876 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
41877 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41878 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
41879 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41880 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
41881 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
41882 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
41883 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
41884 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
41885 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
41887 C...The following data lines are coefficients needed in the
41888 C...Duke, Owens proton structure function parametrizations, see below.
41889 C...Expansion coefficients for (up+down) valence quark distribution.
41890 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
41891 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41892 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41893 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41894 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
41895 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41896 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41897 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41898 C...Expansion coefficients for down valence quark distribution.
41899 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
41900 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41901 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41902 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41903 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
41904 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41905 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41906 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41907 C...Expansion coefficients for (up+down+strange) sea quark distribution.
41908 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
41909 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41910 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
41911 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41912 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41913 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41914 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41915 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41916 C...Expansion coefficients for charm sea quark distribution.
41917 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41918 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41919 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41920 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41921 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41922 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41923 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41924 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41925 C...Expansion coefficients for gluon distribution.
41926 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41927 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41928 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41929 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41930 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41931 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41932 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41933 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41935 C...Euler's beta function, requires ordinary Gamma function
41936 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41938 C...Leading order proton parton distributions from Glueck, Reya and
41939 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41941 IF(MSTP(51).EQ.11) THEN
41943 C...Determine s expansion variable and some x expressions.
41944 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41945 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41950 C...Evaluate valence, gluon and sea distributions.
41951 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41952 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41953 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41954 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41955 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41956 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41957 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41958 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41959 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41960 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41961 & SQRT(4.066D0*SD**1.218D0*XL)))*
41962 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41963 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41964 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41965 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41966 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41967 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41968 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41969 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41970 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41971 IF(SD.LE.0.888D0) THEN
41974 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41975 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41976 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41978 IF(SD.LE.1.351D0) THEN
41981 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41982 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41983 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41986 C...Put into output array.
41988 XPPR(1)=XFVDD+XFSEA
41989 XPPR(2)=XFVUD-XFVDD+XFSEA
41999 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
42000 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
42001 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
42003 C...Determine set, Lambda and x and t expansion variables.
42005 IF(NSET.EQ.1) ALAM=0.2D0
42006 IF(NSET.EQ.2) ALAM=0.29D0
42007 TMIN=LOG(5D0/ALAM**2)
42008 TMAX=LOG(1D8/ALAM**2)
42009 T=LOG(MAX(1D0,Q2/ALAM**2))
42010 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42012 IF(X.LE.0.1D0) NX=2
42013 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42014 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42016 C...Chebyshev polynomials for x and t expansion.
42019 TX(3)=2D0*VX**2-1D0
42020 TX(4)=4D0*VX**3-3D0*VX
42021 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42022 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42025 TT(3)=2D0*VT**2-1D0
42026 TT(4)=4D0*VT**3-3D0*VT
42027 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42028 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42030 C...Calculate structure functions.
42035 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42038 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42041 C...Put into output array.
42043 XPPR(1)=XQ(2)+XQ(3)
42044 XPPR(2)=XQ(1)+XQ(3)
42052 C...Special expansion for bottom (threshold effects).
42053 IF(MSTP(58).GE.5) THEN
42054 IF(NSET.EQ.1) TMIN=8.1905D0
42055 IF(NSET.EQ.2) TMIN=7.4474D0
42057 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42060 TT(3)=2D0*VT**2-1D0
42061 TT(4)=4D0*VT**3-3D0*VT
42062 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42063 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42067 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42070 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42075 C...Special expansion for top (threshold effects).
42076 IF(MSTP(58).GE.6) THEN
42077 IF(NSET.EQ.1) TMIN=11.5528D0
42078 IF(NSET.EQ.2) TMIN=10.8097D0
42079 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42080 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42082 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42085 TT(3)=2D0*VT**2-1D0
42086 TT(4)=4D0*VT**3-3D0*VT
42087 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42088 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42092 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42095 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42100 C...Proton parton distributions from Duke, Owens.
42101 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42102 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42104 C...Determine set, Lambda and s expansion parameter.
42106 IF(NSET.EQ.1) ALAM=0.2D0
42107 IF(NSET.EQ.2) ALAM=0.4D0
42108 Q2IN=MIN(1D6,MAX(4D0,Q2))
42109 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42111 C...Calculate structure functions.
42114 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42115 & CDO(3,IS,KFL,NSET)*SD**2
42118 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42119 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42121 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42122 & TS(5)*X**2+TS(6)*X**3)
42126 C...Put into output arrays.
42128 XPPR(1)=XQ(2)+XQ(3)/6D0
42129 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42142 C*********************************************************************
42145 C...Gives threshold attractive/repulsive factor for heavy flavour
42148 FUNCTION PYHFTH(SH,SQM,FRATT)
42150 C...Double precision and integer declarations.
42151 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42152 IMPLICIT INTEGER(I-N)
42153 INTEGER PYK,PYCHGE,PYCOMP
42155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42156 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42157 COMMON/PYINT1/MINT(400),VINT(400)
42158 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42160 C...Value for alpha_strong.
42161 IF(MSTP(35).LE.1) THEN
42166 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42172 C...Evaluate attractive and repulsive factors.
42173 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42174 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42175 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42176 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42177 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42183 C*********************************************************************
42186 C...Splits a hadron remnant into two (partons or hadron + parton)
42187 C...in case it is more complicated than just a quark or a diquark.
42189 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42191 C...Double precision and integer declarations.
42192 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42193 IMPLICIT INTEGER(I-N)
42194 INTEGER PYK,PYCHGE,PYCOMP
42195 C...Commonblocks. PYDAT1 temporary
42196 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42197 COMMON/PYINT1/MINT(400),VINT(400)
42198 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42199 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42203 C...Preliminaries. Parton composition.
42206 KFL(1)=MOD(KFA/1000,10)
42207 KFL(2)=MOD(KFA/100,10)
42208 KFL(3)=MOD(KFA/10,10)
42209 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42210 KFL(2)=INT(1.5D0+PYR(0))
42211 IF(MINT(105).EQ.333) KFL(2)=3
42212 IF(MINT(105).EQ.443) KFL(2)=4
42214 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42217 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42220 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42221 KFL(2)=MOD(KFA/10,10)
42222 KFL(3)=MOD(KFA/100,10)
42224 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42231 C...Subdivide lepton.
42232 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42233 IF(KFLR.EQ.KFA) THEN
42235 ELSEIF(KFLR.EQ.22) THEN
42237 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42239 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42241 ELSEIF(KFLR.EQ.21) THEN
42249 C...Subdivide photon.
42250 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
42251 IF(KFLR.NE.21) THEN
42256 IF(RAGR.GT.0.125D0) KFLSP=2
42257 IF(RAGR.GT.0.625D0) KFLSP=3
42258 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
42262 C...Subdivide Reggeon or Pomeron.
42263 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
42264 IF(KFLIN.EQ.21) THEN
42270 C...Subdivide meson.
42271 ELSEIF(KFL(1).EQ.0) THEN
42272 KFL(2)=KFL(2)*(-1)**KFL(2)
42273 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
42274 IF(KFLR.EQ.KFL(2)) THEN
42276 ELSEIF(KFLR.EQ.KFL(3)) THEN
42278 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
42281 ELSEIF(KFLR.EQ.21) THEN
42284 ELSEIF(KFLR*KFL(2).GT.0) THEN
42287 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
42288 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42290 ELSEIF(KFLCH.EQ.0) THEN
42291 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42299 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
42300 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42302 ELSEIF(KFLCH.EQ.0) THEN
42303 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42310 C...Special case for extracting photon from baryon without splitting
42311 C...the latter. (Currently only used by external programs.)
42312 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
42316 C...Subdivide baryon.
42320 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
42323 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
42326 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
42327 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
42330 IAGR=1.00001D0+2.99998D0*PYR(0)
42333 IF(IAGR.EQ.1) ID1=2
42334 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
42337 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
42338 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
42339 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
42340 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
42341 ELSEIF(MOD(KFA,10).EQ.2) THEN
42342 IF(IAGR.EQ.1) KSP=1
42343 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
42345 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
42346 IF(KFLR.EQ.21) THEN
42348 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
42351 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
42352 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42354 ELSEIF(KFLCH.EQ.0) THEN
42355 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42359 ELSEIF(NAGR.EQ.0) THEN
42362 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
42363 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42365 ELSEIF(KFLCH.EQ.0) THEN
42366 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42374 C...Add on correct sign for result.
42381 C*********************************************************************
42384 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42385 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42386 C...(Dover, 1965) 6.1.36.
42390 C...Double precision and integer declarations.
42391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42392 IMPLICIT INTEGER(I-N)
42393 INTEGER PYK,PYCHGE,PYCOMP
42394 C...Local array and data.
42396 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
42397 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
42406 PYGAMM=PYGAMM+B(I)*DXP
42412 PYGAMM=(X-IX)*PYGAMM
42419 C***********************************************************************
42422 C...Calculates real and imaginary parts of the auxiliary functions W1
42423 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42424 C...der Bij, Nucl. Phys. B297 (1988) 221.
42426 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
42428 C...Double precision and integer declarations.
42429 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42430 IMPLICIT INTEGER(I-N)
42431 INTEGER PYK,PYCHGE,PYCOMP
42433 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42436 ASINH(X)=LOG(X+SQRT(X**2+1D0))
42437 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
42439 IF(EPS.LT.0D0) THEN
42440 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
42441 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
42443 ELSEIF(EPS.LT.1D0) THEN
42444 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
42445 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
42446 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
42447 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
42449 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
42450 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
42457 C***********************************************************************
42460 C...Calculates real and imaginary parts of the auxiliary function I3;
42461 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42462 C...Nucl. Phys. B297 (1988) 221.
42464 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
42466 C...Double precision and integer declarations.
42467 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42468 IMPLICIT INTEGER(I-N)
42469 INTEGER PYK,PYCHGE,PYCOMP
42471 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42474 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
42475 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
42477 IF(EPS.LT.0D0) THEN
42478 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42479 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42480 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42481 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
42482 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
42483 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
42484 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
42485 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
42487 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42488 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42489 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42490 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
42491 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
42492 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
42493 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
42494 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
42495 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42496 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42497 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42498 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
42499 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
42500 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
42501 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
42502 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
42504 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42505 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
42506 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
42507 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
42508 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
42511 ELSEIF(EPS.LT.1D0) THEN
42512 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42513 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42514 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42515 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
42516 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
42517 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42518 & (0.25D0*(RAT+1D0)*EPS))
42519 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42520 & (0.25D0*(RAT+1D0)*EPS))
42521 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42522 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42523 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42524 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
42525 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
42526 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
42527 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42528 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42529 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42530 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42531 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42532 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
42533 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
42534 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
42535 & (1D0+0.25D0*RAT*EPS-GA))
42536 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
42537 & (1D0+0.25D0*RAT*EPS-GA))
42539 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42540 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
42541 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
42542 & LOG((GA+BE-1D0)/(BE-GA))
42543 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
42546 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
42547 RCTHE=RSQ*(1D0-2D0*BE/EPS)
42548 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
42549 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
42550 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
42552 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
42553 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
42554 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
42555 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
42556 & (PHI-THE)*(PHI+THE-PARU(1))
42557 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
42558 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
42561 Y3RE=2D0/(2D0*BE-1D0)*F3RE
42562 Y3IM=2D0/(2D0*BE-1D0)*F3IM
42567 C***********************************************************************
42570 C...Calculates real and imaginary part of Spence function; see
42571 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42573 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
42575 C...Double precision and integer declarations.
42576 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42577 IMPLICIT INTEGER(I-N)
42578 INTEGER PYK,PYCHGE,PYCOMP
42580 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42582 C...Local array and data.
42585 &1.000000D+00, -5.000000D-01, 1.666667D-01,
42586 &0.000000D+00, -3.333333D-02, 0.000000D+00,
42587 &2.380952D-02, 0.000000D+00, -3.333333D-02,
42588 &0.000000D+00, 7.575757D-02, 0.000000D+00,
42589 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
42593 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
42594 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
42595 IF(IREIM.EQ.2) PYSPEN=0D0
42599 XMOD=SQRT(XRE**2+XIM**2)
42600 IF(XMOD.LT.1D-6) THEN
42601 IF(IREIM.EQ.1) PYSPEN=0D0
42602 IF(IREIM.EQ.2) PYSPEN=0D0
42606 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42610 IF(XMOD.GT.1D0) THEN
42612 ALGXIM=XARG-SIGN(PARU(1),XARG)
42613 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
42614 SP0IM=-ALGXRE*ALGXIM
42621 IF(XRE.GT.0.5D0) THEN
42626 XMOD=SQRT(XRE**2+XIM**2)
42627 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42630 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
42631 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
42637 XMOD=SQRT(XRE**2+XIM**2)
42638 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42647 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
42648 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
42649 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
42652 SPRE=SPRE+B(I)*TERMRE
42653 SPIM=SPIM+B(I)*TERMIM
42656 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
42657 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
42662 C***********************************************************************
42665 C...Calculates the matrix element for the processes
42666 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42667 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42668 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42670 SUBROUTINE PYQQBH(WTQQBH)
42672 C...Double precision and integer declarations.
42673 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42674 IMPLICIT INTEGER(I-N)
42675 INTEGER PYK,PYCHGE,PYCOMP
42677 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42678 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42679 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42680 COMMON/PYINT1/MINT(400),VINT(400)
42681 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42682 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
42683 C...Local arrays and function.
42684 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
42685 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
42688 C...Mass parameters.
42691 SHPR=SQRT(VINT(26))*VINT(1)
42692 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
42693 PH=SQRT(VINT(21))*VINT(1)
42697 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42699 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42700 PP(I,1)=PT*COS(VINT(198+5*I))
42701 PP(I,2)=PT*SIN(VINT(198+5*I))
42703 PP(3,1)=-PP(1,1)-PP(2,1)
42704 PP(3,2)=-PP(1,2)-PP(2,2)
42705 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
42706 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
42707 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
42709 PP(3,3)=PMT3*SINH(VINT(211))
42710 PP(3,4)=PMT3*COSH(VINT(211))
42711 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
42712 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42713 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
42714 PP(2,3)=-PP(1,3)-PP(3,3)
42715 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
42716 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
42718 C...Set up incoming kinematics and derived momentum combinations.
42722 PP(I,3)=-0.5D0*SHPR*(-1)**I
42723 PP(I,4)=-0.5D0*SHPR
42726 PP(6,J)=PP(1,J)+PP(2,J)
42727 PP(7,J)=PP(1,J)+PP(3,J)
42728 PP(8,J)=PP(1,J)+PP(4,J)
42729 PP(9,J)=PP(1,J)+PP(5,J)
42730 PP(10,J)=-PP(2,J)-PP(3,J)
42731 PP(11,J)=-PP(2,J)-PP(4,J)
42732 PP(12,J)=-PP(2,J)-PP(5,J)
42733 PP(13,J)=-PP(4,J)-PP(5,J)
42736 C...Derived kinematics invariants.
42765 C...Define colour coefficients for g + g -> Q + Qbar + H.
42766 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
42770 CLR(I+3,J+3)=16D0/3D0
42771 CLR(I,J+3)=-2D0/3D0
42772 CLR(I+3,J)=-2D0/3D0
42785 CLR(6+K1,6+K2)=12D0
42789 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42790 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
42791 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
42792 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
42793 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
42794 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
42795 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
42797 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
42798 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
42799 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42800 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
42801 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
42802 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
42803 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
42804 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
42805 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
42806 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
42807 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
42808 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
42809 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42810 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
42811 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
42812 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
42813 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
42814 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
42816 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
42817 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
42818 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
42819 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
42820 & +X4*X9*X5+X4*X5**2)
42821 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
42822 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
42823 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
42824 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
42825 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
42826 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
42827 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
42828 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
42829 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
42830 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
42831 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
42832 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
42833 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
42834 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
42835 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
42836 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
42837 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
42838 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
42839 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
42840 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
42842 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
42843 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42844 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
42845 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
42846 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
42847 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
42848 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
42850 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
42851 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
42852 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
42853 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
42854 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
42855 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
42857 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
42858 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
42859 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
42860 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
42861 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
42862 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
42863 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
42865 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42866 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42867 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
42868 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
42869 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
42870 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42871 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
42872 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
42873 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
42874 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
42875 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
42876 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42877 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42878 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
42879 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
42880 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
42881 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42882 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
42883 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
42884 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
42885 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
42886 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
42887 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
42888 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
42889 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
42890 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
42891 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
42892 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
42893 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
42894 & +X3*X8*X5+X3*X5**2)
42895 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
42896 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
42897 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
42898 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
42899 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
42900 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
42901 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
42903 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
42904 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
42905 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
42906 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
42907 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
42908 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
42909 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
42910 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
42911 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42912 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42913 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42914 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42915 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42916 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42917 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42918 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42919 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42920 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42921 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42922 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42923 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42924 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42925 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42926 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42927 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42928 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42930 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42931 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42932 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42933 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42934 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42935 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42936 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42937 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42938 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42939 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42940 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42941 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42942 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42943 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42944 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42945 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42946 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42947 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42948 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42949 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42950 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42951 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42952 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42953 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42954 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42955 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42957 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42958 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42959 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42960 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42961 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42962 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42963 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42964 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42965 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42966 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42967 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42968 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42969 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42970 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42971 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42972 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42973 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42974 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42975 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42976 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42977 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42978 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42979 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42980 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42981 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42982 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42983 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42984 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42985 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42986 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42987 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42988 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42989 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42990 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42991 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42992 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42993 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42994 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42995 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42996 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42997 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42998 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42999 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
43000 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
43002 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
43003 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
43004 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
43005 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
43006 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43007 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43008 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43009 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43010 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43011 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43012 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43014 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43015 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43016 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43017 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43018 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43019 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43021 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43022 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43023 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43025 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43026 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43027 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43028 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43030 C...Repackage matrix elements.
43036 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43037 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43038 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43040 C...Produce final result: matrix elements * colours * propagators.
43045 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43048 WTQQBH=-WTQQBH/256D0
43051 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43052 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43053 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43055 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43056 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43057 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43059 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43060 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43063 C...Produce final result: matrix elements * propagators.
43065 A12=A12/(DX(7)*DX(8))
43067 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43073 C*********************************************************************
43075 C...PYSTBH (and auxiliaries)
43076 C.. Evaluates the matrix elements for t + b + H production.
43078 SUBROUTINE PYSTBH(WTTBH)
43080 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43082 IMPLICIT INTEGER(I-N)
43083 INTEGER PYK,PYCHGE,PYCOMP
43086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43089 COMMON/PYINT1/MINT(400),VINT(400)
43090 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43091 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43092 COMMON/PYINT4/MWID(500),WIDS(500,5)
43093 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43094 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43095 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43096 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43097 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43098 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43099 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43100 DOUBLE PRECISION MW2
43101 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43102 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43104 C...LOCAL ARRAYS AND COMPLEX VARIABLES
43105 DIMENSION QQ(4,2),PP(4,3)
43110 C...KINEMATIC PARAMETERS.
43111 SHPR=SQRT(VINT(26))*VINT(1)
43112 PH=SQRT(VINT(21))*VINT(1)
43115 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43117 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43118 PP(1,I)=PT*COS(VINT(198+5*I))
43119 PP(2,I)=PT*SIN(VINT(198+5*I))
43121 PP(1,3)=-PP(1,1)-PP(1,2)
43122 PP(2,3)=-PP(2,1)-PP(2,2)
43123 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43124 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43125 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43127 PP(3,3)=PMT3*SINH(VINT(211))
43128 PP(4,3)=PMT3*COSH(VINT(211))
43129 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43130 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43131 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43132 PP(3,2)=-PP(3,1)-PP(3,3)
43133 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43134 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43136 C...CM SYSTEM, INGOING QUARKS/GLUONS
43137 QQ(3,1) = SHPR/2.D0
43142 C...PARAMETERS FOR AMPLITUDE METHOD
43146 MW2 = PMAS(24,1)**2
43149 RMB=PYMRUN(5,VINT(52))
43153 IF (ISUB.EQ.401) THEN
43154 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43155 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43156 ELSE IF (ISUB.EQ.402) THEN
43157 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43158 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43163 C------------------------------------------------------------------
43164 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43165 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43167 IMPLICIT INTEGER(I-N)
43168 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43169 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43172 C TOP WIDTH CALCULATION
43179 IF (MT .LT. (MHP+MB)) THEN
43181 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43182 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43183 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43186 C T ->BW +T ->B H^+
43187 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43188 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43189 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43191 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43192 & -4.D0*(MHP*MB/MT**2)**2 )
43193 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43194 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43195 GAMT = GAMTBW+GAMTBH
43202 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43203 C GG->TBH^+, QQBAR->TBH^+
43204 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43205 C (FOR INSTANCE WITH PYTHIA)
43206 C------------------------------------------------------------
43207 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43208 C PHYS REV. D 60 (1999) 115011
43209 C (THESE FILES PREPARED BY J.-L. KNEUR)
43210 C------------------------------------------------------------
43212 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43214 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43216 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43217 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43218 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43219 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43220 C "PHYSICAL PARAMETERS" INPUT:
43221 C MT,MB TOP AND BOTTOM MASSES;
43222 C MHP CHARGED HIGGS MASS
43223 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43225 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43226 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43227 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43228 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43229 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43230 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43231 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43234 IMPLICIT INTEGER(I-N)
43235 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43236 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43237 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43238 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43239 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43241 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43242 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43243 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43244 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43245 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43246 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43247 C (TAN BETA) VALUES
43249 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43250 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43255 C COLLECTING THE RELEVANT OVERALL FACTORS:
43256 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43257 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
43258 C COUPLING CONSTANT (OVERALL NORMALIZATION)
43259 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43260 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43261 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43262 C ALPHAS IS ALPHA_STRONG;
43263 C SW2 IS SIN(THETA_W)**2.
43266 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43268 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43269 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43270 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43272 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43273 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43275 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43277 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43278 S = 2*PYTBHS(Q1,Q2)
43285 C TOP WIDTH CALCULATION
43286 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43287 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43288 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43289 A1INV= S -2*P1Q1 -2*P1Q2
43290 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43291 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43292 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43294 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43295 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43296 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43297 C NOW COMES THE AMP**2:
43298 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43299 C THE EXPRESSIONS BELOW
43302 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
43303 &512*A1*A2*MB*MT/3-
43304 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43305 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
43306 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
43307 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43308 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
43309 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
43310 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
43311 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
43312 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43313 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43314 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
43315 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
43316 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43317 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43318 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
43319 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
43320 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
43321 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
43322 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43323 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
43324 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
43325 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43326 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43327 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43328 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
43329 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43330 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43331 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43332 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43333 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43334 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
43335 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43336 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43337 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
43338 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
43339 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43340 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
43341 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43342 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43343 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
43344 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
43345 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43346 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
43347 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43348 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43349 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43350 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43351 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
43352 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
43353 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43354 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
43355 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43356 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43357 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43358 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43359 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43360 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
43361 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
43362 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
43363 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43364 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43365 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43366 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43367 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43368 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
43369 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43370 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43371 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43372 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
43373 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43374 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
43375 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43376 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43377 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
43378 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43379 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43380 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43381 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
43382 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43383 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43384 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43385 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43386 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43387 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43388 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
43389 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43390 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43391 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
43392 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43393 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43394 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43395 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43396 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43397 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43398 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
43399 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43400 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43401 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43402 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
43403 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43404 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43405 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43406 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43407 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43408 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
43409 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43410 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
43411 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43412 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
43413 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
43414 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43415 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43416 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43417 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43418 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
43419 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43420 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43421 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43422 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43423 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43424 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
43425 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43426 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43427 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43428 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43429 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43430 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
43431 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
43432 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43433 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43434 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43435 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
43436 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43437 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43438 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43439 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43440 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43441 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
43442 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43443 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
43444 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43445 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43446 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
43447 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43448 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43449 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43450 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43451 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43452 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
43453 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43454 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43455 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43456 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43457 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43458 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43459 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43460 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
43461 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43462 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43463 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43464 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43465 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43466 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
43467 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43468 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43469 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43470 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43471 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43472 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43473 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
43474 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43475 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
43476 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43477 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43478 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43479 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43480 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43481 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43482 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43483 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43484 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
43485 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43486 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43487 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
43488 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43489 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43490 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43491 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43492 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43493 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
43494 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43495 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43496 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43497 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
43498 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43499 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43500 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
43501 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43502 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43503 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43504 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43505 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43506 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43507 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43508 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43509 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43510 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43511 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43512 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43513 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43514 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43515 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43516 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43517 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43518 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43519 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43520 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
43521 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43522 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43523 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43524 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43525 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43526 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43527 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43528 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43529 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
43530 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43531 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43532 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43533 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43534 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43535 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43536 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43537 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43538 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
43539 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43540 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43541 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43542 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43543 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43544 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
43545 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43546 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43547 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43548 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43549 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43550 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43551 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43552 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43553 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
43554 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43555 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43556 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43557 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43558 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43559 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43560 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43561 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43562 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43563 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43564 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43565 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43566 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43567 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43568 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43569 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43570 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
43571 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43572 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43573 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43574 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
43575 &384*A12*MB*MT*P1Q1**2/S**2+
43576 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43577 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
43578 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43579 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43580 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43581 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43582 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
43583 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43584 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43585 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43586 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43587 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43588 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43589 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43590 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43591 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
43592 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43593 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
43594 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
43595 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
43596 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
43597 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
43598 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43599 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
43600 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
43601 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
43602 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
43603 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
43604 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
43605 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43606 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
43607 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43608 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
43609 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
43610 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43611 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43612 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
43613 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
43614 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
43615 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
43616 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43617 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43618 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43619 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43620 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
43621 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43622 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
43623 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
43624 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
43625 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
43626 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
43627 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43628 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
43629 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43630 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43631 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43632 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43633 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43634 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43635 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43636 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43637 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43638 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43639 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
43640 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
43641 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
43642 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
43643 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
43644 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
43645 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43646 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43647 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43648 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
43649 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43650 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
43651 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43652 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43653 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43654 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43655 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43656 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43657 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
43658 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43659 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
43660 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43661 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
43662 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43663 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43664 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
43665 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
43666 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43667 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43668 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43669 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43670 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
43671 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43672 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
43673 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43674 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43675 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43676 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
43677 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43678 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
43679 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43680 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
43681 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
43682 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
43683 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43684 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
43685 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
43686 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43687 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43688 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43689 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43690 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43691 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43692 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43693 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43694 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43695 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
43696 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43697 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43698 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43699 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43700 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43701 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43702 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43703 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43704 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43705 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
43706 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43707 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
43708 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43709 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43710 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43711 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43712 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
43713 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
43714 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43715 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
43716 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
43717 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43718 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43719 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
43720 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43721 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43722 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
43723 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43724 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43725 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43726 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
43727 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
43728 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43729 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
43730 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
43731 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43732 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43733 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43734 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43735 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43736 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43737 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
43738 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
43739 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
43740 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43741 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43742 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43743 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43744 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43745 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
43746 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
43747 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43748 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43749 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43750 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
43751 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
43754 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43755 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43756 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43757 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43758 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43759 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43760 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43761 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43762 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43763 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43764 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
43765 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43766 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43767 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
43768 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43769 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
43770 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
43771 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
43772 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43773 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43774 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43775 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43776 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43777 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43778 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
43779 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
43780 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43781 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43782 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
43783 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
43784 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43785 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
43786 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
43787 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
43788 &272*A1*A2*P1Q1*S/(3*P1Q2)+
43789 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
43790 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43791 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
43792 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43793 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43794 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43795 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43796 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43797 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
43798 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43799 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43800 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
43801 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43802 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
43803 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
43804 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43805 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43806 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
43807 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
43808 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
43809 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43810 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
43811 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43812 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
43813 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43814 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43815 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
43816 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43817 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43818 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
43819 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43820 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
43821 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
43822 &32*A12*P2Q1*S/(3*P1Q1)-
43823 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43824 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
43825 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
43826 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43827 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43828 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43829 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43830 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43831 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
43832 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43833 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43834 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
43835 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43836 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43837 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
43838 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
43839 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
43840 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43841 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
43842 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43843 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43844 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
43845 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43846 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
43847 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43848 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
43849 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43850 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43851 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43852 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43853 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43854 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
43855 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
43856 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
43857 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43858 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
43859 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
43860 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
43861 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43862 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43863 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43864 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43865 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43866 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43867 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43868 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43869 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43870 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43871 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
43872 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
43873 &272*A1*A2*P2Q1*S/(3*P2Q2)-
43874 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
43875 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43876 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
43877 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43878 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43879 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43880 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43881 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43882 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43883 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43884 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
43885 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43886 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43887 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43888 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
43889 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
43890 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43891 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43892 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
43893 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
43894 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43895 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43896 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43899 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
43900 &512*A1*A2*MB*MT/3+
43901 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43902 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
43903 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
43904 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43905 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
43906 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
43907 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
43908 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
43909 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43910 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43911 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43912 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43913 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43914 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43915 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43916 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43917 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43918 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43919 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43920 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43921 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43922 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43923 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43924 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43925 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43926 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43927 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43928 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43929 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43930 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43931 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43932 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43933 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43934 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43935 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43936 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43937 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43938 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43939 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43940 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43941 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43942 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43943 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43944 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43945 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43946 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43947 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43948 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43949 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43950 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43951 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43952 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43953 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43954 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43955 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43956 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43957 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43958 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43959 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43960 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43961 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43962 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43963 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43964 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43965 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43966 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43967 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43968 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43969 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43970 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43971 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43972 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43973 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43974 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43975 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43976 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43977 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43978 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43979 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43980 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43981 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43982 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43983 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43984 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43985 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43986 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43987 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43988 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43989 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43990 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43991 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43992 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43993 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43994 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43995 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43996 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43997 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43998 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43999 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
44000 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44001 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44002 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44003 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44004 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44005 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
44006 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44007 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44008 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44009 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44010 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44011 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44012 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44013 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44014 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44015 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44016 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44017 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44018 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44019 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44020 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44021 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44022 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44023 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44024 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44025 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44026 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44027 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44028 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44029 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44030 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44031 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44032 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44033 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44034 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44035 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44036 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44037 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44038 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44039 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44040 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44041 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44042 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44043 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44044 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44045 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44046 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44047 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44048 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44049 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44050 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44051 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44052 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44053 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44054 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44055 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44056 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44057 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44058 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44059 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44060 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44061 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44062 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44063 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44064 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44065 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44066 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44067 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44068 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44069 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44070 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44071 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44072 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44073 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44074 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44075 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44076 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44077 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44078 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44079 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44080 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44081 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44082 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44083 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44084 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44085 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44086 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44087 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44088 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44089 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44090 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44091 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44092 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44093 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44094 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44095 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44096 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44097 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44098 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44099 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44100 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44101 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44102 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44103 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44104 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44105 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44106 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44107 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44108 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44109 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44110 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44111 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44112 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44113 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44114 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44115 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44116 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44117 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44118 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44119 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44120 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44121 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44122 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44123 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44124 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44125 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44126 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44127 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44128 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44129 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44130 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44131 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44132 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44133 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44134 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44135 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44136 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44137 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44138 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44139 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44140 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44141 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44142 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44143 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44144 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44145 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44146 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44147 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44148 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44149 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44150 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44151 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44152 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44153 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44154 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44155 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44156 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44157 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44158 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44159 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44160 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44161 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44162 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44163 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44164 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44165 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44166 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44167 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44168 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44169 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44170 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44171 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44172 &384*A12*MB*MT*P1Q1**2/S**2+
44173 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44174 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44175 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44176 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44177 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44178 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44179 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44180 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44181 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44182 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44183 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44184 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44185 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44186 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44187 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44188 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44189 &384*A2**2*MB*MT*P2Q2**2/S**2+
44190 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44191 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44192 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44193 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44194 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44195 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44196 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44197 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44198 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44199 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44200 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44201 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44202 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44203 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44204 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44205 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44206 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44207 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44208 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44209 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44210 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44211 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44212 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44213 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44214 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44215 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44216 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44217 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44218 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44219 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44220 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44221 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44222 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44223 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44224 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44225 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44226 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44227 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44228 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44229 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44230 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44231 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44232 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44233 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44234 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44235 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44236 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44237 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44238 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44239 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44240 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44241 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44242 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44243 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44244 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44245 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44246 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
44247 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44248 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44249 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44250 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44251 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44252 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44253 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
44254 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44255 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
44256 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44257 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
44258 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44259 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44260 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
44261 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
44262 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44263 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44264 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44265 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44266 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
44267 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44268 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
44269 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44270 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
44271 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44272 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
44273 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44274 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
44275 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44276 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
44277 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
44278 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
44279 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44280 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
44281 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
44282 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44283 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44284 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44285 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44286 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
44287 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44288 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44289 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
44290 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
44291 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
44292 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44293 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44294 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44295 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44296 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44297 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44298 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44299 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44300 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44301 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
44302 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44303 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
44304 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44305 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44306 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
44307 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
44308 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44309 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
44310 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44311 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
44312 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
44313 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44314 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44315 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
44316 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44317 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44318 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
44319 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44320 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44321 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44322 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
44323 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
44324 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44325 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
44326 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44327 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44328 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44329 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44330 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44331 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44332 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
44333 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
44334 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
44335 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44336 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44337 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44338 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
44339 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44340 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
44341 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
44342 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44343 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44344 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44345 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44346 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44347 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44348 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44349 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44350 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44351 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44352 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44353 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
44354 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44355 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44356 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44357 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
44358 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44359 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44360 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
44361 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44362 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
44363 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
44364 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44365 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44366 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44367 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44368 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44369 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44370 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
44371 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
44372 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44373 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44374 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
44375 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
44376 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44377 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
44378 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
44379 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
44380 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
44381 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44382 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
44385 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44386 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44387 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44388 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44389 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44390 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
44391 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44392 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44393 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
44394 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44395 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
44396 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
44397 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44398 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44399 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
44400 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
44401 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
44403 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44404 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
44405 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44406 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
44407 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44408 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44409 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44410 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44411 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44412 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
44413 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44414 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
44415 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
44416 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44417 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
44418 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
44419 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
44420 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44421 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44422 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44423 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44424 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44425 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
44426 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44427 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44428 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
44429 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44430 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44431 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
44432 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
44433 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44434 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
44435 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44436 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44437 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
44438 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44439 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
44440 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44441 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
44442 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44443 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44444 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44445 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44446 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44447 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
44448 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
44449 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44450 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
44451 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
44452 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44453 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44454 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44455 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44456 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44457 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44458 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44459 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44460 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44461 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44462 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44463 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44464 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
44465 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
44466 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
44467 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44468 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
44469 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44470 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44471 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44472 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44473 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44474 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44475 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44476 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
44477 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44478 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44479 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44480 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
44481 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
44482 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44483 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44484 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
44485 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
44486 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44487 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44488 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44492 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
44493 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
44494 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44495 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44496 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44497 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
44498 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44499 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44500 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44501 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44502 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44503 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44504 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
44505 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
44506 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
44507 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
44508 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
44509 V910=V910+96*A1*A2*P1P2*P2Q1/S-
44510 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44511 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
44512 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
44513 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44514 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44516 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
44517 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
44518 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44519 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44520 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44521 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
44522 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44523 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44524 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
44525 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44526 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44527 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44528 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
44529 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
44530 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
44531 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
44532 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
44533 A910=A910+96*A1*A2*P1P2*P2Q1/S-
44534 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44535 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
44536 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
44537 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44538 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44542 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
44545 C---------------------------------------------------------
44546 C 2) Q QBAR ->TBH^+
44547 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44549 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44550 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44552 IMPLICIT INTEGER(I-N)
44553 DOUBLE PRECISION MW2,MT,MB,MHP,MW
44554 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
44555 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44556 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44557 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44558 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
44559 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
44560 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44561 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44562 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44563 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44565 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44566 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44573 C COLLECTING THE RELEVANT OVERALL FACTORS:
44574 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44575 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
44576 C COUPLING CONSTANT (OVERALL NORMALIZATION)
44577 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44578 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44579 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44580 C ALPHAS IS ALPHA_STRONG;
44581 C SW2 IS SIN(THETA_W)**2.
44584 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44586 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44587 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44588 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44590 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44591 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44593 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44595 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44596 S = 2*PYTBHS(Q1,Q2)
44603 C TOP WIDTH CALCULATION
44604 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44605 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44606 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44607 A1INV= S -2*P1Q1 -2*P1Q2
44608 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44609 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44610 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44611 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44612 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44613 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44614 C NOW COMES THE AMP**2:
44615 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44616 C THE EXPRESSIONS BELOW
44617 YY(1, 1) = -16*A**2*A2**2*MB*MT+
44618 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
44619 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
44620 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
44621 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44622 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44623 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
44624 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
44625 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
44626 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
44627 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
44628 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
44629 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
44630 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
44631 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44632 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44633 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
44634 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
44635 &32*A2**2*MB**2*P1P2*V**2/S+
44636 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
44637 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
44638 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
44639 YY(1, 1)=2*YY(1, 1)
44641 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
44642 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
44643 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44644 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44645 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
44646 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
44647 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
44648 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44649 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
44650 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44651 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
44652 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44653 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
44654 &64*A**2*A1*A2*MB*MT*P1P2/S+
44655 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
44656 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
44657 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
44658 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
44659 &64*A**2*A1*A2*P1Q1*P2Q1/S-
44660 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
44661 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
44662 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
44663 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
44664 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
44665 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
44666 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
44667 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
44668 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
44669 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
44670 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
44671 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44672 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44673 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
44674 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
44675 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
44676 &32*A1*A2*P1P2*P1Q1*V**2/S+
44677 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
44678 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
44679 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
44680 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
44683 YY(2, 2) =-16*A**2*A12*MB*MT+
44684 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
44685 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
44686 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
44687 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
44688 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
44689 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
44690 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
44691 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
44692 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
44693 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
44694 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
44695 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
44696 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
44697 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
44698 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
44699 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
44700 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
44701 &32*A12*MT**2*P2Q2*V**2/S-
44702 &32*A12*P1Q2*P2Q2*V**2/S
44703 YY(2, 2)=2*YY(2, 2)
44705 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
44706 AMP2= FACT*PS*VTB**2*RES
44709 C=====================================================================
44710 C ************* FUNCTION SCALAR PRODUCTS *************************
44711 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
44712 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44713 IMPLICIT INTEGER(I-N)
44714 DIMENSION A(4),B(4)
44717 DUM=DUM-A(ID)*B(ID)
44723 C*********************************************************************
44726 C...Initializes supersymmetry: finds sparticle masses and
44727 C...branching ratios and stores this information.
44728 C...AUTHOR: STEPHEN MRENNA
44729 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44733 C...Double precision and integer declarations.
44734 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44735 IMPLICIT INTEGER(I-N)
44736 INTEGER PYK,PYCHGE,PYCOMP
44737 C...Parameter statement to help give large particle numbers.
44738 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44739 &KEXCIT=4000000,KDIMEN=5000000)
44741 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44742 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44743 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44744 COMMON/PYDAT4/CHAF(500,2)
44746 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44747 COMMON/PYINT4/MWID(500),WIDS(500,5)
44748 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44749 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44750 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44751 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44752 COMMON/PYHTRI/HHH(7)
44753 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44754 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
44755 &/PYMSSM/,/PYMSRV/,/PYSSMT/
44757 C...Local variables.
44758 DOUBLE PRECISION ALFA,BETA
44759 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44760 INTEGER I,J,J1,I1,K1
44761 INTEGER KC,LKNT,IDLAM(400,3)
44762 DOUBLE PRECISION XLAM(0:400)
44763 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44764 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44765 DOUBLE PRECISION DELM,XMDIF
44766 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44767 DOUBLE PRECISION ARG,SGNMU,R
44770 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44773 &1000001,2000001,1000002,2000002,1000003,2000003,
44774 &1000004,2000004,1000005,2000005,1000006,2000006,
44775 &1000011,2000011,1000012,2000012,1000013,2000013,
44776 &1000014,2000014,1000015,2000015,1000016,2000016,
44777 &1000021,1000022,1000023,1000025,1000035,1000024,
44778 &1000037,1000039, 25, 35, 36, 37,
44779 & 6, 24, 45, 46,1000045, 9*0/
44782 C...Automatically read QNUMBERS, MASS, and DECAY tables
44783 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
44785 CALL PYSLHA(0,0,IFAIL)
44786 CALL PYSLHA(5,0,IFAIL)
44788 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
44790 C...Do nothing further if SUSY not requested
44792 IF(IMSSM.EQ.0) RETURN
44794 C...Save copy of MWID(KC) and MDCY(KC,1) values before
44795 C...they are set to zero for the LSP.
44802 MDCYSU(I)=MDCY(KC,1)
44806 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44810 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
44812 MDCY(KC,1)=MDCYSU(I)
44816 C...First part of routine: set masses and couplings.
44818 C...Reset mixing values in sfermion sector to pure left/right.
44826 C...Add NMSSM states if NMSSM switched on, and change old names.
44827 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
44828 C... Switch on NMSSM
44829 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
44859 DO 123 KCT=100,MSTU(6)
44860 IF(KCHG(KCT,4).GT.100) KCN=KCT
44866 C... Set stable for now
44872 CHAF(KCN,1)='~chi_50'
44876 C...Read spectrum from SLHA file.
44877 IF (IMSSM.EQ.11) THEN
44878 CALL PYSLHA(1,0,IFAIL)
44881 C...Common couplings.
44886 COS2B=COS(2D0*BETA)
44892 C...Define sparticle masses for a general MSSM simulation.
44893 IF(IMSSM.EQ.1) THEN
44894 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
44896 KC=PYCOMP(KSUSY1+I)
44897 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
44898 KC=PYCOMP(KSUSY2+I)
44899 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
44900 KC=PYCOMP(KSUSY1+I+1)
44901 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
44902 KC=PYCOMP(KSUSY2+I+1)
44903 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
44905 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
44906 IF(XARG.LT.0D0) THEN
44907 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44908 & ' FROM THE SUM RULE. '
44909 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44915 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44916 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44917 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44918 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44920 IF(IMSS(8).EQ.1) THEN
44925 C...Alternatively derive masses from SUGRA relations.
44926 ELSEIF(IMSSM.EQ.2) THEN
44930 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44939 C...Add in extra D-term contributions.
44940 IF(IMSS(7).EQ.1) THEN
44945 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44946 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44947 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44948 WRITE(MSTU(11),*) 'C DX = ',DX
44949 WRITE(MSTU(11),*) 'C DY = ',DY
44950 WRITE(MSTU(11),*) 'C DS = ',DS
44951 WRITE(MSTU(11),*) 'C '
44952 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44953 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44954 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44955 DQ2=DY/6D0-DX/3D0-DS/3D0
44956 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44957 DD2=DY/3D0+DX-2D0*DS/3D0
44958 DL2=-DY/2D0+DX-2D0*DS/3D0
44959 DE2=DY-DX/3D0-DS/3D0
44960 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44961 DHD2=-DY/2D0-2D0*DX/3D0+DS
44962 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44964 DMA2 = 2D0*DMU2+DHU2+DHD2
44966 KC=PYCOMP(KSUSY1+I)
44967 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44968 KC=PYCOMP(KSUSY2+I)
44969 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44970 KC=PYCOMP(KSUSY1+I+1)
44971 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44972 KC=PYCOMP(KSUSY2+I+1)
44973 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44976 KC=PYCOMP(KSUSY1+I)
44977 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44978 KC=PYCOMP(KSUSY2+I)
44979 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44980 KC=PYCOMP(KSUSY1+I+1)
44981 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44983 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44984 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44987 SGNMU=SIGN(1D0,RMSS(4))
44988 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44989 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44990 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44991 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44992 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44993 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44994 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44995 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44996 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44997 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44998 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44999 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
45000 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
45003 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
45004 RMSS(6)=SQRT(RMSS(6)**2+DL2)
45005 RMSS(7)=SQRT(RMSS(7)**2+DE2)
45006 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45007 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45008 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45009 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45010 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45013 C...Fix the third generation sfermions.
45016 C...Fix the neutralino--chargino--gluino sector.
45019 C...Fix the Higgs sector.
45022 C...Choose the Gunion-Haber convention.
45026 C...Print information on mass parameters.
45027 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45028 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45029 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45030 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45031 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45032 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45033 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45034 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45035 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45036 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45037 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45039 IF(IMSS(20).EQ.1) THEN
45040 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45041 WRITE(MSTU(11),*) ' DEBUG MODE '
45042 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45043 & UMIX(2,1),UMIX(2,2)
45044 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45045 & UMIXI(2,1),UMIXI(2,2)
45046 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45047 & VMIX(2,1),VMIX(2,2)
45048 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45049 & VMIXI(2,1),VMIXI(2,2)
45050 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45051 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45052 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45053 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45054 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45055 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45056 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45057 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45058 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45059 WRITE(MSTU(11),*) ' BETA = ',BETA
45060 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45061 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45062 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45065 C...Set up the Higgs couplings - needed here since initialization
45066 C...in PYINRE did not yet occur when PYWIDT is called below.
45078 C2B=COSB**2-SINB**2
45079 C...tanb (used for H+)
45083 C...Coupling to d-type quarks
45084 PARU(161)=SINA/COSB
45085 C...Coupling to u-type quarks
45086 PARU(162)=-COSA/SINB
45087 C...Coupling to leptons
45088 PARU(163)=PARU(161)
45092 PARU(165)=PARU(164)
45095 C...Coupling to d-type quarks
45096 PARU(171)=-COSA/COSB
45097 C...Coupling to u-type quarks
45098 PARU(172)=-SINA/SINB
45099 C...Coupling to leptons
45100 PARU(173)=PARU(171)
45104 PARU(175)=PARU(174)
45106 IF(IMSS(4).GE.2) THEN
45107 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45109 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45110 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45111 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45112 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45113 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45117 IF(IMSS(4).GE.2) THEN
45118 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45120 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45121 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45122 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45123 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45126 IF(IMSS(4).GE.2) THEN
45127 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45129 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45130 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45131 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45132 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45135 IF(IMSS(4).GE.2) THEN
45136 PARU(178)=PARU(177)
45138 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45141 C...Coupling to d-type quarks
45143 C...Coupling to u-type quarks
45144 PARU(182)=1D0/PARU(181)
45145 C...Coupling to leptons
45146 PARU(183)=PARU(181)
45149 C...Coupling to Z h
45150 PARU(186)=COS(BE-AL)
45151 C...Coupling to Z H
45152 PARU(187)=SIN(BE-AL)
45158 C...Coupling to W h
45159 PARU(195)=COS(BE-AL)
45161 C...Tell that all Higgs couplings have been set.
45164 C...Set R-Violating couplings.
45165 C...Set lambda couplings to common value or "natural values".
45166 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45167 VIR3=1D0/(126D0)**3
45171 IF (IRI.NE.IRJ) THEN
45172 IF (IRI.LT.IRJ) THEN
45173 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45174 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45175 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45176 & PMAS(9+2*IRK,1)*VIR3)
45178 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45181 RVLAM(IRI,IRJ,IRK)=0D0
45187 C...Set lambda' couplings to common value or "natural values".
45188 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45189 VIR3=1D0/(126D0)**3
45193 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45194 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45195 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45196 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45201 C...Set lambda'' couplings to common value or "natural values".
45202 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45203 VIR3=1D0/(126D0)**3
45207 IF (IRJ.NE.IRK) THEN
45208 IF (IRJ.LT.IRK) THEN
45209 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45210 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45211 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45212 & PMAS(2*IRK-1,1)*VIR3)
45214 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45217 RVLAMB(IRI,IRJ,IRK) = 0D0
45224 C...Antisymmetrize couplings set by user
45225 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45229 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45230 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45231 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45233 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45234 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45235 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45242 C...Write spectrum to SLHA file
45243 IF (IMSS(23).NE.0) THEN
45245 CALL PYSLHA(3,0,IFAIL)
45248 C...Second part of routine: set decay modes and branching ratios.
45250 C...Allow chi10 -> gravitino + gamma or not.
45251 KC=PYCOMP(KSUSY1+39)
45252 IF( IMSS(11) .NE. 0 ) THEN
45253 PMAS(KC,1)=RMSS(21)/1D9
45256 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45257 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
45259 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
45260 & ' ALLOWING SUSY LLE DECAYS'
45261 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
45262 & ' ALLOWING SUSY LQD DECAYS'
45263 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
45264 & ' ALLOWING SUSY UDD DECAYS'
45265 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
45266 & ' --- Warning: R-Violating couplings possibly',
45267 & ' incompatible with proton decay'
45273 C...Loop over sparticle and Higgs species.
45274 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
45275 C...Find the LSP or NLSP for a gravitino LSP
45280 IF(KF.EQ.1000039) GOTO 300
45282 IF(PMAS(KC,1).LT.PMLSP) THEN
45288 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
45290 IF (KF.EQ.0) GOTO 370
45294 C...Check if there are any decays listed for this sparticle
45296 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
45298 CALL PYSLHA(2,KF,IFAIL)
45299 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
45300 ELSEIF (I.GE.37) THEN
45304 C...Sfermion decays.
45306 C...First check to see if sneutrino is lighter than chi10.
45307 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
45308 & PMAS(KC,1).LT.PMCHI1) THEN
45310 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
45314 ELSEIF(I.EQ.25) THEN
45315 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
45316 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
45318 C...Neutralino decays.
45319 ELSEIF(I.GE.26.AND.I.LE.29) THEN
45320 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
45321 C...chi10 stable or chi10 -> gravitino + gamma.
45322 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
45328 C...Chargino decays.
45329 ELSEIF(I.GE.30.AND.I.LE.31) THEN
45330 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
45332 C...Gravitino is stable.
45333 ELSEIF(I.EQ.32) THEN
45338 ELSEIF(I.GE.33.AND.I.LE.36) THEN
45339 C...Calculate decays to non-SUSY particles.
45340 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
45345 DO 330 I1=1,MDCY(KC,3)
45347 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
45348 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
45350 XLAM(0)=XLAM(0)+XLAM(I1)
45352 IDLAM(I1,J1)=KFDP(K1,J1)
45356 C...Add the decays to SUSY particles.
45357 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
45359 C...Zero the branching ratios for use in loop mode
45360 C...thanks to K. Matchev (FNAL)
45361 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45365 C...Set stable particles.
45373 C...Store branching ratios in the standard tables.
45375 IDC=MDCY(KC,2)+MDCY(KC,3)-1
45381 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
45382 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
45383 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
45384 BRAT(IDC)=XLAM(IL)/XLAM(0)
45386 IF(MDME(IDC,1).GE.1) THEN
45387 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
45388 & PMAS(PYCOMP(KFDP(IDC,2)),1)
45389 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
45390 & PMAS(PYCOMP(KFDP(IDC,3)),1)
45393 IF(XMDIF.GE.0D0) THEN
45394 DELM=MIN(DELM,XMDIF)
45396 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
45397 WRITE(MSTU(11),*) ' KF = ',KF
45398 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
45402 ELSEIF(IDC.EQ.IDCSV) THEN
45403 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
45404 & 'channel not recognized:'
45405 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
45412 C...Store width, cutoff and lifetime.
45414 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
45415 PMAS(KC,3)=PMAS(KC,2)*10D0
45417 PMAS(KC,3)=0.95D0*DELM
45419 IF(PMAS(KC,2).NE.0D0) THEN
45420 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
45422 C...Write decays to SLHA file
45423 IF (IMSS(24).NE.0) THEN
45425 CALL PYSLHA(4,KF,IFAIL)
45433 C*********************************************************************
45436 C...Read/write spectrum or decay data from SLHA standard file(s).
45439 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45440 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45441 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45442 C... (KFORIG=0 : read all decay tables)
45443 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45444 C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45445 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45446 C... (KFORIG=0 : read all MASS entries)
45448 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
45450 C...Double precision and integer declarations.
45451 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45452 IMPLICIT INTEGER(I-N)
45453 INTEGER PYK,PYCHGE,PYCOMP
45454 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45455 &KEXCIT=4000000,KDIMEN=5000000)
45457 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45458 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45459 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45460 COMMON/PYDAT4/CHAF(500,2)
45462 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45463 CHARACTER*40 ISAVER,VISAJE
45464 COMMON/PYINT4/MWID(500),WIDS(500,5)
45465 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
45467 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45468 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45469 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45470 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45471 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
45473 C...Local arrays, character variables and data.
45474 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45475 & AU(3,3),AD(3,3),AE(3,3)
45476 COMMON/PYLH3C/CPRO(2),CVER(2)
45477 C...The common block of new states (QNUMBERS / PARTICLE)
45478 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45479 C...- NQNUM : Number of QNUMBERS blocks that have been read in
45480 C...- KQNUM(I,0) : KF of new state
45481 C...- KQNUM(I,1) : 3 times electric charge
45482 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45483 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45484 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45485 C...- KQNUM(I,5:9) : space available for further quantum numbers
45486 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
45487 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
45488 C...MMOD: flags to set for each block read in.
45489 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45490 C...MSPC: Flags to set for each block read in.
45491 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45492 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45493 C...11: AD 12: AE 13: YU 14: YD 15: YE
45494 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45495 CHARACTER CPRO*12,CVER*12,CHNLIN*6
45496 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45497 CHARACTER CHINL*120,CHKF*9,CHTMP*16
45500 C...Date of last Change
45501 PARAMETER (DOC='13 Jul 2009')
45502 C...Local arrays and initial values
45503 DIMENSION IDC(5),KFSUSY(50)
45512 &1000001,1000002,1000003,1000004,1000005,1000006,
45513 &2000001,2000002,2000003,2000004,2000005,2000006,
45514 &1000011,1000012,1000013,1000014,1000015,1000016,
45515 &2000011,2000012,2000013,2000014,2000015,2000016,
45516 &1000021,1000022,1000023,1000025,1000035,1000024,
45517 &1000037,1000039, 25, 35, 36, 37,
45518 & 6, 24, 45, 46,1000045, 9*0/
45520 RMFUN(IP)=PMAS(PYCOMP(IP),1)
45522 C...Shorthand for spectrum and decay table unit numbers
45526 C...Default for LHEF input: read header information
45527 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
45528 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
45529 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
45530 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
45533 IF (NHELLO.EQ.0) THEN
45534 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
45535 WRITE(MSTU(11),5000) DOC
45540 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45543 IF (MUPDA.EQ.2) LFN=IMSS22
45544 IF (MUPDA.EQ.3) LFN=IMSS(23)
45545 IF (MUPDA.EQ.4) LFN=IMSS(24)
45546 C...Flag that we have not yet found whatever we were asked to find.
45548 C...Flag that we are skipping until <slha> tag found (if LHEF)
45550 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
45552 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45554 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45558 C...If reading LHEF header, start by rewinding file
45559 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
45561 C...If told to read spectrum, first zero all previous information.
45562 IF (MUPDA.EQ.1) THEN
45563 C...Zero all block read flags
45568 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45570 KC=PYCOMP(KFSUSY(ISUSY))
45573 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45581 IF (J.LE.2.AND.L.LE.2) THEN
45588 C...Zero signed masses.
45590 IF (J.LE.2) SMW(J)=0D0
45593 C...If reading decays, reset PYTHIA decay counters.
45594 ELSEIF (MUPDA.EQ.2) THEN
45595 C...Check if DECAY for this KF already read
45596 IF (KFORIG.NE.0) THEN
45597 DO 140 IDEC=1,NDECAY
45598 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
45607 DO 150 KC=1,MSTU(6)
45608 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
45609 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
45611 ELSEIF (MUPDA.EQ.5) THEN
45612 C...Zero block read flags
45619 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45620 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
45621 C...Initialize program and version strings
45622 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
45627 C...Initialize read loop
45631 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45633 READ(LFN,'(A120)',END=400) CHINL
45634 C...Count which line number we're at.
45636 WRITE(CHNLIN,'(I6)') NLINE
45638 C...Skip comment and empty lines without processing.
45639 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
45641 C...We assume all upper case below. Rewrite CHINL to all upper case.
45645 IF (CHINL(INL:INL).NE.'#') THEN
45647 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
45649 C...Extra safety. Chek for sensible input on line
45650 IF (IGOOD.EQ.0) THEN
45652 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
45655 IF (INL.LT.120) GOTO 180
45657 IF (IGOOD.EQ.0) GOTO 170
45659 C...If reading from LHEF file, skip until <slha> begin tag found
45660 IF (ISKIP.NE.0) THEN
45662 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
45664 IF (ISKIP.NE.0) GOTO 170
45667 C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45669 IF (CHINL(I1:I1+5).EQ.'</SLHA'
45670 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
45671 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
45677 C...Check for BLOCK begin statement (spectrum).
45678 IF (CHINL(1:5).EQ.'BLOCK') THEN
45680 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
45681 C...Check if another of this type of block was already read.
45682 C...(logarithmic interpolation not yet implemented, so duplicates always
45684 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
45685 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
45686 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
45687 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
45688 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
45689 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
45690 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
45691 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
45692 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
45693 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
45694 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
45695 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
45696 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
45697 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
45698 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
45699 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
45700 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
45701 C...Check for new particles
45702 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45704 MSPC(19)=MSPC(19)+1
45706 READ(CHBLCK(9:60),*) KFQ
45709 IF (KQNUM(MQ,0).EQ.KFQ) THEN
45714 IF (NHELLO.EQ.0) THEN
45715 WRITE(MSTU(11),5000) DOC
45718 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45719 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
45723 MSPC(19)=MSPC(19)+1
45725 C...Only read in new codes (also OK to overwrite if KF > 3000000)
45726 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
45728 DO 230 KCT=100,MSTU(6)
45729 IF(KCHG(KCT,4).GT.100) KCQ=KCT
45735 C...First write PDG code as name
45737 WRITE(CHTMP,'(A)') CHTMP(2:10)
45738 C...Then look for real name
45741 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
45743 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
45746 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
45747 IF (IEND.LT.59) THEN
45748 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
45749 IF (CHDUM.NE.' ') CHTMP=CHDUM
45751 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
45753 C...Set stable for now
45761 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
45762 & CHAF(KCQ,1), '. Entry ignored.'
45766 C...Finalize this line and read next.
45768 C...Check for DECAY begin statement (decays).
45769 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
45773 C...Read KF code and WIDTH
45775 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
45780 C...If this is not the KF we're looking for...
45781 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
45782 C...Set block skip flag and read next line.
45786 C...Check whether decay table for this particle already read in
45787 DO 280 IDECAY=1,NDECAY
45788 IF (KFDEC(IDECAY).EQ.KF) THEN
45789 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
45790 & ' * (PYSLHA:) Ignoring DECAY table ',
45791 & 'for KF =',KF,' on line ',CHNLIN,
45799 C...Determine PYTHIA KC code of particle
45805 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
45809 IF (KCREP.NE.0) THEN
45810 C...Particle is already known. Do not overwrite low-mass SM particles,
45811 C...since this could give problems at hadronization / hadron decay stage.
45812 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
45813 C...Set block skip flag and read next line
45814 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45815 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45816 & KF, ' (SLHA read-in not allowed)'
45821 C... Add new particle. Actually, this should not happen.
45822 C... New particles should be added already when reading the spectrum
45823 C... information, so go under previously stable category.
45828 IF (WIDTH.LE.0D0) THEN
45829 C...Stable (i.e. LSP)
45830 WRITE(MSTU(11),'(A,I9,A,A)')
45831 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
45832 & KF,', ',CHAF(KCREP,1)(1:16)
45833 IF (WIDTH.LT.0D0) THEN
45834 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
45841 C...Ignore any decay lines that may be present for this KF
45848 C...Finalize and start reading in decay modes.
45850 ELSEIF (MOD(MERR,10).GE.6) THEN
45851 C...If ignore block flag set, skip directly to next line.
45856 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
45857 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45859 READ(CHINL,*) INDX, IVAL
45860 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
45861 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
45862 IF (INDX.EQ.3) KCHG(KCQ,2)=0
45863 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
45864 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
45865 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
45866 IF (INDX.EQ.4) THEN
45868 IF (IVAL.EQ.1) THEN
45870 IF (CHTMP.EQ.' ') THEN
45871 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
45872 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
45876 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
45877 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
45878 CHTMP(ILAST:ILAST)='-'
45880 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
45889 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
45890 C...MASS: Mass spectrum
45891 IF (CHBLCK(1:4).EQ.'MASS') THEN
45892 READ(CHINL,*) KF, VAL
45895 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
45896 C...Read in masses for almost anything
45900 C...Don't read in masses for special code particles
45901 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
45902 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45903 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45904 & KF, ' (KF reserved by PYTHIA)'
45907 C...Be careful with light SM particles / hadrons
45908 IF (PMAS(KC,1).LE.20D0) THEN
45909 IF (IABS(KF).LE.22) THEN
45910 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45911 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45912 & KF, ' (SLHA read-in not allowed)'
45915 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
45916 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45917 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45918 & KF, ' (SLHA read-in not allowed)'
45923 PMAS(KC,1) = ABS(VAL)
45924 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
45925 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45926 & ' * (PYSLHA:) Reading MASS entry for KF =',
45927 & KF, ', pole mass =', VAL
45930 C...Check Z, W and top masses
45931 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
45933 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45934 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
45937 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
45939 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45940 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
45943 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
45945 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45946 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
45950 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
45951 IF (KF.EQ.1000022) SMZ(1)=VAL
45952 IF (KF.EQ.1000023) SMZ(2)=VAL
45953 IF (KF.EQ.1000025) SMZ(3)=VAL
45954 IF (KF.EQ.1000035) SMZ(4)=VAL
45955 IF (KF.EQ.1000024) SMW(1)=VAL
45956 IF (KF.EQ.1000037) SMW(2)=VAL
45958 ELSEIF (MUPDA.EQ.5) THEN
45961 C... MODSEL: Model selection and global switches
45962 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
45963 READ(CHINL,*) INDX, IVAL
45964 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45965 IF (IMSS(1).EQ.0) IMSS(1)=11
45968 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45969 C... Switch on NMSSM
45970 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45971 IMSS(13)=MAX(1,IMSS(13))
45972 C... Add NMSSM states if not already done
46002 DO 310 KCT=100,MSTU(6)
46003 IF(KCHG(KCT,4).GT.100) KCN=KCT
46009 C... Set stable for now
46015 CHAF(KCN,1)='~chi_50'
46021 ELSEIF (MUPDA.EQ.5) THEN
46022 C...If MUPDA = 5, skip all except MASS, return if MODSEL
46024 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46025 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46026 C...Don't print a warning for QNUMBERS when reading spectrum
46028 C...MINPAR: Minimal model parameters
46029 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46030 READ(CHINL,*) INDX, VAL
46031 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46037 IF (MMOD(3).NE.0) THEN
46039 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46043 IF (INDX.EQ.3) RMSS(5)=VAL
46044 C...EXTPAR: non-minimal model parameters.
46045 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46046 IF (MMOD(1).NE.0) THEN
46047 READ(CHINL,*) INDX, VAL
46048 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46056 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46060 IF (INDX.EQ.25) RMSS(5)=VAL
46061 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46062 READ(CHINL,*) INDX, VAL
46063 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46065 ELSEIF (INDX.EQ.4) THEN
46066 PMAS(PYCOMP(23),1)=VAL
46067 ELSEIF (INDX.EQ.6) THEN
46068 PMAS(PYCOMP(6),1)=VAL
46070 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46071 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46072 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46074 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46076 IF (CHBLCK(5:6).EQ.'IM') IM=1
46077 320 READ(CHINL,*) INDX1, INDX2, VAL
46078 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46079 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46080 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46082 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46083 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46084 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46086 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46087 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46088 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46090 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46091 $ .CHBLCK(1:4).EQ.'STAU') THEN
46092 IF (CHBLCK(1:4).EQ.'STOP') THEN
46095 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46098 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46102 C...Set SFMIX element
46103 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46104 MSPC(ISPC)=MSPC(ISPC)+1
46106 C...Running parameters
46107 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46108 READ(CHBLCK(8:25),*,ERR=620) Q
46109 READ(CHINL,*) INDX, VAL
46111 IF (INDX.EQ.1) THEN
46117 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46118 READ(CHINL,*,ERR=630) VAL
46120 MSPC(17)=MSPC(17)+1
46121 C...Higgs parameters set manually or with FeynHiggs.
46122 IMSS(4)=MAX(2,IMSS(4))
46123 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46124 & .CHBLCK(1:2).EQ.'AE') THEN
46125 READ(CHBLCK(9:26),*,ERR=620) Q
46126 READ(CHINL,*) INDX1, INDX2, VAL
46127 IF (CHBLCK(2:2).EQ.'U') THEN
46128 AU(INDX1,INDX2)=VAL
46129 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46130 MSPC(11)=MSPC(11)+1
46131 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46132 AD(INDX1,INDX2)=VAL
46133 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46134 MSPC(10)=MSPC(10)+1
46135 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46136 AE(INDX1,INDX2)=VAL
46137 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46138 MSPC(12)=MSPC(12)+1
46142 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46143 IF (MSPC(18).EQ.0) THEN
46144 READ(CHBLCK(9:25),*,ERR=620) Q
46147 READ(CHINL,*) INDX, VAL
46149 MSPC(18)=MSPC(18)+1
46150 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46152 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46153 & .CHBLCK(1:2).EQ.'YE') THEN
46155 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46156 READ(CHINL(1:6),*) INDX
46160 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46161 C...Don't read index
46162 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46166 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46167 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46169 C... Set unrecognized block flag.
46174 C...Read in decay information
46175 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46176 C...Read new decay chanel
46177 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46179 C...Read in branching ratio and number of daughters for this mode.
46180 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46181 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46183 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46184 & '(PYSLHA:) Decay data arrays full by KF = '
46186 C...If first decay channel, set decays start point in decay table
46187 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46188 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46189 & '* (PYSLHA:) Reading DECAY table for '//
46190 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46191 C...Set particle parameters (mass set when reading BLOCK MASS above)
46193 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46194 WRITE(MSTU(11),'(1x,A)')
46195 & '* Note: the Pythia gg->h/H/A cross section'//
46196 & ' is proportional to the h/H/A->gg width'
46197 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46198 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46199 WRITE(MSTU(11),'(1x,A,A16)')
46200 & '* Warning: will use DECAY table (fixed-width,'//
46201 & ' flat PS) for ',CHAF(KC,1)(1:16)
46204 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46209 C...Add to list of DECAY blocks currently read
46215 C... Count up number of decay modes for this particle
46216 MDCY(KC,3)=MDCY(KC,3)+1
46217 C... Read in decay daughters.
46218 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46219 C... Flip sign if reading antiparticle decays (if antipartner exists)
46221 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46222 & IDC(IDA)=MPSIGN*IDC(IDA)
46224 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46226 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46227 BRSUM=BRSUM+ABS(BRAT(NDC))
46228 BRAT(NDC)=ABS(BRAT(NDC))
46231 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46233 IDC(IDA)=IDC(IDA+1)
46238 IF (IFLIP.GT.0) GOTO 350
46239 C...Treat as ordinary decay, no fancy stuff.
46242 IF (IDA.LE.NDA) THEN
46243 KFDP(NDC,IDA)=IDC(IDA)
46248 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46249 C & (KFDP(NDC,J),J=1,NDA)
46251 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
46256 ELSEIF(CHINL(1:1).EQ.'+') THEN
46258 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
46265 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
46266 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
46269 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
46270 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46271 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
46272 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
46273 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46274 & //CHBLCK(1:INL)//'... on line'//CHNLIN
46275 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
46276 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
46277 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
46278 & //'... on line'//CHNLIN
46279 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
46280 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46281 & /CHBLCK(1:INL)//'... on line'//CHNLIN
46282 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
46285 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46286 & CHTMP(1:9)//' on line'//CHNLIN
46288 C...Iterate read loop
46291 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
46292 & ', ignoring subsequent lines.'
46293 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
46296 C...End of read loop
46298 C...Set flag that KC codes have been rearranged.
46302 C...Perform possible tests that new information is consistent.
46303 IF (MUPDA.EQ.1) THEN
46309 C...Don't complain about right-handed neutrinos
46310 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
46312 C...Only check gravitino in GMSB scenarios
46313 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
46315 IF (PMAS(KC,1).EQ.0D0) THEN
46318 & ,'(PYSLHA:) No mass information found for KF ='
46322 C...Check mixing matrices (MSSM only)
46323 IF (IMSS(13).EQ.0) THEN
46324 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
46325 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46326 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
46327 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46328 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
46329 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46330 IF (MSPC(5).NE.4) CALL PYERRM(9
46331 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46332 IF (MSPC(6).NE.4) CALL PYERRM(9
46333 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46334 IF (MSPC(7).NE.4) CALL PYERRM(9
46335 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46336 IF (MSPC(8).LT.1) CALL PYERRM(9
46337 & ,'(PYSLHA:) Too few elements in HMIX')
46338 IF (MSPC(10).EQ.0) CALL PYERRM(9
46339 & ,'(PYSLHA:) Missing A_b trilinear coupling')
46340 IF (MSPC(11).EQ.0) CALL PYERRM(9
46341 & ,'(PYSLHA:) Missing A_t trilinear coupling')
46342 IF (MSPC(12).EQ.0) CALL PYERRM(9
46343 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46344 IF (MSPC(17).LT.1) CALL PYERRM(9
46345 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46347 C...Check wavefunction normalizations.
46350 IF (MSPC(ISPC).EQ.4) THEN
46352 IF (ISPC.EQ.7) KFSM=15
46353 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
46355 IF (ABS(1D0-CHECK).GT.1D-3) THEN
46358 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46361 C...Bug fix 30/09 2008: PS
46362 C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46363 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
46364 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
46365 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
46369 C...Neutralinos + charginos
46378 CN1=CN1+ZMIX(J,L)**2
46379 CN2=CN2+ZMIX(L,J)**2
46380 IF (J.LE.2.AND.L.LE.2) THEN
46381 CU1=CU1+UMIX(J,L)**2
46382 CU2=CU2+UMIX(L,J)**2
46383 CV1=CV1+VMIX(J,L)**2
46384 CV2=CV2+VMIX(L,J)**2
46387 C...NMIX normalization
46388 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
46389 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
46391 & '(PYSLHA:) NMIX: Inconsistent normalization.')
46392 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
46394 C...UMIX, VMIX normalizations
46395 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
46397 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
46399 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46400 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
46403 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
46405 & '(PYSLHA:) VMIX: Inconsistent normalization.')
46406 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
46412 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
46413 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
46414 & '* (PYSLHA:) No spectrum inconsistencies were found.'
46416 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46417 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46418 & ,' Warning: one or more (serious)'//
46419 & ' inconsistencies were found in the spectrum !'
46420 & ,' Read the error messages above and check your'//
46423 C...Increase precision in Higgs sector using FeynHiggs
46424 IF (IMSS(4).EQ.3) THEN
46425 C...FeynHiggs needs MSOFT.
46427 IF (MSPC(18).EQ.0) THEN
46428 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
46429 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46430 & ' Cannot call FeynHiggs.'
46433 WRITE(MSTU(11),'(1x,/1x,A/)')
46434 & '* (PYSLHA:) Now calling FeynHiggs.'
46436 IF (IERR.NE.0) IMSS(4)=2
46439 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
46441 IF (KFORIG.NE.0) IBEG=NDECAY
46442 DO 490 IDECAY=IBEG,NDECAY
46445 WRITE(CHKF,8300) KF
46446 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
46447 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
46448 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
46449 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46453 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46454 IF(MDME(IDA,2).GT.80) GOTO 460
46456 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
46460 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
46462 ELSEIF(PYCOMP(KP).EQ.0) THEN
46467 PMS=PMS-PMAS(KPC,1)
46468 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
46472 IF(KQ.NE.0) MERR=MAX(2,MERR)
46473 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
46475 IF(MERR.EQ.3) CALL PYERRM(17,
46476 & '(PYSLHA:) Unknown particle code in decay of KF ='
46478 IF(MERR.EQ.2) CALL PYERRM(17,
46479 & '(PYSLHA:) Charge not conserved in decay of KF ='
46481 IF(MERR.EQ.1) CALL PYERRM(7,
46482 & '(PYSLHA:) Kinematically unallowed decay of KF ='
46484 BRSUM=BRSUM+BRAT(IDA)
46485 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
46487 C...Check branching ratio sum.
46488 IF (BROPN.LE.0D0) THEN
46489 C...If zero, set stable.
46490 WRITE(CHTMP,8500) BROPN
46492 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
46493 & CHTMP(9:16)//'. Changed to stable.')
46496 C...If BR's > 1, rescale.
46497 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
46498 WRITE(CHTMP,8500) BRSUM
46499 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
46500 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
46501 & ' ; sum was'//CHTMP(9:16)//'.')
46503 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46504 IF(MDME(IDA,2).GT.80) GOTO 470
46505 BRAT(IDA)=FAC*BRAT(IDA)
46507 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
46508 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46509 WRITE(CHTMP,8500) BRSUM
46510 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
46511 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
46512 & CHTMP(9:16)//'. Dummy mode will be inserted.')
46513 C...Move table and insert dummy mode
46514 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46516 BRAT(NDC)=BRAT(IDA)
46517 KFDP(NDC,1)=KFDP(IDA,1)
46518 KFDP(NDC,2)=KFDP(IDA,2)
46519 KFDP(NDC,3)=KFDP(IDA,3)
46520 KFDP(NDC,4)=KFDP(IDA,4)
46521 KFDP(NDC,5)=KFDP(IDA,5)
46522 MDME(NDC,1)=MDME(IDA,1)
46525 BRAT(NDC)=1D0-BRSUM
46534 MDCY(KC,3)=MDCY(KC,3)+1
46535 MDCY(KC,2)=NDC-MDCY(KC,3)+1
46541 C...WRITE SPECTRUM ON SLHA FILE
46542 ELSEIF(MUPDA.EQ.3) THEN
46543 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46544 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
46549 PARMIN(4)=SIGN(1D0,RMSS(4))
46553 WRITE(LFN,7000) 'SLHA MSSM spectrum'
46554 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46556 WRITE(LFN,7010) 'MODSEL', 'Model selection'
46557 WRITE(LFN,7110) 1, MODSEL(1)
46558 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
46559 IF (MODSEL(1).EQ.1) THEN
46560 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
46561 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
46562 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46563 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46564 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
46565 ELSEIF(MODSEL(2).EQ.2) THEN
46566 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
46567 WRITE(LFN,7210) 2, PARMIN(2), 'M'
46568 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46569 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46570 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
46571 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
46573 WRITE(LFN,7000) ' '
46574 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
46578 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
46580 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
46581 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
46582 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
46583 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
46584 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
46585 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
46586 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
46588 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
46592 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
46593 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
46594 WRITE(LFN,7210) 1, RMSS(4),'mu'
46595 WRITE(LFN,7010) 'ALPHA',' '
46596 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
46597 WRITE(LFN,7020) 'AU',RMSUSY
46598 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
46599 WRITE(LFN,7020) 'AD',RMSUSY
46600 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
46601 WRITE(LFN,7020) 'AE',RMSUSY
46602 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
46603 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
46604 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
46605 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
46606 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
46607 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
46608 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
46609 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
46610 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
46611 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
46612 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
46613 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
46614 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
46615 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
46616 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
46617 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
46618 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
46621 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
46624 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
46627 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
46630 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
46633 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
46636 WRITE(LFN,7010) 'SPINFO'
46637 IF (IMSS(1).EQ.2) THEN
46640 ELSEIF (IMSS(1).EQ.12) THEN
46643 CVER(1)=ISAVER(1:12)
46645 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
46646 WRITE(LFN,7310) 2, CVER(1), 'Version number'
46649 C...Print user information about spectrum
46650 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
46651 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
46652 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
46653 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
46654 IF (MUPDA.EQ.1) THEN
46655 WRITE(MSTU(11),5020) LFN
46657 WRITE(MSTU(11),5010) LFN
46660 WRITE(MSTU(11),5400)
46661 WRITE(MSTU(11),5500) 'Pole masses'
46662 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
46663 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
46664 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
46665 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
46666 IF (IMSS(13).EQ.0) THEN
46667 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
46668 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
46669 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
46670 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
46671 & CHAF(37,1), ' ', ' ',' ',' ',
46672 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
46673 ELSEIF (IMSS(13).EQ.1) THEN
46682 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
46683 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
46684 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
46685 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
46686 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
46687 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
46688 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
46689 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
46690 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
46693 WRITE(MSTU(11),5400)
46694 WRITE(MSTU(11),5500) 'Mixing structure'
46695 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46696 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46697 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46698 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46699 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46700 & ),(SFMIX(15,J),J=3,4)
46701 WRITE(MSTU(11),5400)
46702 WRITE(MSTU(11),5500) 'Couplings'
46703 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
46704 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
46705 WRITE(MSTU(11),5400)
46706 WRITE(MSTU(11),6500)
46710 C...Only rewind when reading
46711 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
46715 C...Serious error catching
46716 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
46717 write(*,*) CHINL(1:80)
46719 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
46720 WRITE(*,*) CHINL(1:72)
46722 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
46723 WRITE(*,*) CHINL(1:80)
46725 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
46726 WRITE(*,*) CHINL(1:80)
46727 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
46729 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
46730 WRITE(*,*) CHINL(1:80)
46736 C...Formats for user information printout.
46737 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.13: SUSY/BSM SPECTRUM '
46738 & ,'INTERFACE',1x,17('*')/1x,'*',1x
46739 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
46740 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
46741 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
46742 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
46743 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46744 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46745 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46746 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46747 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46748 & ,'----------------')
46749 5400 FORMAT(1x,'*',1x,A)
46750 5500 FORMAT(1x,'*',1x,A,':')
46751 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46752 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46753 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46754 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46755 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46756 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46757 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46758 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46759 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46760 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46761 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46762 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
46763 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46764 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46765 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46766 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46767 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46768 & ,1x,F6.3,1x),'|')
46769 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46770 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46771 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46772 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46773 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46774 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46775 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46776 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46777 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46778 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46779 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46780 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46781 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
46782 & ,'A_tau = ',F8.2)
46783 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
46785 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46787 C...Format to use for comments
46788 7000 FORMAT('# ',A)
46789 C...Format to use for block statements
46790 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
46791 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
46793 7110 FORMAT(1x,I4,1x,I4,3x,'#')
46794 C...Non-Indexed Double
46795 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
46797 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
46798 C...Long Indexed Double (PDG + double)
46799 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
46800 C...Indexed Char(12)
46801 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
46803 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
46805 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
46806 C...Write Decay Table
46807 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
46808 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
46814 C*********************************************************************
46817 C...Uses approximate analytical formulae to determine the full set of
46818 C...MSSM parameters from SUGRA input.
46819 C...See M. Drees and S.P. Martin, hep-ph/9504124
46823 C...Double precision and integer declarations.
46824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46825 IMPLICIT INTEGER(I-N)
46826 INTEGER PYK,PYCHGE,PYCOMP
46827 C...Parameter statement to help give large particle numbers.
46828 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46829 &KEXCIT=4000000,KDIMEN=5000000)
46831 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46832 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46833 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46834 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
46836 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46837 &' not intended for serious physics studies'
46850 C...Temporary sign change for AT. Others unchanged.
46854 SINB=TANB/SQRT(TANB**2+1D0)
46857 DTERM=XMZ2*COS(2D0*BETA)
46858 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
46859 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
46862 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
46863 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
46864 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
46865 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
46867 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
46868 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
46869 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
46870 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
46872 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
46873 IF(XARG.LT.0D0) THEN
46874 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46875 & ' FROM THE SUM RULE. '
46876 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46882 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
46883 PMAS(PYCOMP(KSUSY2+I),1)=XMER
46884 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
46885 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
46887 RMT=PYMRUN(6,PMAS(6,1)**2)
46888 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
46889 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
46890 RMB=PYMRUN(5,PMAS(6,1)**2)
46891 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
46892 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
46893 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
46894 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
46897 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
46898 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
46899 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
46900 XMU=SIGN(SQRT(XMU2),RMSS(4))
46902 IF(XMA2.GT.0D0) THEN
46903 RMSS(19)=SQRT(XMA2)
46905 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46908 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
46909 IF(ARG.GT.0D0) THEN
46912 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46915 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
46916 IF(ARG.GT.0D0) THEN
46919 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46922 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
46923 IF(ARG.GT.0D0) THEN
46926 RMSS(10)=-SQRT(-ARG)
46928 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
46929 IF(ARG.GT.0D0) THEN
46932 RMSS(12)=-SQRT(-ARG)
46934 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
46935 IF(ARG.GT.0D0) THEN
46938 RMSS(11)=-SQRT(-ARG)
46944 C*********************************************************************
46947 C...Interface to ISASUSY version 7.71.
46948 C...Warning: this interface should not be used with earlier versions
46949 C...of ISASUSY, since common block incompatibilities may then arise.
46950 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46951 C...Then converts to Gunion-Haber conventions.
46954 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46956 INTEGER PYK,PYCHGE,PYCOMP
46957 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46958 &KEXCIT=4000000,KDIMEN=5000000)
46962 PARAMETER (DOC='01 May 2006')
46964 C...ISASUGRA Input:
46965 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46966 C...XISAIN contains the MSSMi inputs in natural order.
46967 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
46969 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46971 C...ISASUGRA Output
46972 CHARACTER*40 ISAVER,VISAJE
46974 COMMON /SSPAR/ SUPER(72)
46975 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46976 $FBGUT,FTAGUT,FNGUT
46977 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46978 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46979 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46980 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46981 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46982 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46983 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46984 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46985 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46987 SAVE /SUGMG/,/SSPAR/
46988 C SUPER: Filled by ISASUGRA.
46989 C SUPER(1) = mass of ~g
46990 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46991 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46992 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46994 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46995 C SUPER(29) = Higgsino mass = - mu
46996 C SUPER(30) = ratio v2/v1 of vev's
46997 C SUPER(31:34) = Signed neutralino masses
46998 C SUPER(35:50) = Neutralino mixing matrix
46999 C SUPER(51:52) = Signed chargino masses
47000 C SUPER(53:54) = Chargino left, right mixing angles
47001 C SUPER(55:58) = mass of h0, H0, A0, H+
47002 C SUPER(59) = Higgs mixing angle alpha
47003 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
47004 C SUPER(66) = Gravitino mass
47005 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
47006 C SUPER(70) = b-Yukawa at mA scale (not used)
47007 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47008 C GSS: Filled by ISASUGRA
47009 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47010 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47011 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47012 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47013 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47014 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47015 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47016 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47017 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47018 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47019 C GSS(31) = log(vuq)
47020 C MSS: Filled by ISASUGRA
47021 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47022 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47023 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47024 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47025 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47026 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47027 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47028 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47029 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47030 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47031 C MSS(31) = ha0 MSS(32) = h+
47032 C Unification, filled by ISASUGRA if applicable.
47033 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47035 C...SPYTHIA Input/Output
47037 DOUBLE PRECISION RMSS
47038 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47039 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47040 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47041 C...SLHA Input/Output
47042 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47043 & AU(3,3),AD(3,3),AE(3,3)
47044 C...PYTHIA common blocks
47045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47046 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47047 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47049 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47053 CHARACTER*20 CHMOD(5)
47056 COMMON /SUGNU/ XNUSUG(18)
47060 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47061 & 'truly unified SUGRA', 'non-minimal GMSB'/
47063 C...Start by checking for incompatibilities/inconsistencies:
47065 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47066 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47067 & ,' option not used by PYSUGI'
47070 C...ISAJET works with REAL numbers.
47071 MZERO=REAL(RMSS(8))
47073 AZERO=REAL(RMSS(16))
47075 SGNMU=REAL(RMSS(4))
47076 MTOP=REAL(PMAS(6,1))
47078 IF (IMSS(1).EQ.12) THEN
47081 ELSEIF(IMSS(1).EQ.13) THEN
47082 C...Read from isajet par file in IMSS(20)
47084 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47086 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47089 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47090 CMrenna change to allow any susy model
47091 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47092 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47093 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47094 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47095 & ' gauge couplings:'
47096 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47098 IF (IMODEL.EQ.4) THEN
47102 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47103 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47104 & //' sgn(mu), M_t:'
47105 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47106 IF (IMODEL.EQ.3) THEN
47108 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47109 & //' 0 to continue:'
47110 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47111 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47112 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47113 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47114 & //' generation masses'
47116 & ' NUSUG5 = GUT scale 3rd generation masses'
47118 IF (INUSUG.EQ.0) THEN
47120 ELSEIF (INUSUG.EQ.1) THEN
47121 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47122 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47123 IF (XNUSUG(3).LE.0.) THEN
47124 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47127 ELSEIF (INUSUG.EQ.2) THEN
47128 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47129 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47130 ELSEIF (INUSUG.EQ.3) THEN
47131 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47132 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47133 ELSEIF (INUSUG.EQ.4) THEN
47134 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47135 & //' M(ur), M(el), M(er):'
47136 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47137 & XNUSUG(10),XNUSUG(9)
47138 ELSEIF (INUSUG.EQ.5) THEN
47139 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47140 & //' M(Ll), M(Lr):'
47141 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47142 & XNUSUG(15),XNUSUG(14)
47146 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47148 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47149 & ,' sgn(mu), M_t, C_gv:'
47150 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47153 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47155 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47156 IF (IMODEL.EQ.5) THEN
47158 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47159 & ,' masses at M_mes'
47160 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47161 & ,' shifts at M_mes'
47162 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47164 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47166 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47168 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47169 $ XGMIN(13),XGMIN(14)
47172 WRITE(MSTU(11),*) 'Invalid model choice.'
47180 C TANB=REAL(RMSS(5))
47181 C SGNMU=REAL(RMSS(4))
47184 C...Initialize MSSM parameter array
47185 130 DO 140 IPAR=1,72
47189 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47190 C...Check whether ISASUSY thought the model was OK.
47191 IF (NOGOOD.NE.0) THEN
47192 IF (NOGOOD.EQ.1) CALL PYERRM(26
47193 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47194 IF (NOGOOD.EQ.2) CALL PYERRM(26
47195 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47196 IF (NOGOOD.EQ.3) CALL PYERRM(26
47197 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47198 IF (NOGOOD.EQ.4) CALL PYERRM(26
47199 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47200 IF (NOGOOD.EQ.7) CALL PYERRM(26
47201 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47202 IF (NOGOOD.EQ.8) CALL PYERRM(26
47203 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47204 C...Give warning, but don't stop, if LSP not ~chi_10.
47205 IF (NOGOOD.EQ.5) CALL PYERRM(16
47206 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47208 C...Warn about possible GUT scale tachyons.
47209 IF (ITACHY.NE.0) CALL PYERRM(16,
47210 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47211 C...Finalize spectrum (last iteration)
47212 C...(Thanks to A. Raklev for pointing this out.)
47213 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47214 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
47215 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
47216 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
47217 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
47218 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
47222 RMSS(1)=dble(GSS(7))
47223 RMSS(2)=dble(GSS(8))
47224 RMSS(3)=dble(GSS(9))
47225 RMSOFT(1)=dble(GSS(7))
47226 RMSOFT(2)=dble(GSS(8))
47227 RMSOFT(3)=dble(GSS(9))
47228 C...Mu = - Higgsino mass.
47231 C...Slepton and squark masses. 2 first generations.
47232 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
47233 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
47234 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
47235 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
47236 C...Third generation.
47237 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
47242 C...SLHA: store exact soft spectrum in RMSOFT
47243 RMSOFT(31)=SUPER(18)
47244 RMSOFT(32)=SUPER(20)
47245 RMSOFT(33)=SUPER(22)
47246 RMSOFT(34)=SUPER(19)
47247 RMSOFT(35)=SUPER(21)
47248 RMSOFT(36)=SUPER(23)
47249 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
47250 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
47251 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
47252 RMSOFT(44)=SUPER(3)
47253 RMSOFT(45)=SUPER(9)
47254 RMSOFT(46)=SUPER(15)
47255 RMSOFT(47)=SUPER(5)
47256 RMSOFT(48)=SUPER(7)
47257 RMSOFT(49)=SUPER(11)
47259 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47266 C...SLHA trilinears
47277 C...Higgs mixing angle alpha (Gunion-Haber convention).
47278 RMSS(18)=-SUPER(59)
47281 C...GUT scale coupling
47283 C...Gravitino mass (for future compatibility)
47284 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
47286 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47288 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
47289 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
47290 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
47291 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
47293 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
47294 C...Squarks and Sleptons.
47297 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
47298 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
47299 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
47300 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
47301 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
47302 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
47303 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
47304 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
47305 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
47307 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
47308 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
47309 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
47311 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
47312 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
47313 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
47314 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
47315 C...Signed masses (extra minus from going to G-H convention).
47321 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
47322 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
47323 C...Signed masses (extra minus from going to G-H convention).
47327 C... Neutralino Mixing.
47329 ZMIX(IN,1)= SUPER(38+4*(IN-1))
47330 ZMIX(IN,2)= SUPER(37+4*(IN-1))
47331 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
47332 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
47334 C...Chargino Mixing (PYTHIA same angle as HERWIG).
47337 IF (SUPER(53).GT.0) THX=-1D0
47338 IF (SUPER(54).GT.0) THY=-1D0
47339 UMIX(1,1) = -SIN(SUPER(53))
47340 UMIX(1,2) = -COS(SUPER(53))
47341 UMIX(2,1) = -THX*COS(SUPER(53))
47342 UMIX(2,2) = THX*SIN(SUPER(53))
47343 VMIX(1,1) = -SIN(SUPER(54))
47344 VMIX(1,2) = -COS(SUPER(54))
47345 VMIX(2,1) = -THY*COS(SUPER(54))
47346 VMIX(2,2) = THY*SIN(SUPER(54))
47347 C...Sfermion mixing (PYTHIA same angle as ISAJET)
47348 SFMIX(5,1)=COS(SUPER(63))
47349 SFMIX(5,2)=SIN(SUPER(63))
47350 SFMIX(5,3)=-SIN(SUPER(63))
47351 SFMIX(5,4)=COS(SUPER(63))
47352 SFMIX(6,1)=COS(SUPER(61))
47353 SFMIX(6,2)=SIN(SUPER(61))
47354 SFMIX(6,3)=-SIN(SUPER(61))
47355 SFMIX(6,4)=COS(SUPER(61))
47356 SFMIX(15,1)=COS(SUPER(65))
47357 SFMIX(15,2)=SIN(SUPER(65))
47358 SFMIX(15,3)=-SIN(SUPER(65))
47359 SFMIX(15,4)=COS(SUPER(65))
47361 IF (MSTP(122).NE.0) THEN
47362 C...Print a few lines to make the user know what's happening
47364 WRITE(MSTU(11),5000) DOC, ISAVER
47365 WRITE(MSTU(11),5100)
47366 IF (IMODEL.EQ.1) THEN
47367 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
47369 WRITE(MSTU(11),5300)
47371 WRITE(MSTU(11),5500) 'Pole masses'
47372 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
47373 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
47374 & ,(SUPER(IP),IP=19,25,2)
47375 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
47377 WRITE(MSTU(11),5400)
47378 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
47379 WRITE(MSTU(11),5400)
47380 WRITE(MSTU(11),5500) 'EW scale mixing structure'
47381 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47382 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47383 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47384 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47385 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47386 & ),(SFMIX(15,J),J=3,4)
47387 WRITE(MSTU(11),5400)
47388 WRITE(MSTU(11),6450) RMSS(18)
47389 WRITE(MSTU(11),5400)
47390 WRITE(MSTU(11),5500) 'Couplings'
47391 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
47392 WRITE(MSTU(11),5400)
47395 C...Call FeynHiggs to improve Higgs sector if requested
47396 IF (IMSS(4).EQ.3) THEN
47397 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
47398 & ' (PYSUGI:) Now calling FeynHiggs.'
47400 IF (IERR.EQ.0) THEN
47402 IF (MSTP(122).NE.0) THEN
47403 WRITE(MSTU(11),5400)
47404 WRITE(MSTU(11),5500)
47405 & 'Corrected Higgs masses and mixing'
47406 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
47408 WRITE(MSTU(11),6450) RMSS(18)
47409 WRITE(MSTU(11),5400)
47414 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
47416 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47417 C...output by ISASUSY.
47418 IMSS(4)=MAX(2,IMSS(4))
47420 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47421 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
47422 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
47423 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47424 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47425 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47426 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47427 & ,'----------------')
47428 5400 FORMAT(1x,'*',1x,A)
47429 5500 FORMAT(1x,'*',1x,A,':')
47430 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47431 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47432 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47433 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47434 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
47436 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47437 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47438 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
47440 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47441 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47442 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47443 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47444 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
47445 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47446 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
47447 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47448 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47449 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47450 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47451 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47452 & ,1x,F6.3,1x),'|')
47453 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47454 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47455 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47456 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47457 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47458 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47459 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47460 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47461 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47462 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47463 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47464 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47465 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
47466 & ,4x,'Alpha_GUT = ',F8.2)
47467 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
47468 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47473 C*********************************************************************
47476 C...Interface to FeynHiggs for MSSM Higgs sector.
47477 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47480 SUBROUTINE PYFEYN(IERR)
47482 C...Double precision and integer declarations.
47483 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47484 IMPLICIT INTEGER(I-N)
47485 INTEGER PYK,PYCHGE,PYCOMP
47487 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47488 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47490 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47491 C...FeynHiggs variables
47492 DOUBLE PRECISION RMHIGG(4)
47493 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47494 DOUBLE COMPLEX DMU,
47495 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47497 C...SLHA Common Block
47498 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47499 & AU(3,3),AD(3,3),AE(3,3)
47500 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
47503 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
47504 IF (IERR.NE.0) THEN
47505 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47506 & //'Will not use FeynHiggs for this run.')
47544 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
47545 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
47546 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
47547 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
47548 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47549 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
47550 IF (IERR.NE.0) THEN
47551 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
47552 & //' Will not use FeynHiggs for this run.')
47555 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47557 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
47558 IF (IERR.NE.0) THEN
47559 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
47560 & 'GSCORR. Will not use FeynHiggs for this run.')
47563 ALPHA = ASIN(DBLE(SAEFF))
47565 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
47566 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47567 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
47568 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
47570 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
47571 & 1.15D0*PMAS(25,1)) THEN
47572 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47573 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
47574 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
47577 PMAS(25,1)=RMHIGG(1)
47578 PMAS(35,1)=RMHIGG(2)
47579 PMAS(36,1)=RMHIGG(3)
47580 PMAS(37,1)=RMHIGG(4)
47585 C*********************************************************************
47588 C...Determines the running mass of Squarks.
47590 FUNCTION PYRNMQ(ID,DTERM)
47592 C...Double precision and integer declarations.
47593 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47594 IMPLICIT INTEGER(I-N)
47595 INTEGER PYK,PYCHGE,PYCOMP
47597 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47600 C...Local variables.
47601 DOUBLE PRECISION PI,R
47602 DOUBLE PRECISION TOL
47603 DOUBLE PRECISION CI(3)
47605 DOUBLE PRECISION PYALPS
47607 DATA PI,R/3.141592654D0,.61803399D0/
47608 DATA CI/0.47D0,0.07D0,0.02D0/
47612 AG=(0.71D0)**2/4D0/PI
47619 AS=PYALPS(XM02+6D0*XMG2)
47620 CG=8D0/9D0*((AS/AG)**2-1D0)
47621 BX=XM02+(CA+CG)*XMG2+DTERM
47622 AX=MIN(50D0**2,0.5D0*BX)
47623 CX=MAX(2000D0**2,2D0*BX)
47627 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47635 CG=8D0/9D0*((AS1/AG)**2-1D0)
47636 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47638 CG=8D0/9D0*((AS2/AG)**2-1D0)
47639 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47640 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47647 CG=8D0/9D0*((AS2/AG)**2-1D0)
47648 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47655 CG=8D0/9D0*((AS1/AG)**2-1D0)
47656 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47671 C*********************************************************************
47674 C...Calculates the mass eigenstates of the third generation sfermions.
47675 C...Created: 5-31-96
47679 C...Double precision and integer declarations.
47680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47681 IMPLICIT INTEGER(I-N)
47682 INTEGER PYK,PYCHGE,PYCOMP
47683 C...Parameter statement to help give large particle numbers.
47684 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47685 &KEXCIT=4000000,KDIMEN=5000000)
47687 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47688 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47689 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47690 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47691 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47692 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47694 C...Local variables.
47695 DOUBLE PRECISION BETA
47696 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47697 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47698 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47699 DOUBLE PRECISION ATR,AMQR,AMQL
47700 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47701 INTEGER IF,I,J,II,JJ,IT,L
47715 COS2B=COS(2D0*BETA)
47717 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47727 XMQL2=CTT2*XM12+STT2*XM22
47728 XMQR2=STT2*XM12+CTT2*XM22
47729 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
47730 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47732 C......SUBTRACT OUT D-TERM AND FERMION MASS
47733 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
47734 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
47735 IF(XMQL2.GE.0D0) THEN
47736 RMSS(10)=SQRT(XMQL2)
47738 RMSS(10)=-SQRT(-XMQL2)
47740 IF(XMQR2.GE.0D0) THEN
47741 RMSS(12)=SQRT(XMQR2)
47743 RMSS(12)=-SQRT(-XMQR2)
47746 C SAME FOR BOTTOM SQUARK
47752 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
47753 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
47754 IF(ABS(CTT).GE..9999D0) THEN
47757 ELSEIF(ABS(CTT).LE.1D-4) THEN
47761 XM12=(XMQL2-STT2*XM22)/CTT2
47762 XMQR2=STT2*XM12+CTT2*XM22
47763 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47766 C......SUBTRACT OUT D-TERM AND FERMION MASS
47767 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
47768 IF(XMQR2.GE.0D0) THEN
47769 RMSS(11)=SQRT(XMQR2)
47771 RMSS(11)=-SQRT(-XMQR2)
47773 C SAME FOR TAU SLEPTON
47780 XMQL2=CTT2*XM12+STT2*XM22
47781 XMQR2=STT2*XM12+CTT2*XM22
47784 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47786 C......SUBTRACT OUT D-TERM AND FERMION MASS
47787 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
47788 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
47789 IF(XMQL2.GE.0D0) THEN
47790 RMSS(13)=SQRT(XMQL2)
47792 RMSS(13)=-SQRT(-XMQL2)
47794 IF(XMQR2.GE.0D0) THEN
47795 RMSS(14)=SQRT(XMQR2)
47797 RMSS(14)=-SQRT(-XMQR2)
47802 IF(AMQL.LT.0D0) THEN
47809 IF(AMQR.LT.0D0) THEN
47815 XMF=PYMRUN(IF,PMAS(6,1)**2)
47817 AM2(1,1)=XMQL2+XMF2
47818 AM2(2,2)=XMQR2+XMF2
47819 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
47822 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
47823 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
47824 AM2(1,2)=XMF*(ATR+XMU*TANB)
47825 ELSEIF(L.EQ.2) THEN
47826 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
47827 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
47828 AM2(1,2)=XMF*(ATR+XMU/TANB)
47829 ELSEIF(L.EQ.3) THEN
47830 IF(IMSS(8).EQ.1) THEN
47831 AM2(1,1)=RMSS(6)**2
47832 AM2(2,2)=RMSS(7)**2
47837 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
47838 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
47839 AM2(1,2)=XMF*(ATR+XMU*TANB)
47844 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
47845 IF(DETM.LT.0D0) THEN
47846 WRITE(MSTU(11),*) ID2(L),DETM,AM2
47847 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47849 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
47850 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
47854 IF(XMF22-XMF12.GT.0D0) THEN
47855 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
47857 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
47858 & AM2(1,2)/(XMF22-XMF12))
47874 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
47880 IF(DI(1,1).GT.DI(2,2)) THEN
47881 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
47882 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
47883 WRITE(MSTU(11),*) AM2
47884 WRITE(MSTU(11),*) DI
47885 WRITE(MSTU(11),*) RT
47896 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
47897 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47898 & ' OFF DIAGONAL ELEMENTS '
47899 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
47900 WRITE(MSTU(11),*) DI
47901 WRITE(MSTU(11),*) ' ROTATION = ',RT
47903 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
47904 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47905 & ' NEGATIVE MASSES '
47908 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
47909 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
47910 SFMIX(IF,1)=RT(1,1)
47911 SFMIX(IF,2)=RT(1,2)
47912 SFMIX(IF,3)=RT(2,1)
47913 SFMIX(IF,4)=RT(2,2)
47916 C.....TAU SNEUTRINO MASS...L=3
47918 XARG=AM2(1,1)+XMW2*COS2B
47919 IF(XARG.LT.0D0) THEN
47920 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47921 & ' FROM THE SUM RULE. '
47922 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47925 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
47930 C*********************************************************************
47933 C...Finds the mass eigenstates and mixing matrices for neutralinos
47938 C...Double precision and integer declarations.
47939 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47940 IMPLICIT INTEGER(I-N)
47942 C...Parameter statement to help give large particle numbers.
47943 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47944 &KEXCIT=4000000,KDIMEN=5000000)
47946 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47947 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47948 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47949 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47950 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47951 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47953 C...Local variables.
47954 DOUBLE PRECISION XMW,XMZ,XM(4)
47955 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47956 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47957 DOUBLE PRECISION COSW,SINW
47958 DOUBLE PRECISION XMU
47959 DOUBLE PRECISION TANB,COSB,SINB
47960 DOUBLE PRECISION XM1,XM2,XM3,BETA
47961 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47962 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47963 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47964 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47965 DOUBLE PRECISION PYALPS,PYALEM
47966 DOUBLE PRECISION PYRNM3
47967 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47968 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47969 DATA KFNCHI/1000022,1000023,1000025,1000035/
47972 IF(IMSS(1).EQ.2) THEN
47975 C...M1, M2, AND M3 ARE INDEPENDENT
47980 ELSEIF(IOPT.GE.1) THEN
47984 A1=AEM/(1D0-PARU(102))
47987 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47989 XM2=XM1*A2/A1*3D0/5D0
47991 ELSEIF(IOPT.EQ.3) THEN
47992 XM1=XM2*5D0/3D0*A1/A2
47997 IF(XM3.LE.0D0) THEN
47998 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
48004 IF(IMSS(3).EQ.1) THEN
48005 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48010 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48011 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48012 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48018 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48019 RM2=PMAS(I,1)**2/XM3**2
48020 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48021 IF(ARG.GE.0D0) THEN
48022 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48024 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48029 ELSEIF(X0.EQ.0D0) THEN
48033 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48034 & 0.5D0*X0**2*LOG(AX0)
48035 BT=(-1D0-2D0*X0)/4D0
48040 ELSEIF(X1.EQ.0D0) THEN
48044 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48045 & X1**2*LOG(AX1)+AT
48046 BT=(-1D0-2D0*X1)/4D0+BT
48050 X0=0.5D0*(1D0+RM2-RM1)
48051 Y0=-0.5D0*SQRT(-ARG)
48052 AMGX0=SQRT(X0**2+Y0**2)
48053 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48054 ARGX0=ATAN2(-X0,-Y0)
48055 AR1X0=ATAN2(1D0-X0,Y0)
48060 ARGX1=ATAN2(-X1,-Y1)
48061 AR1X1=ATAN2(1D0-X1,Y1)
48062 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48063 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48064 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48065 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48066 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48067 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48072 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48073 & /(2D0*PARU(2))*(15D0+AQ))
48076 C...NEUTRALINO MASSES
48082 XMZ=PMAS(23,1)/100D0
48083 XMW=PMAS(24,1)/100D0
48085 SINW=SQRT(PARU(102))
48086 COSW=SQRT(1D0-PARU(102))
48097 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48098 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48099 AR(1,1) = XM1*COS(RMSS(30))
48100 AI(1,1) = XM1*SIN(RMSS(30))
48101 AR(2,2) = XM2*COS(RMSS(31))
48102 AI(2,2) = XM2*SIN(RMSS(31))
48107 AR(1,3) = -XMZ*SINW*COSB
48109 AR(1,4) = XMZ*SINW*SINB
48111 AR(2,3) = XMZ*COSW*COSB
48113 AR(2,4) = -XMZ*COSW*SINB
48115 AR(3,4) = -XMU*COS(RMSS(33))
48116 AI(3,4) = -XMU*SIN(RMSS(33))
48117 AR(4,3) = -XMU*COS(RMSS(33))
48118 AI(4,3) = -XMU*SIN(RMSS(33))
48119 C CALL PYEIG4(AR,WR,ZR)
48120 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48121 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48122 & 'PROBLEM WITH PYEICG IN PYINOM ')
48130 IF(XM(K).LT.XM(J)) THEN
48148 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48151 S=S+ZR(J,K)**2+ZI(J,K)**2
48154 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48155 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48156 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48157 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48161 C...CHARGINO MASSES
48162 C.....Find eigenvectors of X X^*
48171 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48172 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48173 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48174 &XMU*COS(RMSS(33))*SINB)
48175 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48176 &XMU*SIN(RMSS(33))*SINB)
48177 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48178 &XMU*COS(RMSS(33))*SINB)
48179 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48180 &XMU*SIN(RMSS(33))*SINB)
48181 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48182 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48183 & 'PROBLEM WITH PYEICG IN PYINOM ')
48186 IF(WR(2).LT.WR(1)) THEN
48194 SMW(I)=SQRT(WR(K))*100D0
48197 S=S+ZR(J,K)**2+ZI(J,K)**2
48200 UMIX(I,J)=ZR(J,K)/SQRT(S)
48201 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
48202 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
48203 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
48206 C...Force chargino mass > neutralino mass
48208 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
48209 CALL PYERRM(8,'(PYINOM:) '//
48210 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48211 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
48214 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
48215 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
48217 C.....Find eigenvectors of X^* X
48228 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
48229 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
48230 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48231 &XMU*COS(RMSS(33))*COSB)
48232 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
48233 &XMU*SIN(RMSS(33))*COSB)
48234 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48235 &XMU*COS(RMSS(33))*COSB)
48236 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
48237 &XMU*SIN(RMSS(33))*COSB)
48238 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48239 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48240 & 'PROBLEM WITH PYEICG IN PYINOM ')
48243 IF(WR(2).LT.WR(1)) THEN
48253 S=S+ZR(J,K)**2+ZI(J,K)**2
48254 SIMAG=SIMAG+ZI(J,K)**2
48257 VMIX(I,J)=ZR(J,K)/SQRT(S)
48258 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
48259 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
48260 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
48264 C.....Simplify if no phases
48265 IF(SIMAG.LT.1D-6) THEN
48266 AR(1,1) = XM2*COS(RMSS(31))
48267 AR(2,2) = XMU*COS(RMSS(33))
48268 AR(1,2) = SQRT(2D0)*XMW*SINB
48269 AR(2,1) = SQRT(2D0)*XMW*COSB
48282 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
48287 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
48288 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
48289 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
48290 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
48291 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48292 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48293 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
48297 C.....Must deal with phases
48299 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
48300 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
48301 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
48302 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
48308 CAI(I,J)=CMPLX(0D0,0D0)
48316 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
48317 & CMPLX(VMIX(J,L),VMIXI(J,L))
48323 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
48324 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
48327 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48328 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48331 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48332 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48335 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48336 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48339 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48340 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48341 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48342 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48343 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
48344 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
48352 C*********************************************************************
48355 C...Calculates the running of M3, the SU(3) gluino mass parameter.
48357 FUNCTION PYRNM3(RGUT)
48359 C...Double precision and integer declarations.
48360 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48361 IMPLICIT INTEGER(I-N)
48362 INTEGER PYK,PYCHGE,PYCOMP
48364 C...Local variables.
48366 DOUBLE PRECISION TOL
48368 DOUBLE PRECISION PYALPS
48370 DATA R/0.61803399D0/
48374 BX=RGUT*PYALPS(RGUT**2)
48375 AX=MIN(50D0,BX*0.5D0)
48376 CX=MAX(2000D0,2D0*BX)
48380 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48388 F1=ABS(X1-RGUT*AS1)
48390 F2=ABS(X2-RGUT*AS2)
48391 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48398 F2=ABS(X2-RGUT*AS2)
48405 F1=ABS(X1-RGUT*AS1)
48420 C*********************************************************************
48423 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48424 C...Specific application: mixing in neutralino sector.
48426 SUBROUTINE PYEIG4(A,W,Z)
48428 C...Double precision and integer declarations.
48429 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48430 IMPLICIT INTEGER(I-N)
48431 INTEGER PYK,PYCHGE,PYCOMP
48433 C...Arrays: in call and local.
48434 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
48436 C...Coefficients of fourth-degree equation from matrix.
48437 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48438 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
48442 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
48451 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
48452 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
48453 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
48454 B0=B0+(-1D0)**(I+1)*A(1,I)*(
48455 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
48456 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
48457 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
48460 C...Coefficients of third-degree equation needed for
48461 C...separation into two second-degree equations.
48462 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48465 C0=-B1**2-B0*B3**2+4D0*B0*B2
48466 CQ=C1/3D0-C2**2/9D0
48467 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
48470 C...Cases with one or three real roots.
48471 IF(CQR.GE.0D0) THEN
48472 S1=(CR+SQRT(CQR))**(1D0/3D0)
48473 S2=(CR-SQRT(CQR))**(1D0/3D0)
48477 THE=ACOS(CR/SABS**3)/3D0
48482 C...Find and solve two second-degree equations.
48483 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
48484 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
48485 Q1=U/2D0+SQRT(U**2/4D0-B0)
48486 Q2=U/2D0-SQRT(U**2/4D0-B0)
48487 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
48492 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
48493 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
48494 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
48495 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
48497 C...Order eigenvalues in asceding mass.
48500 DO 130 I2=I1-1,1,-1
48501 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
48507 C...Find equation system for eigenvectors.
48510 D(J1,J1)=A(J1,J1)-W(I)
48517 C...Find largest element in matrix.
48521 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
48524 DAMAX=ABS(D(J1,J2))
48528 C...Subtract others by multiple of row selected above.
48530 DO 210 J3=JA+1,JA+3
48532 RL=D(J1,JB)/D(JA,JB)
48534 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
48535 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
48538 DAMAX=ABS(D(J1,J2))
48542 C...Do one more subtraction of a row.
48544 DO 230 J3=JC+1,JC+3
48546 IF(J1.EQ.JA) GOTO 230
48547 RL=D(J1,JD)/D(JC,JD)
48549 IF(J2.EQ.JB) GOTO 220
48550 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
48551 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
48553 DAMAX=ABS(D(J1,J2))
48557 C...Construct unnormalized eigenvector.
48559 JF2=JD+2-4*((JD+1)/4)
48560 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
48561 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
48564 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
48565 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
48568 C...Normalize and fill in final array.
48569 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
48570 SGN=(-1D0)**INT(PYR(0)+0.5D0)
48579 C*********************************************************************
48582 C...Determines the Higgs boson mass spectrum using several inputs.
48584 SUBROUTINE PYHGGM(ALPHA)
48586 C...Double precision and integer declarations.
48587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48588 IMPLICIT INTEGER(I-N)
48589 INTEGER PYK,PYCHGE,PYCOMP
48590 C...Parameter statement to help give large particle numbers.
48591 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48592 &KEXCIT=4000000,KDIMEN=5000000)
48594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48596 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
48597 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48598 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
48600 C...Local variables.
48601 DOUBLE PRECISION AT,AB,XMU,TANB
48602 DOUBLE PRECISION ALPHA
48604 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48605 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48606 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48607 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48610 IF(IHOPT.EQ.2) THEN
48626 DMC=PMAS(PYCOMP(KSUSY1+37),1)
48633 IF(IHOPT.EQ.0) THEN
48634 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48635 & DMHCH,DSA,DCA,DTANBA)
48636 ELSEIF(IHOPT.EQ.1) THEN
48637 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48638 & DMHCH,DSA,DCA,DTANBA)
48639 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
48640 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
48641 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
48647 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
48648 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48649 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
48650 & PMAS(PYCOMP(1000006),1),DSTOP2
48652 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
48653 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48654 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
48655 & PMAS(PYCOMP(2000006),1),DSTOP1
48657 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
48658 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48659 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
48660 & PMAS(PYCOMP(1000005),1),DSBOT2
48662 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
48663 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48664 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
48665 & PMAS(PYCOMP(2000005),1),DSBOT1
48668 ELSEIF (IHOPT.EQ.3) THEN
48669 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48670 C...Currently only available for SLHA spectrum read-in.
48671 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
48672 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48673 & //' spectrum, change IMSS(1) or IMSS(4) option.')
48689 C*********************************************************************
48692 C...This routine computes the renormalization group improved
48693 C...values of Higgs masses and couplings in the MSSM.
48695 C...Program based on the work by M. Carena, J.R. Espinosa,
48696 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48698 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48699 C...All masses in GeV units. MA is the CP-odd Higgs mass,
48700 C...MTOP is the physical top mass, MQ and MUR are the soft
48701 C...supersymmetry breaking mass parameters of left handed
48702 C...and right handed stops respectively, AU and AD are the
48703 C...stop and sbottom trilinear soft breaking terms,
48704 C...respectively, and MU is the supersymmetric
48705 C...Higgs mass parameter. We use the conventions from
48706 C...the physics report of Haber and Kane: left right
48707 C...stop mixing term proportional to (AU - MU/TANB)
48708 C...We use as input TANB defined at the scale MTOP
48710 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48711 C...where MH and HM are the lightest and heaviest CP-even
48712 C...Higgs masses, MHCH is the charged Higgs mass and
48713 C...ALPHA is the Higgs mixing angle
48714 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48716 C...Range of validity:
48717 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48718 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48719 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48720 C...are the sbottom mass eigenvalues, respectively. This
48721 C...range automatically excludes the existence of tachyons.
48722 C...For the charged Higgs mass computation, the method is
48724 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48725 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48726 C...where M_SUSY**2 is the average of the squared stop mass
48727 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48728 C...masses have been assumed to be of order of the stop ones
48729 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48731 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48732 &XMHCH,SA,CA,TANBA)
48734 C...Double precision and integer declarations.
48735 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48736 IMPLICIT INTEGER(I-N)
48737 INTEGER PYK,PYCHGE,PYCOMP
48738 C...Parameter statement to help give large particle numbers.
48739 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48740 &KEXCIT=4000000,KDIMEN=5000000)
48742 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48743 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48744 COMMON/PYHTRI/HHH(7)
48745 SAVE /PYDAT1/,/PYDAT2/
48747 C...Local variables.
48748 DOUBLE PRECISION PYALEM,PYALPS
48749 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48750 DOUBLE PRECISION XMHCH,SA,CA
48751 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48752 DOUBLE PRECISION Q02
48753 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48754 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48755 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48756 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48757 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48758 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48759 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48760 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48765 ALP1=AEM/(1D0-PARU(102))
48778 C...MBOTTOM(MTOP) = 3. GEV
48779 XMB = PYMRUN(5,XMTOP**2)
48780 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
48781 &LOG(XMTOP**2/XMZ**2))
48783 C...RMTOP= RUNNING TOP QUARK MASS
48784 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
48785 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
48786 T = LOG(XMS**2/XMTOP**2)
48787 SINB = TANB/((1D0 + TANB**2)**0.5D0)
48789 C...IF(MA.LE.XMTOP) TANBA = TANBT
48791 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
48792 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
48793 &LOG(XMA**2/XMTOP**2))
48795 SINBT = TANBT/SQRT(1D0 + TANBT**2)
48796 COSBT = 1D0/SQRT(1D0 + TANBT**2)
48797 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48798 G1 = SQRT(ALP1*4D0*PI)
48799 G2 = SQRT(ALP2*4D0*PI)
48800 G3 = SQRT(ALP3*4D0*PI)
48815 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
48816 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
48817 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
48818 &+ 3D0*(AU + AD)**2/XMS2)/6D0
48819 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
48820 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
48821 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
48822 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
48823 &- 16D0*G3**2) *T/16D0/PI2)
48824 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
48825 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
48826 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
48827 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
48828 &- 16D0*G3**2) *T/16D0/PI2)
48829 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48830 &(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/
48834 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
48835 &- 16D0*G3**2) *T/16D0/PI2)
48836 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48837 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
48838 &- 16D0*G3**2) *T/16D0/PI2)
48839 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
48840 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48841 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48842 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48844 &(1+ (6D0*HU2 -2D0* HD2
48845 &- 16D0*G3**2) *T/16D0/PI2)
48846 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48848 &(1+ (6D0*HD2 -2D0* HU2/2D0
48849 &- 16D0*G3**2) *T/16D0/PI2)
48850 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
48851 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
48852 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
48853 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
48854 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
48855 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48856 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
48857 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48858 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
48859 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48860 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
48861 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48869 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
48870 &2D0* XLAM6*SINBT*COSBT
48871 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
48873 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
48875 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
48876 &2D0* XLAM6* COSBT*SINBT
48877 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48878 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
48879 &((XLAM1* COSBT**2 +2D0*
48880 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
48881 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
48883 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
48884 &+ XLAM4) + XLAM6*COSBT**2
48885 &+ XLAM7* SINBT**2))
48887 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
48888 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
48891 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
48892 XMHCH = SQRT(XMHCH2)
48894 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48895 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48896 &XLAM6* COSBT*SINBT
48897 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48898 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48899 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
48900 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
48902 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
48903 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
48904 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
48905 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
48906 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48907 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48908 &XLAM6* COSBT*SINBT
48909 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48910 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48911 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
48921 C*********************************************************************
48924 C...This subroutine computes the CP-even higgs and CP-odd pole
48925 c...Higgs masses and mixing angles.
48927 C...Program based on the work by M. Carena, M. Quiros
48928 C...and C.E.M. Wagner, "Effective potential methods and
48929 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48931 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48933 C...where MCHI is the largest chargino mass, MA is the running
48934 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48935 C...expectaion values at the scale MTOP, MQ is the third generation
48936 C...left handed squark mass parameter, MUR is the third generation
48937 C...right handed stop mass parameter, MDR is the third generation
48938 C...right handed sbottom mass parameter, MTOP is the pole top quark
48939 C...mass; AT,AB are the soft supersymmetry breaking trilinear
48940 C...couplings of the stop and sbottoms, respectively, and MU is the
48941 C...supersymmetric mass parameter
48943 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48944 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48945 C...masses are given, what makes the running of the program
48946 c...much faster and it is quite generally a good approximation
48947 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48948 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48949 c...and if IHIGGS=3, then h,H,A polarizations are computed
48951 C...Output: MH and MHP which are the lightest CP-even Higgs running
48952 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48953 C...Higgs running and pole masses, repectively; SA and CA are the
48954 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48955 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48956 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48957 C...the value of TANB at the CP-odd Higgs mass scale
48959 C...This subroutine makes use of CERN library subroutine
48960 C...integration package, which makes the computation of the
48961 C...pole Higgs masses somewhat faster. We thank P. Janot for this
48962 C...improvement. Those who are not able to call the CERN
48963 C...libraries, please use the subroutine SUBHPOLE2.F, which
48964 C...although somewhat slower, gives identical results
48966 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48967 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48969 C...Double precision and integer declarations.
48970 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48971 IMPLICIT INTEGER(I-N)
48974 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48976 INTEGER PYK,PYCHGE,PYCOMP
48978 C...Local variables.
48979 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48980 &SSBOT2(2),B(2,2),COUPB(2,2),
48981 &HCOUPT(2,2),HCOUPB(2,2),
48982 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48991 RXMT=PYMRUN(6,XMT**2)
48992 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48993 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48995 SINB = TANB/(TANB**2+1D0)**0.5D0
48996 COSB = 1D0/(TANB**2+1D0)**0.5D0
48997 COS2B = SINB**2 - COSB**2
48998 SINBPA = SINB*CA + COSB*SA
48999 COSBPA = COSB*CA - SINB*SA
49000 RMBOT = PYMRUN(5,XMT**2)
49003 IF(XMUR.LT.0D0) XMUR2=-XMUR2
49005 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
49006 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49007 IF(XMST11.LT.0D0) GOTO 500
49008 IF(XMST22.LT.0D0) GOTO 500
49009 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49010 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49011 IF(XMSB11.LT.0D0) GOTO 500
49012 IF(XMSB22.LT.0D0) GOTO 500
49013 C WMST11 = RXMT**2 + XMQ2
49014 C WMST22 = RXMT**2 + XMUR2
49015 XMST12 = RXMT*(AT - XMU/TANB)
49016 XMSB12 = RMBOT*(AB - XMU*TANB)
49018 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49019 C...STOP EIGENVALUES CALCULATION
49020 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49022 STOP12 = 0.5D0*(XMST11+XMST22) +
49023 &0.5D0*((XMST11+XMST22)**2 -
49024 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49025 STOP22 = 0.5D0*(XMST11+XMST22) -
49026 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49027 &XMST12**2))**0.5D0
49029 IF(STOP22.LT.0D0) GOTO 500
49032 STOP1 = STOP12**0.5D0
49033 STOP2 = STOP22**0.5D0
49037 IF(XMST12.EQ.0D0) XST11 = 1D0
49038 IF(XMST12.EQ.0D0) XST12 = 0D0
49039 IF(XMST12.EQ.0D0) XST21 = 0D0
49040 IF(XMST12.EQ.0D0) XST22 = 1D0
49042 IF(XMST12.EQ.0D0) GOTO 110
49044 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49045 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49046 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49047 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49054 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49055 &0.5D0*((XMSB11+XMSB22)**2 -
49056 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49057 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49058 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49059 &XMSB12**2))**0.5D0
49060 IF(SBOT22.LT.0D0) GOTO 500
49061 SBOT1 = SBOT12**0.5D0
49062 SBOT2 = SBOT22**0.5D0
49067 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49068 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49069 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49070 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49072 IF(XMSB12.EQ.0D0) GOTO 130
49074 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49075 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49076 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49077 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49089 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49090 C...STARTING OF LIGHT HIGGS
49091 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49093 IF(IHIGGS.EQ.0) GOTO 490
49098 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49099 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49100 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49101 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49110 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49111 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49112 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49113 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49121 180 ITER = ITER + 1
49124 PR(I3)=PRUN+(I3-2)*EPS/2
49129 POLT = POLT + COUPT(I,J)**2*3D0*
49130 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49137 POLB = POLB + COUPB(I,J)**2*3D0*
49138 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49145 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49147 & (-2D0*XMT**2+0.5D0*P2)*
49148 & PYFINT(P2,XMT2,XMT2)
49150 POL = POLT + POLB + POLTT
49151 POLAR(I3) = P2 - XMH**2 - POL
49153 DERIV = (POLAR(3)-POLAR(1))/EPS
49154 DRUN = - POLAR(2)/DERIV
49157 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49163 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49164 C...END OF LIGHT HIGGS
49165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49167 250 IF(IHIGGS.EQ.1) GOTO 490
49169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49170 C... STARTING OF HEAVY HIGGS
49171 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49176 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49177 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49178 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49179 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49187 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49188 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49189 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49190 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
49199 300 ITER = ITER + 1
49201 PR(I3)=PRUN+(I3-2)*EPS/2
49207 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
49208 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49215 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
49216 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49224 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49226 & (-2D0*XMT**2+0.5D0*HP2)*
49227 & PYFINT(HP2,XMT2,XMT2)
49229 HPOL = HPOLT + HPOLB + HPOLTT
49230 POLAR(I3) =HP2-HM**2-HPOL
49232 DERIV = (POLAR(3)-POLAR(1))/EPS
49233 DRUN = - POLAR(2)/DERIV
49236 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
49244 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49245 C... END OF HEAVY HIGGS
49246 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49248 IF(IHIGGS.EQ.2) GOTO 490
49250 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49251 C...BEGINNING OF PSEUDOSCALAR HIGGS
49252 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49257 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
49258 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
49264 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
49265 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
49272 420 ITER = ITER + 1
49274 PR(I3)=PRUN+(I3-2)*EPS/2
49279 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
49280 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49286 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
49287 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49293 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49294 & COSB**2/SINB**2 *
49296 & PYFINT(AP2,XMT2,XMT2)
49297 APOL = APOLT + APOLB + APOLTT
49298 POLAR(I3) = AP2 - XMA**2 -APOL
49300 DERIV = (POLAR(3)-POLAR(1))/EPS
49301 DRUN = - POLAR(2)/DERIV
49304 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
49310 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49311 C...END OF PSEUDOSCALAR HIGGS
49312 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49314 IF(IHIGGS.EQ.3) GOTO 490
49319 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
49320 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
49321 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
49322 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
49326 C*********************************************************************
49329 C...Auxiliary to PYPOLE.
49331 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49332 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49333 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
49334 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
49337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49348 C MBOTTOM(MTOP) = 3. GEV
49349 MB = PYMRUN(5,MTOP**2)
49350 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
49351 *LOG(MTOP**2/MZ**2))
49352 C RMTOP= RUNNING TOP QUARK MASS
49353 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49354 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
49355 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
49356 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
49357 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49359 C NEW DEFINITION, TGLU.
49361 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49362 TGLU = LOG(MGLU**2/MTOP**2)
49363 SINB = TANB/DSQRT(1D0 + TANB**2)
49366 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
49367 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
49368 *LOG(MA**2/MTOP**2))
49369 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
49370 SINB = TANBT/SQRT(1D0 + TANBT**2)
49371 COSB = 1D0/DSQRT(1D0 + TANBT**2)
49372 G1 = SQRT(ALPHA1*4D0*PI)
49373 G2 = SQRT(ALPHA2*4D0*PI)
49374 G3 = SQRT(ALPHA3*4D0*PI)
49377 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
49378 *SBOT1,SBOT2,DELTAMT,DELTAMB)
49379 IF(MQ.GT.MUR) TP = TQ - TU
49380 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
49381 IF(MQ.GT.MUR) TDP = TU
49382 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
49383 IF(MQ.GT.MD) TPD = TQ - TD
49384 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
49385 IF(MQ.GT.MD) TDPD = TD
49386 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
49388 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
49389 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
49390 * HD**2*(G1**2/3D0+G2**2)*TPD
49392 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
49393 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
49394 * HU**2*(-G1**2/3D0+G2**2)*TP
49396 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49398 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49399 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49400 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49404 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49407 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
49408 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
49409 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
49412 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
49413 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49416 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
49417 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49420 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
49421 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
49424 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
49425 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49428 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
49429 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49434 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
49435 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
49436 *(G2**2-G1**2/3D0)*TPD
49437 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
49438 *1D0/16D0/PI**2*G1**2*HU**2*TP
49439 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
49440 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
49441 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
49442 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
49444 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
49445 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
49446 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
49447 *+ (3D0*HD**2/2D0 + HU**2/2D0
49448 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
49449 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
49450 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
49451 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
49452 *(TP + TDP)/8D0/PI**2)
49453 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
49454 *+ (3D0*HU**2/2D0 + HD**2/2D0
49455 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
49456 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
49457 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
49458 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49459 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
49460 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
49461 LAMBDA4 = (- G2**2/2D0)*(1D0
49462 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
49463 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
49469 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
49470 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
49472 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
49473 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
49474 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
49475 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
49478 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49479 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49480 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49482 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
49484 IF(MCHI.GT.MSSUSY) GOTO 100
49485 IF(MCHI.LT.MTOP) MCHI=MTOP
49487 TCHAR=LOG(MSSUSY**2/MCHI**2)
49489 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
49490 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
49491 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
49493 DELTAM112=2D0*DELTAL12*V**2*COSB**2
49494 DELTAM222=2D0*DELTAL12*V**2*SINB**2
49495 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
49497 M2(1,1)=M2(1,1)+DELTAM112
49498 M2(2,2)=M2(2,2)+DELTAM222
49499 M2(1,2)=M2(1,2)+DELTAM122
49500 M2(2,1)=M2(2,1)+DELTAM122
49504 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49505 CCC END OF CHARGINOS/NEUTRALINOS
49506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49510 M2P(I,J) = M2(I,J) + VH(I,J)
49513 TRM2P = M2P(1,1) + M2P(2,2)
49514 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
49515 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49516 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49518 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
49520 IF(MH2P.LT.0.) GOTO 130
49522 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
49523 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
49524 IF(COS2ALPHA.GE.0.) THEN
49525 ALPHA = ASIN(SIN2ALPHA)/2D0
49527 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
49531 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49533 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49534 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49535 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49538 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49539 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
49540 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
49545 C*********************************************************************
49548 C...Auxiliary to PYRGHM.
49550 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49551 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49552 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
49553 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
49555 INTEGER MSTU,MSTJ,KCHG
49556 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49557 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49558 SAVE /PYDAT1/,/PYDAT2/
49560 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
49562 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
49563 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
49565 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
49570 SINBA = TANBA/DSQRT(TANBA**2+1D0)
49571 COSBA = SINBA/TANBA
49573 SINB = TANB/DSQRT(TANB**2+1D0)
49579 SW = 1D0-MW**2/MZ**2
49582 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
49583 G2 = DSQRT(0.0336D0*4D0*PI)
49584 G1 = DSQRT(0.0101D0*4D0*PI)
49586 IF(MQ.GT.MUR) MST = MQ
49587 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
49589 MSUSYT = DSQRT(MST**2 + MTOP**2)
49591 IF(MQ.GT.MD) MSB = MQ
49592 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
49594 MB = PYMRUN(5,MSB**2)
49595 MSUSYB = DSQRT(MSB**2 + MB**2)
49596 TT = LOG(MSUSYT**2/MTOP**2)
49597 TB = LOG(MSUSYB**2/MTOP**2)
49599 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49600 HT = RMTOP/(V*SINB)
49603 G32 = ALPHA3*4D0*PI
49604 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
49605 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
49606 AL2 = 3D0/8D0/PI**2*HT**2
49607 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49608 C ALST = 3./8./PI**2*HTST**2
49609 AL1 = 3D0/8D0/PI**2*HB**2
49612 AL(1,2) = (AL2+AL1)/2D0
49613 AL(2,1) = (AL2+AL1)/2D0
49616 IF(MA.GT.MTOP) THEN
49617 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
49618 * LOG(MTOP**2/MA**2))
49621 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
49622 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
49623 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
49624 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
49629 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49630 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49631 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49632 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49636 SINBT = TANBST/DSQRT(1D0+TANBST**2)
49639 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
49640 COSBB = SINBB/TANBSB
49645 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49646 MTOP2 = DSQRT(MTOP4)
49647 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49648 * /(1D0+DELTAMB)**4
49649 MBOT2 = DSQRT(MBOT4)
49651 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49652 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49653 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49654 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49655 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49656 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49657 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49658 * MQ2 - MUR2)**2*0.25D0
49659 * + MTOP2*(AT-XMU/TANBST)**2)
49660 IF(STOP22.LT.0.) GOTO 120
49661 SBOT12 = (MQ2 + MD2)*.5D0
49662 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49663 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49664 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49665 SBOT22 = (MQ2 + MD2)*.5D0
49666 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49667 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49668 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49669 IF(SBOT22.LT.0.) SBOT22 = 10000D0
49671 STOP1 = DSQRT(STOP12)
49672 STOP2 = DSQRT(STOP22)
49673 SBOT1 = DSQRT(SBOT12)
49674 SBOT2 = DSQRT(SBOT22)
49676 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49678 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49679 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49680 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49681 C INDUCED CORRECTIONS.
49683 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49688 IF(X.EQ.Y) X = X - 0.00001D0
49689 IF(X.EQ.Z) X = X - 0.00002D0
49690 IF(Y.EQ.Z) Y = Y - 0.00003D0
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 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
49701 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
49705 IF(X.EQ.Y) X = X - 0.00001D0
49706 IF(X.EQ.Z) X = X - 0.00002D0
49707 IF(Y.EQ.Z) Y = Y - 0.00003D0
49709 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
49711 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49713 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49714 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49715 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49716 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49717 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49718 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49719 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49720 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49721 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49722 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49723 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49726 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49728 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49729 MTOP2 = DSQRT(MTOP4)
49730 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49731 * /(1D0+DELTAMB)**4
49732 MBOT2 = DSQRT(MBOT4)
49734 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49735 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49736 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49737 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49738 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49739 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49740 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49741 * MQ2 - MUR2)**2*0.25D0
49742 * + MTOP2*(AT-XMU/TANBST)**2)
49744 IF(STOP22.LT.0.) GOTO 120
49745 SBOT12 = (MQ2 + MD2)*.5D0
49746 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49747 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49748 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49749 SBOT22 = (MQ2 + MD2)*.5D0
49750 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49751 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49752 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49753 IF(SBOT22.LT.0.) GOTO 120
49756 STOP1 = DSQRT(STOP12)
49757 STOP2 = DSQRT(STOP22)
49758 SBOT1 = DSQRT(SBOT12)
49759 SBOT2 = DSQRT(SBOT22)
49761 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49763 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49766 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
49768 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
49769 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
49771 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
49773 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
49774 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
49776 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
49777 * (-.5D0*LOG(STOP12/STOP22)
49778 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
49779 * G(STOP12,STOP22))
49781 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
49782 * (.5D0*LOG(SBOT12/SBOT22)
49783 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
49784 * G(SBOT12,SBOT22))
49786 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
49787 * (MQ2+MBOT2)/(MD2+MBOT2))
49788 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
49789 * LOG(SBOT1**2/SBOT2**2)) +
49790 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
49791 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
49794 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
49795 * -STOP2**2))**2*G(STOP12,STOP22)
49797 VH3B(1,1)=VH3B(1,1)+
49798 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
49800 VH3T(1,1) = VH3T(1,1) +
49801 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
49803 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
49804 * (MQ2+MTOP2)/(MUR2+MTOP2))
49805 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
49806 * LOG(STOP1**2/STOP2**2)) +
49807 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
49808 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
49811 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
49812 * -SBOT2**2))**2*G(SBOT12,SBOT22)
49814 VH3T(2,2)=VH3T(2,2)+
49815 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
49816 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
49818 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
49819 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
49820 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
49823 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
49824 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
49825 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
49828 VH3T(1,2)=VH3T(1,2) +
49829 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
49831 VH3B(1,2)=VH3B(1,2) +
49832 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
49834 VH3T(2,1) = VH3T(1,2)
49835 VH3B(2,1) = VH3B(1,2)
49837 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49838 C TU = LOG((MUR2+MTOP2)/MTOP2)
49839 C TQD = LOG((MQ2 + MB**2)/MB**2)
49840 C TD = LOG((MD2+MB**2)/MB**2)
49845 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
49846 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
49847 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
49848 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
49867 C*********************************************************************
49870 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49872 FUNCTION PYFINT(A,B,C)
49874 C...Double precision and integer declarations.
49875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49876 IMPLICIT INTEGER(I-N)
49877 INTEGER PYK,PYCHGE,PYCOMP
49879 COMMON/PYINTS/XXM(20)
49882 C...Local variables.
49884 DOUBLE PRECISION PYFISB
49891 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
49896 C*********************************************************************
49899 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49903 C...Double precision and integer declarations.
49904 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49905 IMPLICIT INTEGER(I-N)
49906 INTEGER PYK,PYCHGE,PYCOMP
49908 COMMON/PYINTS/XXM(20)
49911 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
49912 &(X*(XXM(2)-XXM(3))+XXM(3)))
49917 C*********************************************************************
49920 C...Calculates decays of sfermions.
49922 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
49924 C...Double precision and integer declarations.
49925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49926 IMPLICIT INTEGER(I-N)
49927 INTEGER PYK,PYCHGE,PYCOMP
49928 C...Parameter statement to help give large particle numbers.
49929 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49930 &KEXCIT=4000000,KDIMEN=5000000)
49932 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49933 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49934 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49935 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49936 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49937 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49939 C...Local variables.
49940 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49941 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49943 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49944 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49945 DOUBLE PRECISION PYLAMF,XL
49946 DOUBLE PRECISION TANW,XW,AEM,C1,AS
49947 DOUBLE PRECISION AL,AR,BL,BR
49948 DOUBLE PRECISION CH1,CH2,CH3,CH4
49949 DOUBLE PRECISION XMBOT,XMTOP
49950 DOUBLE PRECISION XLAM(0:400)
49951 INTEGER IDLAM(400,3)
49952 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49953 DOUBLE PRECISION SR2
49954 DOUBLE PRECISION CBETA,SBETA
49955 DOUBLE PRECISION CW
49956 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49957 DOUBLE PRECISION COSA,SINA,TANB
49958 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49959 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49961 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49962 DATA IGG/23,25,35,36/
49963 DATA PI/3.141592654D0/
49964 DATA SR2/1.4142136D0/
49965 DATA KFNCHI/1000022,1000023,1000025,1000035/
49966 DATA KFCCHI/1000024,1000037/
49968 C...COUNT THE NUMBER OF DECAY MODES
49972 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49973 &KFIN.EQ.KSUSY2+16) RETURN
49979 TANW = SQRT(XW/(1D0-XW))
49984 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49989 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49990 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49996 C...ILR is 1 for left and 2 for right.
49998 C...IFL is matching non-SUSY flavour.
49999 IFL=MOD(KFIN,KSUSY1)
50000 C...IDU is weak isospin, 1 for down and 2 for up.
50011 XMBOT=PYMRUN(5,XMI2)
50012 XMTOP=PYMRUN(6,XMI2)
50026 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50028 IF(IMSS(11).EQ.1) THEN
50031 XMGR=PMAS(PYCOMP(IDG),1)
50032 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50035 ELSEIF(IFL.EQ.6) THEN
50040 IF(XMI.GT.XMGR+XMF) THEN
50045 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50049 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50051 C...CHARGED DECAYS:
50053 C...DI -> U CHI1-,CHI2-
50057 C...UI -> D CHI1+,CHI2+
50064 IF(XMI.GE.AXMJ+XMFP) THEN
50071 ELSEIF(IFL.LT.6) THEN
50076 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50077 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50083 ELSEIF(IFL.LT.5) THEN
50088 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50089 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50093 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50094 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50095 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50096 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50112 XL=PYLAMF(XMI2,XMA2,XMB2)
50113 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50114 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50115 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50118 IDLAM(LKNT,1)=-KFCCHI(IX)
50119 IDLAM(LKNT,2)=IFL+1
50121 IDLAM(LKNT,1)=KFCCHI(IX)
50122 IDLAM(LKNT,2)=IFL-1
50133 IF(XMI.GE.AXMJ+XMF) THEN
50139 ELSEIF(IFL.LT.5) THEN
50142 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50143 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50144 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50149 ELSEIF(IFL.LT.5) THEN
50152 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50153 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50154 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50158 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50159 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50160 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50161 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50177 XL=PYLAMF(XMI2,XMA2,XMB2)
50178 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50179 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50180 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50181 IDLAM(LKNT,1)=KFNCHI(IX)
50187 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50191 IF(ILR.EQ.1) GOTO 160
50193 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50194 IF(XMI.LT.XMSF1+XMB) GOTO 160
50196 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
50199 ELSEIF(IG.EQ.25) THEN
50202 ELSEIF(IFL.EQ.6) THEN
50204 ELSEIF(IFL.LT.5) THEN
50210 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50211 & XMF**2/XMW*COSA/SBETA
50212 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50213 & XMF**2/XMW*COSA/SBETA
50215 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50216 & XMF**2/XMW*(-SINA)/CBETA
50217 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50218 & XMF**2/XMW*(-SINA)/CBETA
50222 ELSEIF(IFL.EQ.6) THEN
50224 ELSEIF(IFL.EQ.15) THEN
50229 C.........need to complexify
50231 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
50234 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
50240 ELSEIF(IG.EQ.35) THEN
50243 ELSEIF(IFL.EQ.6) THEN
50245 ELSEIF(IFL.LT.5) THEN
50251 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50252 & XMF**2/XMW*SINA/SBETA
50253 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50254 & XMF**2/XMW*SINA/SBETA
50256 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50257 & XMF**2/XMW*COSA/CBETA
50258 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50259 & XMF**2/XMW*COSA/CBETA
50263 ELSEIF(IFL.EQ.6) THEN
50265 ELSEIF(IFL.EQ.15) THEN
50270 C.........Need to complexify
50272 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
50275 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
50281 ELSEIF(IG.EQ.36) THEN
50286 ELSEIF(IFL.EQ.6) THEN
50288 ELSEIF(IFL.LT.5) THEN
50295 ELSEIF(IFL.EQ.6) THEN
50297 ELSEIF(IFL.EQ.15) THEN
50302 C.........Need to complexify
50304 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
50306 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
50312 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
50313 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
50314 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
50315 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50318 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50320 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
50323 IDLAM(LKNT,1)=KFIN-KSUSY1
50329 IF(MOD(IFL,2).EQ.0) THEN
50335 XMSF1=PMAS(PYCOMP(KF1),1)
50336 XMSF2=PMAS(PYCOMP(KF2),1)
50337 IF(XMI.GT.XMB+XMSF1) THEN
50338 IF(MOD(IFL,2).EQ.0) THEN
50340 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
50342 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
50346 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
50348 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
50351 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50353 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50356 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50358 IF(XMI.GT.XMB+XMSF2) THEN
50359 IF(MOD(IFL,2).EQ.0) THEN
50361 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
50363 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
50367 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
50369 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
50372 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
50374 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50377 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50382 IF(MOD(IFL,2).EQ.0) THEN
50388 XMSF1=PMAS(PYCOMP(KF1),1)
50389 XMSF2=PMAS(PYCOMP(KF2),1)
50390 IF(XMI.GT.XMB+XMSF1) THEN
50395 IF(MOD(IFL,2).EQ.0) THEN
50398 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
50399 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
50400 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
50401 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
50404 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
50405 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
50406 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
50407 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
50418 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
50419 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
50420 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
50421 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
50424 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
50425 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
50426 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
50427 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
50436 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50438 C.......Need to complexify
50439 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50440 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50441 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50442 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50445 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50447 IF(XMI.GT.XMB+XMSF2) THEN
50452 IF(MOD(IFL,2).EQ.0) THEN
50455 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
50456 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
50457 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
50458 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
50461 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
50462 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
50463 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
50464 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
50475 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
50476 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
50477 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
50478 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
50481 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
50482 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
50483 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
50484 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
50493 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50495 C.......Need to complexify
50496 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50497 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50498 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50499 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50502 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50505 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50510 IF(IFL.EQ.6) XMF=PMAS(6,1)
50511 IF(IFL.EQ.5) XMF=PMAS(5,1)
50512 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50514 IF(XMI.GE.AXMJ+XMF) THEN
50531 XL=PYLAMF(XMI2,XMA2,XMB2)
50532 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50533 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
50534 IDLAM(LKNT,1)=KSUSY1+21
50540 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50541 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
50542 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
50543 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50544 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50545 C...M*M = C1**2 * G**2/(16PI**2)
50546 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50548 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
50549 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
50550 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
50551 IDLAM(LKNT,1)=KSUSY1+22
50556 C...R-violating sfermion decays (SKANDS).
50557 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
50562 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50563 XLAM(0)=XLAM(0)+XLAM(I)
50565 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
50570 C*********************************************************************
50573 C...Calculates gluino decay modes.
50575 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
50577 C...Double precision and integer declarations.
50578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50579 IMPLICIT INTEGER(I-N)
50580 INTEGER PYK,PYCHGE,PYCOMP
50581 C...Parameter statement to help give large particle numbers.
50582 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50583 &KEXCIT=4000000,KDIMEN=5000000)
50585 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50586 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50587 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50588 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50589 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50591 C COMMON/PYINTS/XXM(20)
50593 COMMON/PYINTC/XXC(10),CXC(8)
50594 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50596 C...Local variables
50597 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50598 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50599 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50600 DOUBLE PRECISION PYLAMF,XL
50601 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50602 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50603 DOUBLE PRECISION XLAM(0:400)
50604 INTEGER IDLAM(400,3)
50605 INTEGER LKNT,IX,ILR,I,IKNT,IFL
50606 DOUBLE PRECISION SR2
50607 DOUBLE PRECISION GAM
50608 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50609 EXTERNAL PYGAUS,PYXXZ6
50610 DOUBLE PRECISION PYGAUS,PYXXZ6
50611 DOUBLE PRECISION PREC
50612 INTEGER KFNCHI(4),KFCCHI(2)
50613 DATA PI/3.141592654D0/
50614 DATA SR2/1.4142136D0/
50616 DATA KFNCHI/1000022,1000023,1000025,1000035/
50617 DATA KFCCHI/1000024,1000037/
50619 C...COUNT THE NUMBER OF DECAY MODES
50621 IF(KFIN.NE.KSUSY1+21) RETURN
50625 TANW = SQRT(XW/(1D0-XW))
50635 XMI=SIGN(XMI,RMSS(3))
50637 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50639 IF(IMSS(11).EQ.1) THEN
50642 XMGR=PMAS(PYCOMP(IDG),1)
50643 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50644 IF(AXMI.GT.XMGR) THEN
50653 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50657 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
50660 IF(AXMI.GE.AXMJ+XMF) THEN
50661 C...Minus sign difference from gluino-quark-squark feynman rules
50678 XL=PYLAMF(XMI2,XMA2,XMB2)
50679 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
50680 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
50681 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
50685 XLAM(LKNT)=XLAM(LKNT-1)
50686 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50687 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50693 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50694 C...GLUINO -> NI Q QBAR
50698 IF(AXMI.GE.AXMJ) THEN
50700 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
50702 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
50709 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50710 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50716 T3I=SIGN(1D0,EI+1D-6)/2D0
50717 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50718 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50722 CXC(4)=DCONJG(GLIJ)
50726 CXC(8)=-DCONJG(GRIJ)
50728 S12MAX=(AXMI-AXMJ)**2
50729 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
50730 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50732 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50733 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50734 IDLAM(LKNT,1)=KFNCHI(IX)
50738 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50740 XLAM(LKNT)=XLAM(LKNT-1)
50741 IDLAM(LKNT,1)=KFNCHI(IX)
50746 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50747 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
50748 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
50750 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
50751 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
50753 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
50756 IDLAM(LKNT,1)=KFNCHI(IX)
50759 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
50764 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50765 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50766 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50770 T3I=SIGN(1D0,EI+1D-6)/2D0
50771 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50772 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50774 CXC(4)=DCONJG(GLIJ)
50776 CXC(8)=-DCONJG(GRIJ)
50777 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
50778 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50780 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50781 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50782 IDLAM(LKNT,1)=KFNCHI(IX)
50786 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50788 XLAM(LKNT)=XLAM(LKNT-1)
50789 IDLAM(LKNT,1)=KFNCHI(IX)
50794 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50795 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50797 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
50798 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
50799 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
50801 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
50802 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
50804 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
50807 IDLAM(LKNT,1)=KFNCHI(IX)
50810 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
50816 C...GLUINO -> CI Q QBAR'
50820 IF(AXMI.GE.AXMJ) THEN
50822 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
50823 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
50826 S12MAX=(AXMI-AXMJ)**2
50831 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50832 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50835 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50837 CXC(1)=DCMPLX(0D0,0D0)
50838 CXC(3)=DCMPLX(0D0,0D0)
50839 CXC(5)=DCMPLX(0D0,0D0)
50840 CXC(7)=DCMPLX(0D0,0D0)
50841 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50842 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50843 CXC(6)=DCMPLX(0D0,0D0)
50844 CXC(8)=DCMPLX(0D0,0D0)
50845 IF(XXC(5).LT.AXMI) THEN
50847 ELSEIF(XXC(6).LT.AXMI) THEN
50852 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
50853 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50855 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50856 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50857 IDLAM(LKNT,1)=KFCCHI(IX)
50861 XLAM(LKNT)=XLAM(LKNT-1)
50862 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50863 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50864 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50866 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50868 XLAM(LKNT)=XLAM(LKNT-1)
50869 IDLAM(LKNT,1)=KFCCHI(IX)
50873 XLAM(LKNT)=XLAM(LKNT-1)
50874 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50875 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50876 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50882 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
50883 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
50884 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
50885 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
50886 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
50887 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
50888 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
50889 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
50890 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
50891 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
50892 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
50893 CALL PYTBBC(IX,100,XMI,GAM)
50896 IDLAM(LKNT,1)=KFCCHI(IX)
50900 XLAM(LKNT)=XLAM(LKNT-1)
50901 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50902 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50903 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50904 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
50905 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
50906 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
50907 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
50913 C...R-parity violating (3-body) decays.
50914 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
50919 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50920 XLAM(0)=XLAM(0)+XLAM(I)
50922 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50928 C*********************************************************************
50931 C...Calculates the three-body decay of gluinos into
50932 C...neutralinos and third generation fermions.
50934 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
50936 C...Double precision and integer declarations.
50937 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50938 IMPLICIT INTEGER(I-N)
50939 INTEGER PYK,PYCHGE,PYCOMP
50940 C...Parameter statement to help give large particle numbers.
50941 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50942 &KEXCIT=4000000,KDIMEN=5000000)
50944 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50945 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50946 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50947 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50948 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50949 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50951 C...Local variables.
50952 EXTERNAL PYSIMP,PYLAMF
50953 DOUBLE PRECISION PYSIMP,PYLAMF
50955 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50956 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50957 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50958 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50959 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50960 DOUBLE PRECISION XLN1,XLN2,B1,B2
50961 DOUBLE PRECISION E,XMGLU,GAM
50962 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50963 SAVE HRB,HLB,FLB,FRB
50964 DOUBLE PRECISION ALPHAW,ALPHAS
50965 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50966 SAVE HLT,HRT,FLT,FRT
50967 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50969 DOUBLE PRECISION AMBOT,SINC,COSC
50970 DOUBLE PRECISION AMTOP,SINA,COSA
50971 DOUBLE PRECISION SINW,COSW,TANW
50972 DOUBLE PRECISION ROT1(4,4)
50975 DATA IFIRST/.TRUE./
50978 SINB=TANB/SQRT(1D0+TANB**2)
50989 AMBOT=PYMRUN(5,XMGLU**2)
50990 AMTOP=PYMRUN(6,XMGLU**2)
50992 FAKT1=AMBOT/W2/AMW/COSB
50993 FAKT2=AMTOP/W2/AMW/SINB
51004 ROT1(2,1)=-ROT1(1,2)
51005 ROT1(2,2)=ROT1(1,1)
51008 ROT1(4,3)=-ROT1(3,4)
51009 ROT1(4,4)=ROT1(3,3)
51013 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51018 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51019 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51020 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51022 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51023 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51024 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51025 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51028 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51029 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51030 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51031 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51032 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51033 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51034 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51038 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51039 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51040 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51041 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51045 IF(NINT(3D0*E).EQ.2) THEN
51052 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51053 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51062 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51063 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51069 SIN2D=SIND*COSD*2D0
51083 ALPHAW=PYALEM(XMG2)
51084 ALPHAS=PYALPS(XMG2)
51088 XM24=(XMG2+XM2)*(XM2+XMR2)
51090 SMAX=(XMG-ABS(XMR))**2
51091 XMQA=XMG2+2D0*XM2+XMR2
51093 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51095 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51097 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51098 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51099 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51100 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51101 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51102 & +2D0*(FF*SIND2-HH*COSD2))*W
51103 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51104 & +4D0*HFL*XM*XMR)*XLN1
51105 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51106 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51107 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51108 & +8D0*HFL*XMQ4*SIN2D)*B1
51109 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51110 & +4D0*HFR*XMR*XM)*XLN2
51111 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51112 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51113 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51114 & -8D0*HFR*XMQ4*SIN2D)*B2
51115 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51116 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51117 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51118 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51119 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51120 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51121 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51122 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51123 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51124 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51125 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51126 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51127 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51128 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51129 & +COS2D*XM*(SBAR+XMG2-XMR2))
51130 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51131 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51132 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51133 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51134 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51135 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51136 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51139 SUMME(LIN)=SUMME(LIN)+G(J)
51144 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51145 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51150 C*********************************************************************
51153 C...Calculates the three-body decay of gluinos into
51154 C...charginos and third generation fermions.
51156 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51158 C...Double precision and integer declarations.
51159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51160 IMPLICIT INTEGER(I-N)
51161 INTEGER PYK,PYCHGE,PYCOMP
51162 C...Parameter statement to help give large particle numbers.
51163 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51164 &KEXCIT=4000000,KDIMEN=5000000)
51166 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51167 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51168 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51169 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51170 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51171 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51173 C...Local variables.
51174 EXTERNAL PYSIMP,PYLAMF
51175 DOUBLE PRECISION PYSIMP,PYLAMF
51177 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51178 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51179 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51180 DOUBLE PRECISION SUMME(0:100),A(4,8)
51181 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51182 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51183 DOUBLE PRECISION XMGLU,GAM
51184 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51185 &DDD(2),EEE(2),FFF(2)
51186 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51187 DOUBLE PRECISION ALPHAW,ALPHAS
51188 DOUBLE PRECISION AMC(2)
51190 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51191 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51195 DATA IFIRST/.TRUE./
51198 SINB=TANB/SQRT(1D0+TANB**2)
51206 AMBOT=PYMRUN(5,XMGLU**2)
51207 AMTOP=PYMRUN(6,XMGLU**2)
51210 FAKT1=AMBOT/W2/AMW/COSB
51211 FAKT2=AMTOP/W2/AMW/SINB
51216 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
51217 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
51218 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
51219 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
51220 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
51221 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
51222 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
51223 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
51225 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51226 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51227 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51228 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51232 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
51233 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
51234 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
51235 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
51237 COS2A=COSA**2-SINA**2
51238 SIN2A=SINA*COSA*2D0
51239 COS2C=COSC**2-SINC**2
51240 SIN2C=SINC*COSC*2D0
51247 ALPHAW=PYALEM(XMG2)
51248 ALPHAS=PYALPS(XMG2)
51252 XMQ2=XMG2+XMT2+XMB2+XMR2
51253 XMQ4=XMG*XMT*XMB*XMR
51254 XMQ3=XMG2*XMR2+XMT2*XMB2
51255 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
51256 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
51258 XMST(1)=AMST(1)*AMST(1)
51259 XMST(2)=AMST(1)*AMST(1)
51260 XMST(3)=AMST(2)*AMST(2)
51261 XMST(4)=AMST(2)*AMST(2)
51262 XMSB(1)=AMSB(1)*AMSB(1)
51263 XMSB(2)=AMSB(2)*AMSB(2)
51264 XMSB(3)=AMSB(1)*AMSB(1)
51265 XMSB(4)=AMSB(2)*AMSB(2)
51267 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
51268 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
51269 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
51270 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
51271 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
51272 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
51273 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
51274 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
51276 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
51277 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
51278 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
51279 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
51280 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
51281 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
51282 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
51283 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
51285 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
51286 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
51287 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
51288 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
51289 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
51290 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
51291 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
51292 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
51294 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
51295 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
51296 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
51297 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
51298 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
51299 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
51300 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
51301 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
51303 SMAX=(XMG-ABS(XMR))**2
51304 SMIN=(XMB+XMT)**2+0.1D0
51307 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51308 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
51310 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
51311 W=DSQRT(W)/2D0/SBAR
51312 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
51313 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
51314 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
51315 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
51316 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
51317 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
51318 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
51319 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
51320 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
51321 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
51322 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
51323 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
51324 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
51325 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
51326 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
51327 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
51328 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
51329 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
51330 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
51331 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
51332 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
51333 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
51334 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
51335 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
51336 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
51337 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
51338 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
51339 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
51340 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
51341 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
51342 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
51343 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
51344 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
51345 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
51346 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
51347 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
51348 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
51349 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
51350 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
51351 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
51352 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
51353 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
51354 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
51356 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
51357 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
51358 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
51359 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
51360 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
51361 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
51362 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
51363 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
51364 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
51365 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
51366 & -A(J,6)*(XMG2+XMR2-SBAR)
51367 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
51368 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
51369 & /(GRS+XMSB(J)+XMST(J))
51373 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51374 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51379 C*********************************************************************
51382 C...Calculates decay widths for the neutralinos (admixtures of
51383 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51385 C...Input: KCIN = KF code for particle
51386 C...Output: XLAM = widths
51387 C... IDLAM = KF codes for decay particles
51388 C... IKNT = number of decay channels defined
51389 C...AUTHOR: STEPHEN MRENNA
51391 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51392 C...when CHIGAMMA .NE. 0
51393 C...10 FEB 96: Calculate this decay for small tan(beta)
51395 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
51397 C...Double precision and integer declarations.
51398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51399 IMPLICIT INTEGER(I-N)
51400 INTEGER PYK,PYCHGE,PYCOMP
51401 C...Parameter statement to help give large particle numbers.
51402 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51403 &KEXCIT=4000000,KDIMEN=5000000)
51405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51406 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51407 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51408 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51410 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51411 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51412 C COMMON/PYINTS/XXM(20)
51414 COMMON/PYINTC/XXC(10),CXC(8)
51415 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51417 C...Local variables.
51418 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51419 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51421 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51422 &XMZ,XMZ2,AXMJ,AXMI
51423 DOUBLE PRECISION S12MIN,S12MAX
51424 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51425 DOUBLE PRECISION PYLAMF,XL
51426 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51427 DOUBLE PRECISION PYX2XH,PYX2XG
51428 DOUBLE PRECISION XLAM(0:400)
51429 INTEGER IDLAM(400,3)
51430 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51431 INTEGER ITH(3),KF1,KF2
51433 DOUBLE PRECISION DH(3),EH(3)
51434 DOUBLE PRECISION SR2
51435 DOUBLE PRECISION CBETA,SBETA
51436 DOUBLE PRECISION GAMCON,XMT1,XMT2
51437 DOUBLE PRECISION PYALEM,PI,PYALPS
51438 DOUBLE PRECISION RAT1,RAT2
51439 DOUBLE PRECISION T3T,FCOL
51440 DOUBLE PRECISION ALFA,BETA,TANB
51441 DOUBLE PRECISION PYXXGA
51442 EXTERNAL PYGAUS,PYXXZ6
51443 DOUBLE PRECISION PYGAUS,PYXXZ6
51444 DOUBLE PRECISION PREC
51445 INTEGER KFNCHI(4),KFCCHI(2)
51449 DATA PI/3.141592654D0/
51450 DATA SR2/1.4142136D0/
51451 DATA KFNCHI/1000022,1000023,1000025,1000035/
51452 DATA KFCCHI/1000024,1000037/
51454 C...COUNT THE NUMBER OF DECAY MODES
51463 TANW = SQRT(XW/XW1)
51465 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51467 IF(KFIN.EQ.KFNCHI(2)) IX=2
51468 IF(KFIN.EQ.KFNCHI(3)) IX=3
51469 IF(KFIN.EQ.KFNCHI(4)) IX=4
51489 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51494 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51495 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51499 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51500 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
51502 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51503 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
51507 GAMCON=AEM**3/8D0/PI/XMW2/XW
51508 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51509 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51510 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51511 IDLAM(LKNT,1)=KSUSY1+22
51514 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
51518 C...GRAVITINO DECAY MODES
51520 IF(IMSS(11).EQ.1) THEN
51523 XMGR=PMAS(PYCOMP(IDG),1)
51526 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51527 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
51532 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
51534 IF(AXMI.GT.XMGR+XMZ) THEN
51539 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
51540 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
51541 & (1D0-XMZ2/XMI2)**4
51543 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
51548 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
51549 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
51551 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
51556 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
51557 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
51559 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
51564 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
51565 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
51567 IF(IX.EQ.1) GOTO 300
51575 C...CHI0_I -> CHI0_J + GAMMA
51576 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
51577 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
51578 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
51579 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
51580 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
51581 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
51582 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
51584 IDLAM(LKNT,1)=KFNCHI(IJ)
51587 GAMCON=AEM**3/8D0/PI/XMW2/XW
51588 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51589 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51590 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51594 C...CHI0_I -> CHI0_J + Z0
51595 IF(AXMI.GE.AXMJ+XMZ) THEN
51597 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51598 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51600 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51601 GLR=DBLE(OLPP*DCONJG(ORPP))
51602 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51603 IDLAM(LKNT,1)=KFNCHI(IJ)
51606 ELSEIF(AXMI.GE.AXMJ) THEN
51613 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51614 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51616 C...CHARGED LEPTONS
51618 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51619 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51621 T3I=SIGN(1D0,EI+1D-6)/2D0
51622 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51623 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51624 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51625 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51627 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51628 CXC(4)=DCONJG(GLIJ)
51629 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51631 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51632 CXC(8)=-DCONJG(GRIJ)
51634 S12MAX=(AXMI-AXMJ)**2
51635 IF( XXC(5).LT.AXMI ) THEN
51638 IF(XXC(6).LT.AXMI ) THEN
51644 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51646 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51647 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51648 IDLAM(LKNT,1)=KFNCHI(IJ)
51651 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51653 XLAM(LKNT)=XLAM(LKNT-1)
51654 IDLAM(LKNT,1)=KFNCHI(IJ)
51660 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51661 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51662 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51664 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51665 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51667 IF( XXC(5).LT.AXMI ) THEN
51670 IF(XXC(6).LT.AXMI ) THEN
51676 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51678 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51679 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51680 IDLAM(LKNT,1)=KFNCHI(IJ)
51688 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51689 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51691 T3I=SIGN(1D0,EI+1D-6)/2D0
51692 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51693 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51694 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51695 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51697 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51698 CXC(4)=DCONJG(GLIJ)
51699 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51701 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51702 CXC(8)=-DCONJG(GRIJ)
51704 S12MAX=(AXMI-AXMJ)**2
51705 IF( XXC(5).LT.AXMI ) THEN
51708 IF( XXC(6).LT.AXMI ) THEN
51715 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51716 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51717 IDLAM(LKNT,1)=KFNCHI(IJ)
51721 XLAM(LKNT)=XLAM(LKNT-1)
51722 IDLAM(LKNT,1)=KFNCHI(IJ)
51727 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
51729 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51730 IF( XXC(5).LT.AXMI ) THEN
51735 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51736 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51739 XLAM(LKNT)=XLAM(LKNT-1)
51741 IDLAM(LKNT,1)=KFNCHI(IJ)
51747 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51748 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51750 T3I=SIGN(1D0,EI+1D-6)/2D0
51751 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51752 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51753 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51754 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51756 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51757 CXC(4)=DCONJG(GLIJ)
51758 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51760 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51761 CXC(8)=-DCONJG(GRIJ)
51763 S12MAX=(AXMI-AXMJ)**2
51764 IF( XXC(5).LT.AXMI ) THEN
51767 IF( XXC(6).LT.AXMI ) THEN
51773 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51775 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51776 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51777 IDLAM(LKNT,1)=KFNCHI(IJ)
51780 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51782 XLAM(LKNT)=XLAM(LKNT-1)
51783 IDLAM(LKNT,1)=KFNCHI(IJ)
51789 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51790 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51791 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51793 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51794 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51796 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51797 IF(XXC(5).LT.AXMI) THEN
51799 ELSEIF(XXC(6).LT.AXMI) THEN
51804 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51806 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51807 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51808 IDLAM(LKNT,1)=KFNCHI(IJ)
51816 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51817 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51819 T3I=SIGN(1D0,EI+1D-6)/2D0
51820 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51821 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51822 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51823 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51825 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51826 CXC(4)=DCONJG(GLIJ)
51827 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51829 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51830 CXC(8)=-DCONJG(GRIJ)
51832 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
51833 IF(XXC(5).LT.AXMI) THEN
51835 ELSEIF(XXC(6).LT.AXMI) THEN
51841 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51843 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51844 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51845 IDLAM(LKNT,1)=KFNCHI(IJ)
51848 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51850 XLAM(LKNT)=XLAM(LKNT-1)
51851 IDLAM(LKNT,1)=KFNCHI(IJ)
51859 C...CHI0_I -> CHI0_J + H0_K
51866 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
51867 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
51868 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
51869 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
51870 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
51871 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
51872 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
51873 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
51875 XMH=PMAS(ITH(IH),1)
51877 IF(AXMI.GE.AXMJ+XMH) THEN
51879 XL=PYLAMF(XMI2,XMJ2,XMH2)
51880 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
51882 C...SIGN OF MASSES I,J
51884 IF(IH.EQ.3) XMK=-XMK
51885 GX2=ABS(F21K)**2+ABS(F12K)**2
51886 GLR=DBLE(F21K*DCONJG(F12K))
51887 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51888 IDLAM(LKNT,1)=KFNCHI(IJ)
51889 IDLAM(LKNT,2)=ITH(IH)
51895 C...CHI0_I -> CHI+_J + W-
51900 IF(AXMI.GE.AXMJ+XMW) THEN
51902 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51903 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
51904 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51905 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
51906 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51907 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51908 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51909 IDLAM(LKNT,1)=KFCCHI(IJ)
51913 XLAM(LKNT)=XLAM(LKNT-1)
51914 IDLAM(LKNT,1)=-KFCCHI(IJ)
51917 ELSEIF(AXMI.GE.AXMJ) THEN
51919 S12MAX=(AXMI-AXMJ)**2
51920 RT2I = 1D0/SQRT(2D0)
51921 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51922 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
51923 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51924 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
51925 CXC(5)=DCMPLX(0D0,0D0)
51926 CXC(7)=DCMPLX(0D0,0D0)
51930 T3I=SIGN(1D0,EI+1D-6)/2D0
51932 T3J=SIGN(1D0,EJ+1D-6)/2D0
51933 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51934 & TANW+ZMIXC(IX,2)*T3J)*RT2I
51935 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51936 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
51937 CXC(6)=DCMPLX(0D0,0D0)
51938 CXC(8)=DCMPLX(0D0,0D0)
51943 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51944 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51947 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
51948 IF(XXC(5).LT.AXMI) THEN
51950 ELSEIF(XXC(6).LT.AXMI) THEN
51955 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51957 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51958 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51959 IDLAM(LKNT,1)=KFCCHI(IJ)
51963 XLAM(LKNT)=XLAM(LKNT-1)
51964 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51965 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51966 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51967 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51969 XLAM(LKNT)=XLAM(LKNT-1)
51970 IDLAM(LKNT,1)=KFCCHI(IJ)
51974 XLAM(LKNT)=XLAM(LKNT-1)
51975 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51976 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51977 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51981 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51982 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51983 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51985 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51986 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51988 IF(XXC(5).LT.AXMI) THEN
51991 IF(XXC(6).LT.AXMI) THEN
51996 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51998 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51999 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52000 XLAM(LKNT)=XLAM(LKNT-1)
52001 IDLAM(LKNT,1)=KFCCHI(IJ)
52005 XLAM(LKNT)=XLAM(LKNT-1)
52006 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52007 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52008 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52011 C...NOW, DO THE QUARKS
52016 T3I=SIGN(1D0,EI+1D-6)/2D0
52018 T3J=SIGN(1D0,EJ+1D-6)/2D0
52019 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52020 & TANW+ZMIXC(IX,2)*T3J)
52021 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52022 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52023 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52024 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52025 IF(XXC(5).LT.AXMI) THEN
52028 IF(XXC(6).LT.AXMI) THEN
52033 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52035 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52036 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52037 IDLAM(LKNT,1)=KFCCHI(IJ)
52041 XLAM(LKNT)=XLAM(LKNT-1)
52042 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52043 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52044 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52045 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52047 XLAM(LKNT)=XLAM(LKNT-1)
52048 IDLAM(LKNT,1)=KFCCHI(IJ)
52052 XLAM(LKNT)=XLAM(LKNT-1)
52053 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52054 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52055 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52063 C...CHI0_I -> CHI+_I + H-
52069 IF(AXMI.GE.AXMJ+XMHP) THEN
52071 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52072 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52073 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52074 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52076 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52077 GLR=DBLE(OLPP*DCONJG(ORPP))
52078 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52079 IDLAM(LKNT,1)=KFCCHI(IJ)
52080 IDLAM(LKNT,2)=-ITHC
52083 XLAM(LKNT)=XLAM(LKNT-1)
52084 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52085 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52086 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52092 C...2-BODY DECAYS TO FERMION SFERMION
52094 IF(J.GE.7.AND.J.LE.10) GOTO 290
52097 XMSF1=PMAS(PYCOMP(KF1),1)
52098 XMSF2=PMAS(PYCOMP(KF2),1)
52108 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52109 IF(MOD(J,2).EQ.0) THEN
52110 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52111 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52112 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52115 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52116 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52117 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52122 IF(AXMI.GE.XMF+XMSF1) THEN
52126 XL=PYLAMF(XMI2,XMA2,XMB2)
52127 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52128 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52129 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52130 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52135 XLAM(LKNT)=XLAM(LKNT-1)
52136 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52137 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52142 IF(AXMI.GE.XMF+XMSF2) THEN
52146 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52147 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52148 XL=PYLAMF(XMI2,XMA2,XMB2)
52149 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52150 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52155 XLAM(LKNT)=XLAM(LKNT-1)
52156 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52157 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52162 C...3-BODY DECAY TO Q Q~ GLUINO
52163 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52164 IF(AXMI.GE.XMJ) THEN
52165 RT2I = 1D0/SQRT(2D0)
52166 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52174 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52175 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52181 T3I=SIGN(1D0,EI+1D-6)/2D0
52182 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52183 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52187 CXC(4)=DCONJG(GLIJ)
52191 CXC(8)=-DCONJG(GRIJ)
52193 S12MAX=(AXMI-AXMJ)**2
52194 CMRENNA.This statement must be here to define S12MAX
52195 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
52196 C...ALL QUARKS BUT T
52197 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52199 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52200 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52201 IDLAM(LKNT,1)=KSUSY1+21
52204 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52206 XLAM(LKNT)=XLAM(LKNT-1)
52207 IDLAM(LKNT,1)=KSUSY1+21
52213 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52214 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52215 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52217 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52218 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52220 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
52223 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52225 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52226 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52227 IDLAM(LKNT,1)=KSUSY1+21
52234 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52235 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52236 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
52240 T3I=SIGN(1D0,EI+1D-6)/2D0
52241 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52242 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52244 CXC(4)=DCONJG(GLIJ)
52246 CXC(8)=-DCONJG(GRIJ)
52247 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52249 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52250 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52251 IDLAM(LKNT,1)=KSUSY1+21
52254 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52256 XLAM(LKNT)=XLAM(LKNT-1)
52257 IDLAM(LKNT,1)=KSUSY1+21
52265 C...R-violating decay modes (SKANDS).
52266 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
52271 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
52272 XLAM(0)=XLAM(0)+XLAM(I)
52274 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52279 C*********************************************************************
52282 C...Calculate decay widths for the charginos (admixtures of
52283 C...charged Wino and charged Higgsino.
52285 C...Input: KCIN = KF code for particle
52286 C...Output: XLAM = widths
52287 C... IDLAM = KF codes for decay particles
52288 C... IKNT = number of decay channels defined
52289 C...AUTHOR: STEPHEN MRENNA
52291 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52292 C...when CHIENU .NE. 0
52294 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
52296 C...Double precision and integer declarations.
52297 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52298 IMPLICIT INTEGER(I-N)
52299 INTEGER PYK,PYCHGE,PYCOMP
52300 C...Parameter statement to help give large particle numbers.
52301 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52302 &KEXCIT=4000000,KDIMEN=5000000)
52304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52306 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52307 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52308 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52310 C COMMON/PYINTS/XXM(20)
52312 COMMON/PYINTC/XXC(10),CXC(8)
52313 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52315 C...Local variables
52316 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52317 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52319 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52320 &XMZ,XMZ2,AXMJ,AXMI
52321 DOUBLE PRECISION S12MIN,S12MAX
52322 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52323 DOUBLE PRECISION PYLAMF,XL
52324 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52325 DOUBLE PRECISION PYX2XH,PYX2XG
52326 DOUBLE PRECISION XLAM(0:400)
52327 INTEGER IDLAM(400,3)
52328 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52331 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52332 DOUBLE PRECISION SR2
52333 DOUBLE PRECISION CBETA,SBETA,TANB
52335 DOUBLE PRECISION PYALEM,PI,PYALPS
52336 DOUBLE PRECISION FCOL
52337 INTEGER KF1,KF2,ISF
52338 INTEGER KFNCHI(4),KFCCHI(2)
52340 DOUBLE PRECISION TEMP
52341 EXTERNAL PYGAUS,PYXXZ6
52342 DOUBLE PRECISION PYGAUS,PYXXZ6
52343 DOUBLE PRECISION PREC
52346 DATA ETAH/1D0,1D0,-1D0/
52347 DATA SR2/1.4142136D0/
52348 DATA PI/3.141592654D0/
52350 DATA KFNCHI/1000022,1000023,1000025,1000035/
52351 DATA KFCCHI/1000024,1000037/
52353 C...COUNT THE NUMBER OF DECAY MODES
52361 TANW = SQRT(XW/XW1)
52363 C...1 OR 2 DEPENDING ON CHARGINO TYPE
52365 IF(KFIN.EQ.KFCCHI(2)) IX=2
52383 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52384 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52388 C...GRAVITINO DECAY MODES
52390 IF(IMSS(11).EQ.1) THEN
52393 XMGR=PMAS(PYCOMP(IDG),1)
52395 C COSW=SQRT(1D0-XW)
52396 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52397 IF(AXMI.GT.XMGR+XMW) THEN
52403 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
52404 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
52405 & (1D0-XMW2/XMI2)**4
52407 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
52412 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
52413 & (ABS(UMIXC(IX,2))*SBETA)**2))
52414 & *(1D0-PMAS(37,1)**2/XMI2)**4
52418 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52419 IF(IX.EQ.1) GOTO 170
52424 C...CHI_2+ -> CHI_1+ + Z0
52425 IF(AXMI.GE.AXMJ+XMZ) THEN
52428 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52429 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52430 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52431 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52432 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52433 GLR=DBLE(OLPP*DCONJG(ORPP))
52434 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52435 IDLAM(LKNT,1)=KFCCHI(1)
52439 C...CHARGED LEPTONS
52440 ELSEIF(AXMI.GE.AXMJ) THEN
52442 S12MAX=(AXMI-AXMJ)**2
52445 EI=KCHG(IABS(IA),1)/3D0
52446 T3I=SIGN(1D0,EI+1D-6)/2D0
52451 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52456 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52457 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52458 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52459 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52460 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52461 CXC(2)=DCMPLX(0D0,0D0)
52462 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52463 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52464 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52465 CXC(6)=DCMPLX(0D0,0D0)
52466 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52467 CXC(8)=DCMPLX(0D0,0D0)
52468 IF( XXC(5).LT.AXMI ) THEN
52473 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52475 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52476 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52477 IDLAM(LKNT,1)=KFCCHI(1)
52480 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52482 XLAM(LKNT)=XLAM(LKNT-1)
52483 IDLAM(LKNT,1)=KFCCHI(1)
52487 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52489 XLAM(LKNT)=XLAM(LKNT-1)
52490 IDLAM(LKNT,1)=KFCCHI(1)
52500 EI=KCHG(IABS(IA),1)/3D0
52501 T3I=SIGN(1D0,EI+1D-6)/2D0
52502 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52504 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52505 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52506 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52507 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52508 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52509 IF( XXC(5).LT.AXMI ) THEN
52514 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
52516 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52517 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52518 IDLAM(LKNT,1)=KFCCHI(1)
52522 XLAM(LKNT)=XLAM(LKNT-1)
52523 IDLAM(LKNT,1)=KFCCHI(1)
52527 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
52528 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52529 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52531 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52533 IF( XXC(5).LT.AXMI ) THEN
52538 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52539 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52540 IDLAM(LKNT,1)=KFCCHI(1)
52549 EI=KCHG(IABS(IA),1)/3D0
52550 T3I=SIGN(1D0,EI+1D-6)/2D0
52551 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52553 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52554 CXC(2)=DCMPLX(0D0,0D0)
52555 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52556 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52557 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52558 CXC(6)=DCMPLX(0D0,0D0)
52559 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52560 CXC(8)=DCMPLX(0D0,0D0)
52561 IF( XXC(5).LT.AXMI ) THEN
52566 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52568 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52569 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52570 IDLAM(LKNT,1)=KFCCHI(1)
52573 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52575 XLAM(LKNT)=XLAM(LKNT-1)
52576 IDLAM(LKNT,1)=KFCCHI(1)
52581 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52582 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52583 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52585 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52587 IF( XXC(5).LT.AXMI ) THEN
52592 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52593 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52594 IDLAM(LKNT,1)=KFCCHI(1)
52603 EI=KCHG(IABS(IA),1)/3D0
52604 T3I=SIGN(1D0,EI+1D-6)/2D0
52605 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52607 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52608 CXC(2)=DCMPLX(0D0,0D0)
52609 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52610 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52611 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52612 CXC(6)=DCMPLX(0D0,0D0)
52613 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52614 CXC(8)=DCMPLX(0D0,0D0)
52615 IF( XXC(5).LT.AXMI ) THEN
52620 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52622 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52623 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52624 IDLAM(LKNT,1)=KFCCHI(1)
52627 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52629 XLAM(LKNT)=XLAM(LKNT-1)
52630 IDLAM(LKNT,1)=KFCCHI(1)
52638 C...CHI_2+ -> CHI_1+ + H0_K
52646 XMH=PMAS(ITH(IH),1)
52648 C...NO 3-BODY OPTION
52649 IF(AXMI.GE.AXMJ+XMH) THEN
52651 XL=PYLAMF(XMI2,XMJ2,XMH2)
52652 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
52653 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
52654 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
52655 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
52657 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52658 GLR=DBLE(OLPP*DCONJG(ORPP))
52659 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52660 IDLAM(LKNT,1)=KFCCHI(1)
52661 IDLAM(LKNT,2)=ITH(IH)
52666 C...CHI1 JUMPS TO HERE
52669 C...CHI+_I -> CHI0_J + W+
52674 IF(AXMI.GE.AXMJ+XMW) THEN
52677 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52679 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52680 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
52681 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52682 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
52683 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52684 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52685 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52686 IDLAM(LKNT,1)=KFNCHI(IJ)
52690 ELSEIF(AXMI.GE.AXMJ) THEN
52692 S12MAX=(AXMI-AXMJ)**2
52694 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52696 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52697 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
52698 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52699 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
52700 CXC(5)=DCMPLX(0D0,0D0)
52701 CXC(7)=DCMPLX(0D0,0D0)
52705 T3I=SIGN(1D0,EI+1D-6)/2D0
52707 T3J=SIGN(1D0,EJ+1D-6)/2D0
52708 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52709 & TANW+ZMIXC(IJ,2)*T3J)/SR2
52710 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52711 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
52712 CXC(6)=DCMPLX(0D0,0D0)
52713 CXC(8)=DCMPLX(0D0,0D0)
52718 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52719 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52722 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52723 IF(XXC(5).LT.AXMI) THEN
52725 ELSEIF(XXC(6).LT.AXMI) THEN
52730 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52731 C...--> 1/(16PI)/M**3*(AEM/XW)**2
52732 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52734 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52735 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52736 IDLAM(LKNT,1)=KFNCHI(IJ)
52739 C...ONLY DECAY CHI+1 -> E+ NU_E
52740 IF( IMSS(12).NE. 0 ) GOTO 260
52741 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52743 XLAM(LKNT)=XLAM(LKNT-1)
52744 IDLAM(LKNT,1)=KFNCHI(IJ)
52749 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52751 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52752 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52754 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52756 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52757 IF(XXC(5).LT.AXMI) THEN
52759 ELSEIF(XXC(6).LT.AXMI) THEN
52764 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52765 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52766 IDLAM(LKNT,1)=KFNCHI(IJ)
52771 C...NOW, DO THE QUARKS
52776 T3I=SIGN(1D0,EI+1D-6)/2D0
52778 T3J=SIGN(1D0,EJ+1D-6)/2D0
52779 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52780 & TANW+ZMIXC(IJ,2)*T3J)
52781 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52782 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
52783 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52784 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52785 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
52786 IF(XXC(5).LT.AXMI) THEN
52789 IF(XXC(6).LT.AXMI) THEN
52794 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52796 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52797 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52798 IDLAM(LKNT,1)=KFNCHI(IJ)
52801 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52803 XLAM(LKNT)=XLAM(LKNT-1)
52804 IDLAM(LKNT,1)=KFNCHI(IJ)
52813 C...CHI+_I -> CHI0_J + H+
52819 IF(AXMI.GE.AXMJ+XMHP) THEN
52821 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
52822 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
52823 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
52824 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
52826 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52827 GLR=DBLE(OLPP*DCONJG(ORPP))
52828 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52829 IDLAM(LKNT,1)=KFNCHI(IJ)
52837 C...2-BODY DECAYS TO FERMION SFERMION
52839 IF(J.GE.7.AND.J.LE.10) GOTO 240
52840 IF(MOD(J,2).EQ.0) THEN
52846 XMSF1=PMAS(PYCOMP(KF1),1)
52847 XMSF2=PMAS(PYCOMP(KF2),1)
52856 IF(MOD(J,2).EQ.0) THEN
52859 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
52860 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
52866 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
52868 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
52873 IF(AXMI.GE.XMF+XMSF1) THEN
52877 XL=PYLAMF(XMI2,XMA2,XMB2)
52878 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
52879 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
52880 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52881 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52883 IF(MOD(J,2).EQ.0) THEN
52893 IF(AXMI.GE.XMF+XMSF2) THEN
52897 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
52898 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
52899 XL=PYLAMF(XMI2,XMA2,XMB2)
52900 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52901 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52903 IF(MOD(J,2).EQ.0) THEN
52913 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52914 C...A 2-BODY -- 2-BODY CHAIN
52915 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52916 IF(AXMI.GE.XMJ) THEN
52919 S12MAX=(AXMI-AXMJ)**2
52924 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
52925 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
52928 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
52930 CXC(1)=DCMPLX(0D0,0D0)
52931 CXC(3)=DCMPLX(0D0,0D0)
52932 CXC(5)=DCMPLX(0D0,0D0)
52933 CXC(7)=DCMPLX(0D0,0D0)
52934 CXC(2)=UMIXC(IX,1)*OLPP/SR2
52935 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
52936 CXC(6)=DCMPLX(0D0,0D0)
52937 CXC(8)=DCMPLX(0D0,0D0)
52938 IF(XXC(5).LT.AXMI) THEN
52940 ELSEIF(XXC(6).LT.AXMI) THEN
52945 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
52946 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52948 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52949 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52950 IDLAM(LKNT,1)=KSUSY1+21
52953 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52955 XLAM(LKNT)=XLAM(LKNT-1)
52956 IDLAM(LKNT,1)=KSUSY1+21
52964 C...R-violating decay modes (SKANDS).
52965 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
52970 XLAM(0)=XLAM(0)+XLAM(I)
52971 IF(XLAM(I).LT.0D0) THEN
52972 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52973 & (IDLAM(I,J),J=1,3)
52977 IF(XLAM(0).EQ.0D0) THEN
52979 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52980 WRITE(MSTU(11),*) LKNT
52981 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52987 C*********************************************************************
52990 C...Used in the calculation of inoi -> inoj + f + ~f.
52994 C...Double precision and integer declarations.
52995 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52996 IMPLICIT INTEGER(I-N)
52997 INTEGER PYK,PYCHGE,PYCOMP
52998 C...Parameter statement to help give large particle numbers.
52999 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53000 &KEXCIT=4000000,KDIMEN=5000000)
53002 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53003 C COMMON/PYINTS/XXM(20)
53005 COMMON/PYINTC/XXC(10),CXC(8)
53006 SAVE /PYDAT1/,/PYINTC/
53008 C...Local variables.
53009 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53010 DOUBLE PRECISION PYXXZ6,X
53011 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53012 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53013 DOUBLE PRECISION SIJ
53014 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53015 DOUBLE PRECISION OL2
53016 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53019 C...Statement functions.
53020 C...Integral from x to y of (t-a)(b-t) dt.
53021 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53022 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53023 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53024 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53025 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53026 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53027 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53028 C...Integral from x to y of (t-a)/(b-t) dt.
53029 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53030 C...Integral from x to y of 1/(t-a) dt.
53031 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53039 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53040 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53041 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53043 S23MIN=(S23AVE-S23DEL)
53044 S23MAX=(S23AVE+S23DEL)
53061 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53062 SIJ=2D0*XXC(2)*XXC(4)*S13
53063 IF(XMV.LE.1000D0) THEN
53064 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53065 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53066 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53067 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53068 IF(XXC(5).LE.10000D0) THEN
53069 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53070 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53071 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53072 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53073 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53074 & *(S13-XMV**2)/WPROP2
53079 IF(XXC(6).LE.10000D0) THEN
53080 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53081 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53082 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53083 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53084 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53085 & *(S13-XMV**2)/WPROP2
53094 IF(XXC(5).LE.10000D0) THEN
53095 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53096 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53097 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53098 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53102 IF(XXC(6).LE.10000D0) THEN
53103 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53104 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53105 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53106 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53111 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53113 IF(PYXXZ6.LT.0D0) THEN
53114 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53115 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53116 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53117 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53118 WRITE(MSTU(11),*) S23MIN,S23MAX
53126 C*********************************************************************
53129 C...Calculates chi0_i -> chi0_j + gamma.
53131 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53133 C...Double precision and integer declarations.
53134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53135 IMPLICIT INTEGER(I-N)
53136 INTEGER PYK,PYCHGE,PYCOMP
53138 C...Local variables.
53139 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53140 DOUBLE PRECISION F1,F2
53142 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53143 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53144 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53145 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53150 C*********************************************************************
53153 C...Calculates the decay rate for ino -> ino + gauge boson.
53155 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53157 C...Double precision and integer declarations.
53158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53159 IMPLICIT INTEGER(I-N)
53160 INTEGER PYK,PYCHGE,PYCOMP
53162 C...Local variables.
53163 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53164 DOUBLE PRECISION XL,PYLAMF,C1
53165 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53171 XL=PYLAMF(XMI2,XMJ2,XMV2)
53172 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53173 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53174 &12D0*GLR*XM1*XM2*XMV2)
53179 C*********************************************************************
53182 C...Calculates the decay rate for ino -> ino + H.
53184 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53186 C...Double precision and integer declarations.
53187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53188 IMPLICIT INTEGER(I-N)
53189 INTEGER PYK,PYCHGE,PYCOMP
53191 C...Local variables.
53192 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53193 DOUBLE PRECISION XL,PYLAMF,C1
53194 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53200 XL=PYLAMF(XMI2,XMJ2,XMV2)
53201 PYX2XH=C1/8D0/XMI3*SQRT(XL)
53202 &*(GX2*(XMI2+XMJ2-XMV2)+
53208 C*********************************************************************
53211 C...Calculates the non-standard decay modes of the Higgs boson.
53213 C...Author: Stephen Mrenna
53214 C...Last Update: April 2001
53215 C......Allow complex values for Z,U, and V
53217 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
53219 C...Double precision and integer declarations.
53220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53221 IMPLICIT INTEGER(I-N)
53222 INTEGER PYK,PYCHGE,PYCOMP
53223 C...Parameter statement to help give large particle numbers.
53224 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53225 &KEXCIT=4000000,KDIMEN=5000000)
53227 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53228 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53229 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53230 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53231 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53232 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53233 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
53235 C...Local variables.
53236 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53237 COMPLEX*16 QIJ,RIJ,F21K,F12K
53239 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53240 DOUBLE PRECISION XMI2,XMI3,XMJ2
53241 DOUBLE PRECISION PYLAMF,XL,CF,EI
53243 DOUBLE PRECISION TANW,XW,AEM,C1,AS
53244 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53245 DOUBLE PRECISION XLAM(0:400)
53246 INTEGER IDLAM(400,3)
53247 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53249 INTEGER KFNCHI(4),KFCCHI(2)
53250 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53251 DOUBLE PRECISION SR2
53252 DOUBLE PRECISION BETA,ALFA
53253 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53254 DOUBLE PRECISION PYALEM
53255 DOUBLE PRECISION AL,AR,ALR
53256 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53257 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53258 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53259 DATA ITH/25,35,36,37/
53260 DATA ETAH/1D0,1D0,-1D0/
53261 DATA SR2/1.4142136D0/
53262 DATA KFNCHI/1000022,1000023,1000025,1000035/
53263 DATA KFCCHI/1000024,1000037/
53265 C...COUNT THE NUMBER OF DECAY MODES
53272 TANW = SQRT(XW/(1D0-XW))
53275 C...1 - 4 DEPENDING ON Higgs species.
53277 IF(KFIN.EQ.ITH(2)) IH=2
53278 IF(KFIN.EQ.ITH(3)) IH=3
53279 IF(KFIN.EQ.ITH(4)) IH=4
53302 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
53307 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53308 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53313 IF(IH.EQ.4) GOTO 220
53315 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53316 C...H0_K -> CHI0_I + CHI0_J
53329 IF(AXMI.GE.AXMJ+AXMK) THEN
53331 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
53332 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
53333 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
53334 & ZMIXC(IJ,3)*ZMIXC(IK,1))
53335 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
53336 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
53337 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
53338 & ZMIXC(IJ,4)*ZMIXC(IK,1))
53339 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
53340 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
53341 C...SIGN OF MASSES I,J
53343 GX2=ABS(F12K)**2+ABS(F21K)**2
53344 GLR=DBLE(F12K*DCONJG(F21K))
53345 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53346 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
53347 IDLAM(LKNT,1)=KFNCHI(IJ)
53348 IDLAM(LKNT,2)=KFNCHI(IK)
53354 C...H0_K -> CHI+_I CHI-_J
53361 IF(AXMI.GE.AXMJ+AXMK) THEN
53363 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
53364 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
53365 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
53366 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
53367 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53368 GLR=DBLE(OLPP*DCONJG(ORPP))
53370 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53371 IDLAM(LKNT,1)=KFCCHI(IJ)
53372 IDLAM(LKNT,2)=-KFCCHI(IK)
53378 C...HIGGS TO SFERMION SFERMION
53380 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
53382 XMJL=PMAS(PYCOMP(IJ),1)
53383 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
53384 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
53387 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53394 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
53395 & XMF**2/XMW*SINA/CBETA
53396 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
53397 & XMF**2/XMW*SINA/CBETA
53399 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53401 ELSEIF(IFL.EQ.15) THEN
53402 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53408 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
53409 & XMF**2/XMW*COSA/SBETA
53410 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
53411 & XMF**2/XMW*COSA/SBETA
53413 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
53420 ELSEIF(IH.EQ.2) THEN
53422 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
53423 & XMF**2/XMW*COSA/CBETA
53424 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53425 & XMF**2/XMW*COSA/CBETA
53427 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53429 ELSEIF(IFL.EQ.15) THEN
53430 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53436 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
53437 & XMF**2/XMW*SINA/SBETA
53438 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53439 & XMF**2/XMW*SINA/SBETA
53441 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
53448 ELSEIF(IH.EQ.3) THEN
53454 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
53455 ELSEIF(IFL.EQ.15) THEN
53456 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
53460 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
53464 IF(IH.EQ.3) GOTO 180
53468 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
53475 IF(AXMI.GE.2D0*XMJ) THEN
53477 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53479 & +2D0*GHLR*ALR)**2
53485 IF(AXMI.GE.2D0*XMJR) THEN
53489 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
53492 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53493 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53495 & +2D0*GHLR*ALR)**2
53496 IDLAM(LKNT,1)=IJ+KSUSY1
53497 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53502 IF(AXMI.GE.XMJL+XMJR) THEN
53504 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
53505 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
53506 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
53509 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
53510 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53511 & (GHLL*AL+GHRR*AR)**2
53513 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53517 IDLAM(LKNT,2)=IJ+KSUSY1
53519 XLAM(LKNT)=XLAM(LKNT-1)
53529 C...H+ -> CHI+_I + CHI0_J
53537 IF(AXMI.GE.AXMJ+AXMK) THEN
53539 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
53540 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
53541 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
53542 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
53543 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53544 GLR=DBLE(OLPP*DCONJG(ORPP))
53545 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
53546 IDLAM(LKNT,1)=KFNCHI(IJ)
53547 IDLAM(LKNT,2)=KFCCHI(IK)
53553 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
53554 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
53560 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53561 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53562 IF(XMI.GE.XM1+XM2) THEN
53563 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53565 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53566 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
53567 IDLAM(LKNT,1)=KSUSY1+6
53568 IDLAM(LKNT,2)=-(KSUSY1+5)
53573 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53574 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53575 IF(XMI.GE.XM1+XM2) THEN
53576 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53578 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53579 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
53580 IDLAM(LKNT,1)=KSUSY2+6
53581 IDLAM(LKNT,2)=-(KSUSY1+5)
53586 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53587 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53588 IF(XMI.GE.XM1+XM2) THEN
53589 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53591 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53592 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
53593 IDLAM(LKNT,1)=KSUSY1+6
53594 IDLAM(LKNT,2)=-(KSUSY2+5)
53599 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53600 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53601 IF(XMI.GE.XM1+XM2) THEN
53602 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53604 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53605 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
53606 IDLAM(LKNT,1)=KSUSY2+6
53607 IDLAM(LKNT,2)=-(KSUSY2+5)
53612 GL=-XMW/SR2*SIN(2D0*BETA)
53614 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53615 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53616 IF(XMI.GE.XM1+XM2) THEN
53617 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53619 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53620 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53621 IDLAM(LKNT,2)=KSUSY1+IJ+1
53629 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53630 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53631 IF(XMI.GE.XM1+XM2) THEN
53632 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53634 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53635 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53636 IDLAM(LKNT,2)=KSUSY1+IJ+1
53641 C...H+ -> TAU1 NUTAUL
53642 XM1=PMAS(PYCOMP(KSUSY1+15),1)
53643 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53644 IF(XMI.GE.XM1+XM2) THEN
53645 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53647 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
53648 IDLAM(LKNT,1)=-(KSUSY1+15)
53649 IDLAM(LKNT,2)= KSUSY1+16
53653 C...H+ -> TAU2 NUTAUL
53654 XM1=PMAS(PYCOMP(KSUSY2+15),1)
53655 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53656 IF(XMI.GE.XM1+XM2) THEN
53657 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53659 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
53660 IDLAM(LKNT,1)=-(KSUSY2+15)
53661 IDLAM(LKNT,2)= KSUSY1+16
53669 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
53670 XLAM(0)=XLAM(0)+XLAM(I)
53672 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53677 C*********************************************************************
53680 C...Calculates the decay rate for a Higgs to an ino pair.
53682 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
53684 C...Double precision and integer declarations.
53685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53686 IMPLICIT INTEGER(I-N)
53687 INTEGER PYK,PYCHGE,PYCOMP
53689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53692 C...Local variables.
53693 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53694 DOUBLE PRECISION XL,PYLAMF,C1
53695 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53701 XL=PYLAMF(XMI2,XMJ2,XMK2)
53702 PYH2XX=C1/4D0/XMI3*SQRT(XL)
53703 &*(GX2*(XMI2-XMJ2-XMK2)-
53705 IF(PYH2XX.LT.0D0) PYH2XX=0D0
53710 C*********************************************************************
53713 C...Integration by adaptive Gaussian quadrature.
53714 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53716 FUNCTION PYGAUS(F, A, B, EPS)
53718 C...Double precision and integer declarations.
53719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53720 IMPLICIT INTEGER(I-N)
53721 INTEGER PYK,PYCHGE,PYCOMP
53723 C...Local declarations.
53725 DOUBLE PRECISION F,W(12), X(12)
53726 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53727 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53728 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53729 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53730 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53731 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53732 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53733 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53734 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53735 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53736 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53737 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53739 C...The Gaussian quadrature algorithm.
53741 IF(B .EQ. A) GOTO 140
53742 CONST = 5D-3 / ABS(B-A)
53753 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53758 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53761 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53763 IF(BB .NE. B) GOTO 100
53766 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53768 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
53777 C*********************************************************************
53780 C...Integration by adaptive Gaussian quadrature.
53781 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53782 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53784 FUNCTION PYGAU2(F, A, B, EPS)
53786 C...Double precision and integer declarations.
53787 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53788 IMPLICIT INTEGER(I-N)
53789 INTEGER PYK,PYCHGE,PYCOMP
53791 C...Local declarations.
53793 DOUBLE PRECISION F,W(12), X(12)
53794 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53795 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53796 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53797 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53798 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53799 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53800 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53801 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53802 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53803 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53804 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53805 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53807 C...The Gaussian quadrature algorithm.
53809 IF(B .EQ. A) GOTO 140
53810 CONST = 5D-3 / ABS(B-A)
53821 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53826 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53829 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53831 IF(BB .NE. B) GOTO 100
53834 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53836 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
53845 C*********************************************************************
53848 C...Simpson formula for an integral.
53850 FUNCTION PYSIMP(Y,X0,X1,N)
53852 C...Double precision and integer declarations.
53853 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53854 IMPLICIT INTEGER(I-N)
53855 INTEGER PYK,PYCHGE,PYCOMP
53857 C...Local variables.
53858 DOUBLE PRECISION Y,X0,X1,H,S
53864 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
53871 C*********************************************************************
53874 C...The standard lambda function.
53876 FUNCTION PYLAMF(X,Y,Z)
53878 C...Double precision and integer declarations.
53879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53880 IMPLICIT INTEGER(I-N)
53881 INTEGER PYK,PYCHGE,PYCOMP
53883 C...Local variables.
53884 DOUBLE PRECISION PYLAMF,X,Y,Z
53886 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
53887 IF(PYLAMF.LT.0D0) PYLAMF=0D0
53892 C*********************************************************************
53895 C...Generates 3-body decays of gauginos.
53897 SUBROUTINE PYTBDY(IDIN)
53899 C...Double precision and integer declarations.
53900 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53901 IMPLICIT INTEGER(I-N)
53902 INTEGER PYK,PYCHGE,PYCOMP
53903 C...Parameter statement to help give large particle numbers.
53904 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53905 &KEXCIT=4000000,KDIMEN=5000000)
53907 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53908 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53909 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53910 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53911 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53912 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53913 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53914 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53915 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
53917 C...Local variables.
53918 DOUBLE PRECISION XM(5)
53919 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53920 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53921 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53922 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53923 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53924 DOUBLE PRECISION CPHI1,SPHI1
53925 DOUBLE PRECISION S23DEL,EPS
53926 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53927 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
53928 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53930 DATA INOID/22,23,25,35/
53941 S12MIN=(XM(1)+XM(2))**2
53942 S12MAX=(XM(5)-XM(3))**2
53943 YJACO1=S12MAX-S12MIN
53945 C...Initialize some parameters
53957 C...Mrenna: check that we are indeed decaying a SUSY particle
53958 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
53962 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
53963 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
53965 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
53966 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
53967 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
53968 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
53971 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53972 T3I=SIGN(1D0,EI+1D-6)/2D0
53975 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53977 ELSEIF(IZID1*IZID2.NE.0) THEN
53979 GMMZ=PMAS(23,1)*PMAS(23,2)
53981 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53982 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53984 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53985 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53987 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53989 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53991 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53992 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53993 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53994 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53995 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53997 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53999 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
54001 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
54003 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
54004 IF(IZID1.NE.0) THEN
54005 XM1M2=SMZ(IZID1)*SMW(IWID2)
54009 XM1M2=SMZ(IZID2)*SMW(IWID1)
54012 RT2I = 1D0/SQRT(2D0)
54014 GMMZ=PMAS(24,1)*PMAS(24,2)
54016 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54017 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54020 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54022 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54023 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54024 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54025 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54026 EJ=KCHG(IABS(JA),1)/3D0
54027 T3J=SIGN(1D0,EJ+1D-6)/2D0
54028 QRLS=DCMPLX(0D0,0D0)
54034 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54035 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54036 IF(MOD(IA,2).EQ.0) THEN
54037 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54038 & TANW+ZMIXC(IZID2,2)*T3I)
54039 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54040 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54042 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54043 & TANW+ZMIXC(IZID2,2)*T3J)
54044 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54045 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54047 ELSEIF(IWID1*IWID2.NE.0) THEN
54050 XM1M2=SMW(IWID1)*SMW(IWID2)
54052 GMMZ=PMAS(23,1)*PMAS(23,2)
54054 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54055 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54056 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54057 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54059 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54060 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54061 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54062 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54063 QRLS=-DCMPLX(EI/XW1)*ORPP
54064 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54065 QRRS=-DCMPLX(EI/XW1)*OLPP
54066 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54067 IF(MOD(IA,2).EQ.0) THEN
54068 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54069 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54071 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54072 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54074 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54081 IF(ISKIP.NE.0) THEN
54084 S12=S12MIN+YJACO1*(KT-1)/99
54085 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54086 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54087 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54088 & -(2D0*XM(1)*XM(2))**2
54089 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54090 & -(2D0*XM(3)*XM(5))**2
54093 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54095 S23MIN=S23AVE-S23DEL
54096 S23MAX=S23AVE+S23DEL
54097 YJACO2=S23MAX-S23MIN
54100 S23=S23MIN+YJACO2*(KS-1)/99
54103 WU2 = (UH-ZM12)*(UH-ZM22)
54104 WT2 = (TH-ZM12)*(TH-ZM22)
54106 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54107 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54108 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54109 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54110 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54111 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54112 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54113 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54114 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54115 IF(WT0.GT.WTMAX) WTMAX=WT0
54125 BX=S12MIN+0.5D0*YJACO1
54128 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54136 C...SOLVE FOR F1 AND F2
54137 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54138 &-(2D0*XM(1)*XM(2))**2
54139 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54140 &-(2D0*XM(3)*XM(5))**2
54143 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54145 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54146 &-(2D0*XM(1)*XM(2))**2
54147 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54148 &-(2D0*XM(3)*XM(5))**2
54151 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54154 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54155 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54161 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54162 & -(2D0*XM(1)*XM(2))**2
54163 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54164 & -(2D0*XM(3)*XM(5))**2
54167 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54174 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54175 & -(2D0*XM(1)*XM(2))**2
54176 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54177 & -(2D0*XM(3)*XM(5))**2
54180 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54185 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54195 180 S12=S12MIN+PYR(0)*YJACO1
54198 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54199 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54200 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54201 &-(2D0*XM(1)*XM(2))**2
54202 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54203 &-(2D0*XM(3)*XM(5))**2
54206 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54208 S23MIN=S23AVE-S23DEL
54209 S23MAX=S23AVE+S23DEL
54210 YJACO2=S23MAX-S23MIN
54211 S23=S23MIN+PYR(0)*YJACO2
54213 C...CHECK THE SAMPLING
54214 IF(IKNT.GT.100) THEN
54215 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
54218 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
54220 IF(ISKIP.EQ.0) GOTO 190
54226 WU2 = (UH-ZM12)*(UH-ZM22)
54227 WT2 = (TH-ZM12)*(TH-ZM22)
54229 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54230 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54232 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54233 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54234 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54235 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54236 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54237 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54238 c &/DCMPLX(TH-XML2)
54239 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54240 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54241 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54242 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54243 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
54244 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54246 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
54247 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
54249 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
54250 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
54252 P1=SQRT(D1*D1-XM(1)**2)
54253 P2=SQRT(D2*D2-XM(2)**2)
54254 P3=SQRT(D3*D3-XM(3)**2)
54255 CTHE1=2D0*PYR(0)-1D0
54256 ANG1=2D0*PYR(0)*PARU(1)
54260 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54262 P(N+1,1)=P1*STHE1*CPHI1
54263 P(N+1,2)=P1*STHE1*SPHI1
54268 ANG3=2D0*PYR(0)*PARU(1)
54271 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
54273 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54275 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
54276 &+P3*STHE3*SPHI3*SPHI1
54277 &+P3*CTHE3*STHE1*CPHI1
54278 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
54279 &-P3*STHE3*SPHI3*CPHI1
54280 &+P3*CTHE3*STHE1*SPHI1
54281 P(N+3,3)=P3*STHE3*CPHI3*STHE1
54286 P(N+2,I)=-P(N+1,I)-P(N+3,I)
54294 C*********************************************************************
54297 C...Finds the s-hat dependent eigenvalues of the inverse propagator
54298 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54299 C...phase space generation. Extended to include techni-a meson, and
54300 C...to return the width.
54302 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
54304 C...Double precision and integer declarations.
54305 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54306 IMPLICIT INTEGER(I-N)
54307 INTEGER PYK,PYCHGE,PYCOMP
54308 C...Parameter statement to help give large particle numbers.
54309 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54310 &KEXCIT=4000000,KDIMEN=5000000)
54312 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54313 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54314 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54315 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54316 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
54318 C...Local variables.
54319 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54320 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
54321 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
54328 SINW=MIN(SQRT(PARU(102)),1D0)
54329 COSW=SQRT(1D0-SINW**2)
54331 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
54332 QUPD=2D0*RTCM(2)-1D0
54334 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
54335 FAR=SQRT(AEM/ALPRHT)
54339 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
54352 AR(2,2) = SH-PMAS(23,1)**2
54353 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
54354 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
54355 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
54376 CALL PYWIDT(23,SH,WDTP,WDTE)
54377 AT(2,2) = WDTP(0)*SHR
54378 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
54379 AT(3,3) = WDTP(0)*SHR
54380 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
54381 AT(4,4) = WDTP(0)*SHR
54382 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
54383 AT(5,5) = WDTP(0)*SHR
54387 AR(1,1) = SH-PMAS(24,1)**2
54388 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
54389 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
54396 CALL PYWIDT(24,SH,WDTP,WDTE)
54397 AT(1,1) = WDTP(0)*SHR
54398 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
54399 AT(2,2) = WDTP(0)*SHR
54400 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
54401 AT(3,3) = WDTP(0)*SHR
54404 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
54409 WX(I)=SQRT(ABS(SH-WR(I)))
54411 IF(WR(I).LT.SXMN) THEN
54421 C*********************************************************************
54424 C...Universal Extra Dimensions Model (UED)
54425 C...Initialize the xd masses and widths
54426 C...M. ELKACIMI 4/03/2006
54427 C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54431 C...Double precision and integer declarations.
54432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54433 IMPLICIT INTEGER(I-N)
54434 INTEGER PYK,PYCHGE,PYCOMP
54436 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54437 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54438 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54439 C...UED Pythia common
54440 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54442 C...SAVE statements
54443 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
54445 C...Print out some info about the UED model
54446 WRITE(MSTU(11),7000)
54448 & '********** PYXDIN: initialization of UED ******************',
54450 & 'Universal Extra Dimensions (UED) switched on ',
54452 & 'This implementation is courtesy of',
54453 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54454 & ' see [hep-ph/0602198] (Les Houches 2005) ',
54456 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54457 & 'Dobrescu), with gravity-mediated decay widths calculated in',
54458 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54459 & 'radiative corrections to the KK masses from [hep/ph0204342]',
54460 & '(Cheng, Matchev, Schmaltz).'
54461 WRITE(MSTU(11),7000)
54463 & 'SM particles can propagate into one small extra dimension ',
54464 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54465 & 'graviton is further allowed to propagate into N = IUED(4)',
54466 & 'large (eV^-1) extra dimensions.'
54467 WRITE(MSTU(11),7000)
54469 & 'The switches and parameters for UED are:',
54470 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54471 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54472 & ' IUED(3): (D=5) number of quark flavours',
54473 & ' IUED(4): (D=6) number of large extra dimensions into',
54474 & ' which the graviton propagates',
54475 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54476 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54478 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54479 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54480 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54481 & ' when IUED(5)=0',
54482 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54483 WRITE(MSTU(11),7000)
54485 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54486 & 'model, but is set through pmas(25,1).',
54489 C...Hardcoded switch, required by current implementation
54490 CALL PYGIVE('MSTP(42)=0')
54492 C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54493 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
54495 C...Calculated the radiative corrections to the KK particle masses
54498 C...Initialize the graviton mass
54499 C...only if the KK particles decays gravitationally
54500 IF(IUED(2).EQ.1) CALL PYGRAM(0)
54502 WRITE(MSTU(11),7000)
54503 & '********** PYXDIN: UED initialization completed ***********'
54505 C...Format to use for comments
54506 7000 FORMAT(' * ',A)
54510 C*********************************************************************
54513 C...Auxiliary to PYXDIN
54514 C...Mass kk states radiative corrections
54515 C...Radiative corrections are included (hep/ph0204342)
54519 C...Double precision and integer declarations.
54520 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54521 IMPLICIT INTEGER(I-N)
54522 INTEGER PYK,PYCHGE,PYCOMP
54524 PARAMETER(KKPART=25,KKFLA=450)
54526 C...UED Pythia common
54527 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54528 C...Pythia common: particles properties
54529 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54531 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54532 C...Decay information.
54533 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54534 C...Resonance width and secondary decay treatment.
54535 COMMON/PYINT4/MWID(500),WIDS(500,5)
54536 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54538 C...Local variables
54539 DOUBLE PRECISION PI,QUP,QDW
54540 DOUBLE PRECISION WDTP,WDTE
54541 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54542 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54543 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54544 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54545 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54546 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54547 DOUBLE PRECISION SWW1,CWW1
54548 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54549 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54550 DOUBLE PRECISION SW21,CW21,SW021,CW021
54551 COMMON/SW1/SW021,CW021
54552 C...UED related declarations:
54553 C...equivalences between ordered particles (451->475)
54554 C...and UED particle code (5 000 000 + id)
54555 DIMENSION IUEDEQ(475)
54556 DATA (IUEDEQ(I),I=451,475)/
54558 & 6100001,6100002,6100003,6100004,6100005,6100006,
54560 & 5100001,5100002,5100003,5100004,5100005,5100006,
54561 C...Singlet leptons
54562 & 6100011,6100013,6100015,
54563 C...Doublet leptons
54564 & 5100012,5100011,5100014,5100013,5100016,5100015,
54565 C...Gauge boson KK excitations
54566 & 5100021,5100022,5100023,5100024/
54568 C...N.B. rinv=rued(1)
54569 IF(RUED(1).LE.0.)THEN
54570 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
54571 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54584 c...qt is q-tilde, qs is q-star
54585 c...strong coupling value
54589 c...weak mixing angle
54593 c...for the mass corrections
54598 C... Either fix the cutoff scale LAMUED
54599 IF(IUED(5).EQ.0)THEN
54600 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
54601 C... or the ratio LAMUED/RINV (=product Lambda*R)
54602 ELSEIF(IUED(5).EQ.1)THEN
54603 LOGLAM = DLOG(RUED(4)**2)
54605 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54609 C...Calculate the radiative corrections for the UED KK masses
54610 IF(IUED(6).EQ.1)THEN
54612 C...or induce a minute mass difference
54613 C...keeping the UED KK mass values nearly equal to 1/R
54614 ELSEIF(IUED(6).EQ.0)THEN
54617 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54621 c...Take into account only the strong interactions:
54623 c...The space bulk corrections :
54624 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
54625 c...The boundary terms:
54626 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
54628 c...Mass corrections for fermions are extracted from
54629 c...Phys. Rev. D66 036005(2002)9
54630 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
54631 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
54632 DBMQU=RMKK*(3.*(ALPHS/4./PI)
54633 . +(ALPHEM/4./PI/CW2))*LOGLAM
54634 DBMQD=RMKK*(3.*(ALPHS/4./PI)
54635 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
54637 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
54638 . (ALPHEM/4./PI/CW2))*LOGLAM
54639 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
54641 c...Vector boson masss matrix diagonalization
54642 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
54643 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
54644 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
54645 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
54647 c...Elements of the mass matrix
54648 A = RMZ2*SW2 + DBMB2 + DSMB2
54649 B = RMZ2*CW2 + DBMA2 + DSMA2
54650 C = RMZ2*DSQRT(SW2*CW2)
54651 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
54653 c...Eigenvalues: corrections to X1 and Z1 masses
54654 DMB2 = (A+B-SQRDEL)/2.
54655 DMA2 = (A+B+SQRDEL)/2.
54657 c...Rotation angles
54661 SW21= SWW1**2/(SWW1**2 + CWW1**2)
54668 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
54670 RMDQST=RMKK+RFACT*DBMQDO
54671 RMSQUS=RMKK+RFACT*DBMQU
54672 RMSQDS=RMKK+RFACT*DBMQD
54674 C...Note: MZ mass is included in ma2
54675 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
54676 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
54677 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
54679 RMLSLD=RMKK+RFACT*DBMLDO
54680 RMLSLE=RMKK+RFACT*DBMLE
54683 PMAS(KKFLA+IPART,1)=RMSQDS
54686 PMAS(KKFLA+IPART,1)=RMSQUS
54689 PMAS(KKFLA+IPART,1)=RMDQST
54692 PMAS(KKFLA+IPART,1)=RMLSLE
54695 PMAS(KKFLA+IPART,1)=RMLSLD
54697 PMAS(KKFLA+22,1)=RMGST
54698 PMAS(KKFLA+23,1)=RMPHST
54699 PMAS(KKFLA+24,1)=RMZST
54700 PMAS(KKFLA+25,1)=RMWST
54702 WRITE(MSTU(11),7000) ' PYUEDC: ',
54703 & 'UED Mass Spectrum (GeV) :'
54704 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
54705 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
54706 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
54707 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
54708 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
54709 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
54710 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
54711 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
54712 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
54713 WRITE(MSTU(11),7000) ' '
54715 C...Initialize widths, branching ratios and life time
54718 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
54719 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
54720 IF(WDTP(0).LE.0)THEN
54722 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
54723 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
54726 DO 180 IDC=1,MDCY(KC,3)
54727 IC=IDC+MDCY(KC,2)-1
54728 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
54729 C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54730 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
54731 BRAT(IC)=WDTP(IDC)/WDTP(0)
54738 C...Format to use for comments
54739 7000 FORMAT(' * ',A)
54740 7100 FORMAT(' * ',A,F12.3)
54743 C********************************************************************
54746 C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54747 C... Original version:
54750 C Universal Extra Dimensions Subprocess cross sections
54751 C The expressions used are from atl-com-phys-2005-003
54752 C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54753 C For each UED subprocess, the color flow used is the same
54754 C as the equivalent QCD subprocess. Different configuration
54755 C color flows are considered to have the same probability.
54757 C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54758 C by G.Azuelos and P.H.Beauchemin.
54760 C This routine is called from pysigh.
54762 SUBROUTINE PYXUED(NCHN,SIGS)
54764 C...Double precision and integer declarations
54765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54766 IMPLICIT INTEGER(I-N)
54769 COMMON/DECMOD/NGRDEC
54771 PARAMETER(KKPART=25,KKFLA=450)
54773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54774 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54775 COMMON/PYINT1/MINT(400),VINT(400)
54776 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
54777 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
54778 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
54779 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
54780 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
54781 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
54782 C...UED Pythia common
54783 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54784 C...Local arrays and complex variables
54785 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54786 + ,FAC1,XMNKK,XMUED,SIGS
54789 C...Return if UED not switched on
54790 IF (IUED(1).LE.0) THEN
54794 C...Energy scale of the parton processus
54795 C...taken equal to the mass of the final state kk
54798 C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54799 XMNKK=PMAS(KKFLA+23,1)
54801 C...To compare the cross section with phys-pub-2005-03
54802 C...(no radiative corrections),
54803 C...take xmnkk=rinv and q2=rinv**2
54805 C...n.b. (rinv=rued(1))
54806 c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54807 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
54816 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
54819 c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54820 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
54822 c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54823 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
54826 C...Strong coupling value
54829 IF(ISUB.EQ.311)THEN
54831 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
54832 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
54833 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
54834 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
54835 & 12.*TP**2*UP**3+6*TP*UP**4)
54836 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
54837 & 15.*TP**3*UP**3+13*TP**2*UP**4+
54838 & 6.*TP*UP**5+2.*UP**6)
54842 C...Three color flow configurations (qcd g+g->g+g)
54844 IF(XCOL.LE.1./3.)THEN
54846 ELSEIF(XCOL.LE.2./3.)THEN
54851 SIGH(NCHN)=COMFAC*XMUED
54852 ELSEIF(ISUB.EQ.312)THEN
54853 C...q + g -> q*_D + g*, q*_S + g*
54854 C...(the two channels have the same cross section)
54855 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
54856 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
54857 & 5.*SP**4*UP**2+12.*SP**5*UP)
54858 XMUED=COMFAC*2.*XMUED
54860 DO 190 I=MMINA,MMAXA
54861 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
54864 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
54865 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
54868 ISIG(NCHN,3-ISDE)=21
54871 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54875 ELSEIF(ISUB.EQ.313)THEN
54876 C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54877 C...(the two channels have the same cross section)
54878 C...qi and qj have the same charge sign
54879 DO 100 I=MMIN1,MMAX1
54881 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
54882 DO 101 J=MMIN2,MMAX2
54884 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
54886 IF(J*I.LE.0)GOTO 101
54891 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
54893 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
54894 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
54895 & 20.*TP**2*UP**2+56./3.*
54896 & TP*UP**3+8.*UP**4)
54897 SIGH(NCHN)=COMFAC*2.*XMUED
54899 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54901 FAC1=2./9.*ALPHAS**2/TP**2
54902 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54903 SIGH(NCHN)=COMFAC*2.*XMUED
54908 ELSEIF(ISUB.EQ.314)THEN
54909 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54910 C...(the two channels have the same cross section)
54914 ISIG(NCHN,3)=INT(1.5+PYR(0))
54916 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
54917 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
54918 + +4.*UP**4+4*TP**4)
54919 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
54920 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
54921 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
54923 SIGH(NCHN)=COMFAC*XMUED
54924 C...has been multiplied by 5: all possible quark flavors in final state
54926 ELSEIF(ISUB.EQ.315)THEN
54927 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54928 C...(the two channels have the same cross section)
54929 DO 141 I=MMIN1,MMAX1
54930 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
54931 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
54932 DO 142 J=MMIN2,MMAX2
54933 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
54934 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
54935 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
54936 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
54937 & 2./3.*SP**3*TP+SP**4)
54942 SIGH(NCHN)=COMFAC*2.*XMUED
54945 ELSEIF(ISUB.EQ.316)THEN
54946 C...q + qbar' -> q*_D + q*_Sbar'
54947 FAC1=2./9.*ALPHAS**2
54948 DO 300 I=MMIN1,MMAX1
54950 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
54951 DO 301 J=MMIN2,MMAX2
54953 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
54954 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
54959 FAC1=2./9.*ALPHAS**2/TP**2
54960 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54961 SIGH(NCHN)=COMFAC*XMUED
54965 ELSEIF(ISUB.EQ.317)THEN
54966 C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54967 C...(the two channels have the same cross section)
54968 DO 400 I=MMIN1,MMAX1
54970 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
54971 DO 401 J=MMIN1,MMAX1
54973 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
54974 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
54979 FAC1=1./18.*ALPHAS**2/TP**2
54980 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
54981 SIGH(NCHN)=COMFAC*2.*XMUED
54984 ELSEIF(ISUB.EQ.318)THEN
54985 C...q + q' -> q*_D + q*_S'
54986 DO 500 I=MMIN1,MMAX1
54988 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
54989 DO 501 J=MMIN2,MMAX2
54991 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
54992 IF(J*I.LE.0)GOTO 501
54997 ISIG(NCHN,3)=INT(1.5+PYR(0))
54998 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
54999 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
55000 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
55001 SIGH(NCHN)=COMFAC*XMUED
55007 FAC1=1./18.*ALPHAS**2/TP**2
55008 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55009 SIGH(NCHN)=COMFAC*2.*XMUED
55013 ELSEIF(ISUB.EQ.319)THEN
55014 C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55015 C...(the two channels have the same cross section)
55016 DO 741 I=MMIN1,MMAX1
55017 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55018 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55019 DO 742 J=MMIN2,MMAX2
55020 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55021 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55022 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55027 SIGH(NCHN)=COMFAC*2.*XMUED
55035 C*********************************************************************
55038 C...Universal Extra Dimensions Model (UED)
55039 C...Computation of the Graviton mass.
55041 SUBROUTINE PYGRAM(IN)
55043 C...Double precision and integer declarations
55044 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55045 IMPLICIT INTEGER(I-N)
55047 C...Pythia commonblocks
55048 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55049 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55050 C...UED Pythia common
55051 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55053 C...Local variables
55055 PARAMETER(KCFLA=450,NMAX=5000)
55056 DIMENSION YVEC(5000),RESVEC(5000)
55057 COMMON/INTSAV/YSAV,YMAX,RESMAX
55058 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55059 COMMON/KAPPA/XKAPPA
55061 C...External function (used in call to PYGAUS)
55064 C...SAVE statements
55065 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55073 C...Initialize for numerical integration
55075 XKAPPA=DSQRT(2.D0)/XMPLNK
55077 C...For NDIM=2, compute graviton mass distribution numerically
55080 C... For first event: tabulate distribution of stepwise integrals:
55081 C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55086 YSAV = (I-0.5)/DBLE(NMAX)
55088 C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55089 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55092 C... Save max of distribution (for accept/reject below)
55093 IF(RESINT.GT.RESMAX)THEN
55100 C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55103 XMGAMK=PMAS(KCGAKK,1)
55105 C... Pick random graviton mass, accept according to stored integrals
55106 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55107 110 RMG=AMMAX*PYR(0)
55110 C... Bin enumeration starts at 1, but make sure always in range
55112 IBIN=MIN(IBIN,NMAX)
55113 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55115 C... For NDIM=4 and 6, the analytical expression for the
55116 C... graviton mass distribution integral is used.
55117 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55119 C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55122 C... KK photon (?) compressed code and mass
55124 XMGAMK=PMAS(KCGAKK,1)
55126 C... Find maximum of (dGamma/dMg)
55132 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55133 IF(RESINT.GE.RESMAX)THEN
55140 C... Pick random graviton mass, accept/reject
55141 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55142 130 RMG=AMMAX*PYR(0)
55144 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55145 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55147 C... If the user has not chosen N=2,4 or 6, STOP
55149 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55150 & ' (MUST BE 2, 4, OR 6) '
55154 C... Now store the sampled Mg
55160 C*********************************************************************
55163 C...Universal Extra Dimensions Model (UED)
55165 C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55167 C...Integrand for the KK boson -> SM boson + graviton
55168 C...graviton mass distribution (and gravity mediated total width),
55169 C...which contains (see 0201300 and below for the full product)
55170 C...the gravity mediated partial decay width Gamma(xx, yy)
55171 C... i.e. GRADEN(YY)*PYWDKK(XXA)
55172 C... where xx is exclusive to gravity
55173 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55174 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55176 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55178 C...Double precision and integer declarations
55179 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55180 IMPLICIT INTEGER (I-N)
55182 C...Pythia commonblocks
55183 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55185 C...Local UED commonblocks and variables
55186 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55187 COMMON/INTSAV/YSAV,YMAX,RESMAX
55189 C...SAVE statements
55190 SAVE /PYDAT1/,/INTSAV/
55192 C...External: Pythia's Gamma function
55201 XX=DSQRT(1.-YY**2)*YIN
55202 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
55203 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
55207 XXA=DSQRT(XX**2+YY**2)
55208 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
55211 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
55215 C*********************************************************************
55218 C...Universal Extra Dimensions Model (UED)
55220 C...Multiplied by the square modulus of a form factor
55221 C...(see GRADEN in function PYGRAW)
55222 C...PYWDKK is the KK boson -> SM boson + graviton
55223 C...gravity mediated partial decay width Gamma(xx, yy)
55224 C... where xx is exclusive to gravity
55225 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55226 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55228 C...N.B. The Feynman rules for the couplings of the graviton fields
55229 C...to the UED fields are related to the corresponding couplings of
55230 C...the graviton fields to the SM fields by the form factor.
55232 DOUBLE PRECISION FUNCTION PYWDKK(X)
55234 C...Double precision and integer declarations
55235 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55236 IMPLICIT INTEGER (I-N)
55238 C...Pythia commonblocks
55239 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55240 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55242 C...Local UED commonblocks and variables
55243 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55244 COMMON/KAPPA/XKAPPA
55246 C...SAVE statements
55247 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
55251 C...gamma* mass 473
55253 XMNKK=PMAS(KCQKK,1)
55255 C...Bosons partial width Macesanu hep-ph/0201300
55256 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
55257 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
55262 C*********************************************************************
55265 C...Finds eigenvalues of a general complex matrix
55267 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55268 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55269 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55270 C OF A COMPLEX GENERAL MATRIX.
55274 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55275 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55276 C DIMENSION STATEMENT.
55278 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55280 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55281 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55283 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55284 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55285 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55289 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55290 C RESPECTIVELY, OF THE EIGENVALUES.
55292 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55293 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55295 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55296 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55297 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55299 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55301 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55302 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55304 C THIS VERSION DATED AUGUST 1983.
55307 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55309 INTEGER N,NM,IS1,IS2,IERR,MATZ
55310 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55311 X FV1(5),FV2(5),FV3(5)
55312 IF (N .LE. NM) GOTO 100
55316 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
55317 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
55318 IF (MATZ .NE. 0) GOTO 110
55319 C .......... FIND EIGENVALUES ONLY ..........
55320 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
55322 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55323 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
55324 IF (IERR .NE. 0) GOTO 120
55325 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
55329 C*********************************************************************
55332 C...Auxiliary to PYEICG.
55334 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55335 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55337 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55338 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55339 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55341 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55342 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55346 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55347 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55348 C DIMENSION STATEMENT.
55350 C N IS THE ORDER OF THE MATRIX.
55352 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55353 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55354 C SET LOW=1, IGH=N.
55356 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55357 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55358 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55359 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55360 C THE REDUCTION BY CORTH, IF PERFORMED.
55364 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55365 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55366 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55367 C EIGENVECTORS IS TO BE PERFORMED.
55369 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55370 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55371 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55372 C FOR INDICES IERR+1,...,N.
55375 C ZERO FOR NORMAL RETURN,
55376 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55377 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55379 C CALLS PYCDIV FOR COMPLEX DIVISION.
55380 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55381 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55383 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55384 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55386 C THIS VERSION DATED AUGUST 1983.
55389 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55391 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55392 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55393 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55397 IF (LOW .EQ. IGH) GOTO 130
55398 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55403 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
55404 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55405 YR = HR(I,I-1) / NORM
55406 YI = HI(I,I-1) / NORM
55411 SI = YR * HI(I,J) - YI * HR(I,J)
55412 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55417 SI = YR * HI(J,I) + YI * HR(J,I)
55418 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55423 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55424 130 DO 140 I = 1, N
55425 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
55434 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55435 150 IF (EN .LT. LOW) GOTO 320
55438 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55439 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55440 160 DO 170 LL = LOW, EN
55442 IF (L .EQ. LOW) GOTO 180
55443 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55444 X + DABS(HR(L,L)) + DABS(HI(L,L))
55445 TST2 = TST1 + DABS(HR(L,L-1))
55446 IF (TST2 .EQ. TST1) GOTO 180
55448 C .......... FORM SHIFT ..........
55449 180 IF (L .EQ. EN) GOTO 300
55450 IF (ITN .EQ. 0) GOTO 310
55451 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
55454 XR = HR(ENM1,EN) * HR(EN,ENM1)
55455 XI = HI(ENM1,EN) * HR(EN,ENM1)
55456 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
55457 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55458 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55459 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55460 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
55463 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55467 C .......... FORM EXCEPTIONAL SHIFT ..........
55468 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55471 210 DO 220 I = LOW, EN
55472 HR(I,I) = HR(I,I) - SR
55473 HI(I,I) = HI(I,I) - SI
55480 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55486 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55487 XR = HR(I-1,I-1) / NORM
55489 XI = HI(I-1,I-1) / NORM
55492 HI(I-1,I-1) = 0.0D0
55493 HI(I,I-1) = SR / NORM
55500 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55501 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55502 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55503 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55509 IF (SI .EQ. 0.0D0) GOTO 250
55510 NORM = PYTHAG(HR(EN,EN),SI)
55511 SR = HR(EN,EN) / NORM
55515 C .......... INVERSE OPERATION (COLUMNS) ..........
55516 250 DO 280 J = LP1, EN
55525 IF (I .EQ. J) GOTO 260
55527 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55528 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55529 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55530 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55535 IF (SI .EQ. 0.0D0) GOTO 160
55540 HR(I,EN) = SR * YR - SI * YI
55541 HI(I,EN) = SR * YI + SI * YR
55545 C .......... A ROOT FOUND ..........
55546 300 WR(EN) = HR(EN,EN) + TR
55547 WI(EN) = HI(EN,EN) + TI
55550 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55551 C CONVERGED AFTER 30*N ITERATIONS ..........
55556 C*********************************************************************
55559 C...Auxiliary to PYEICG.
55561 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55562 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55564 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55565 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55566 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55568 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55569 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55570 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55571 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55572 C THIS GENERAL MATRIX TO HESSENBERG FORM.
55576 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55577 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55578 C DIMENSION STATEMENT.
55580 C N IS THE ORDER OF THE MATRIX.
55582 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55583 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55584 C SET LOW=1, IGH=N.
55586 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55587 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55588 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55589 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55590 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55592 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55593 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55594 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55595 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55596 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55597 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55602 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55603 C HAVE BEEN DESTROYED.
55605 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55606 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55607 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55608 C FOR INDICES IERR+1,...,N.
55610 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55611 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55612 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55613 C THE EIGENVECTORS HAS BEEN FOUND.
55616 C ZERO FOR NORMAL RETURN,
55617 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55618 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55620 C CALLS PYCDIV FOR COMPLEX DIVISION.
55621 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55622 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55624 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55625 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55627 C THIS VERSION DATED OCTOBER 1989.
55629 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55630 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55633 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55635 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55636 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55637 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55639 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55643 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55652 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55653 C FROM THE INFORMATION LEFT BY CORTH ..........
55654 IEND = IGH - LOW - 1
55655 IF (IEND.LT.0) GOTO 220
55656 IF (IEND.EQ.0) GOTO 170
55657 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55658 DO 160 II = 1, IEND
55660 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
55661 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
55662 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55663 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
55666 DO 120 K = IP1, IGH
55667 ORTR(K) = HR(K,I-1)
55668 ORTI(K) = HI(K,I-1)
55676 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
55677 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
55684 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
55685 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
55691 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55696 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
55697 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55698 YR = HR(I,I-1) / NORM
55699 YI = HI(I,I-1) / NORM
55704 SI = YR * HI(I,J) - YI * HR(I,J)
55705 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55710 SI = YR * HI(J,I) + YI * HR(J,I)
55711 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55715 DO 200 J = LOW, IGH
55716 SI = YR * ZI(J,I) + YI * ZR(J,I)
55717 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
55722 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55723 220 DO 230 I = 1, N
55724 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
55733 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55734 240 IF (EN .LT. LOW) GOTO 430
55737 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55738 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55739 250 DO 260 LL = LOW, EN
55741 IF (L .EQ. LOW) GOTO 270
55742 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55743 X + DABS(HR(L,L)) + DABS(HI(L,L))
55744 TST2 = TST1 + DABS(HR(L,L-1))
55745 IF (TST2 .EQ. TST1) GOTO 270
55747 C .......... FORM SHIFT ..........
55748 270 IF (L .EQ. EN) GOTO 420
55749 IF (ITN .EQ. 0) GOTO 550
55750 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
55753 XR = HR(ENM1,EN) * HR(EN,ENM1)
55754 XI = HI(ENM1,EN) * HR(EN,ENM1)
55755 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
55756 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55757 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55758 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55759 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
55762 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55766 C .......... FORM EXCEPTIONAL SHIFT ..........
55767 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55770 300 DO 310 I = LOW, EN
55771 HR(I,I) = HR(I,I) - SR
55772 HI(I,I) = HI(I,I) - SI
55779 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55785 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55786 XR = HR(I-1,I-1) / NORM
55788 XI = HI(I-1,I-1) / NORM
55791 HI(I-1,I-1) = 0.0D0
55792 HI(I,I-1) = SR / NORM
55799 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55800 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55801 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55802 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55808 IF (SI .EQ. 0.0D0) GOTO 350
55809 NORM = PYTHAG(HR(EN,EN),SI)
55810 SR = HR(EN,EN) / NORM
55814 IF (EN .EQ. N) GOTO 350
55820 HR(EN,J) = SR * YR + SI * YI
55821 HI(EN,J) = SR * YI - SI * YR
55823 C .......... INVERSE OPERATION (COLUMNS) ..........
55824 350 DO 390 J = LP1, EN
55833 IF (I .EQ. J) GOTO 360
55835 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55836 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55837 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55838 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55841 DO 380 I = LOW, IGH
55846 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55847 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55848 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55849 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55854 IF (SI .EQ. 0.0D0) GOTO 250
55859 HR(I,EN) = SR * YR - SI * YI
55860 HI(I,EN) = SR * YI + SI * YR
55863 DO 410 I = LOW, IGH
55866 ZR(I,EN) = SR * YR - SI * YI
55867 ZI(I,EN) = SR * YI + SI * YR
55871 C .......... A ROOT FOUND ..........
55872 420 HR(EN,EN) = HR(EN,EN) + TR
55874 HI(EN,EN) = HI(EN,EN) + TI
55878 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55879 C VECTORS OF UPPER TRIANGULAR FORM ..........
55885 TR = DABS(HR(I,J)) + DABS(HI(I,J))
55886 IF (TR .GT. NORM) NORM = TR
55889 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
55890 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55898 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55899 DO 490 II = 1, ENM1
55906 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
55907 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
55912 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
55915 460 YR = 0.01D0 * YR
55917 IF (TST2 .GT. TST1) GOTO 460
55919 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
55920 C .......... OVERFLOW CONTROL ..........
55921 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
55922 IF (TR .EQ. 0.0D0) GOTO 490
55924 TST2 = TST1 + 1.0D0/TST1
55925 IF (TST2 .GT. TST1) GOTO 490
55927 HR(J,EN) = HR(J,EN)/TR
55928 HI(J,EN) = HI(J,EN)/TR
55934 C .......... END BACKSUBSTITUTION ..........
55935 C .......... VECTORS OF ISOLATED ROOTS ..........
55937 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
55945 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55946 C VECTORS OF ORIGINAL FULL MATRIX.
55947 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55952 DO 540 I = LOW, IGH
55957 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
55958 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
55966 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55967 C CONVERGED AFTER 30*N ITERATIONS ..........
55972 C*********************************************************************
55975 C...Auxiliary to PYCMQR
55977 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55980 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
55982 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55983 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55985 S = DABS(BR) + DABS(BI)
55990 S = BRS**2 + BIS**2
55991 CR = (ARS*BRS + AIS*BIS)/S
55992 CI = (AIS*BRS - ARS*BIS)/S
55996 C*********************************************************************
55999 C...Auxiliary to PYCMQR
56001 C (YR,YI) = COMPLEX DSQRT(XR,XI)
56002 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
56005 SUBROUTINE PYCSRT(XR,XI,YR,YI)
56007 DOUBLE PRECISION XR,XI,YR,YI
56008 DOUBLE PRECISION S,TR,TI,PYTHAG
56012 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56013 IF (TR .GE. 0.0D0) YR = S
56014 IF (TI .LT. 0.0D0) S = -S
56015 IF (TR .LE. 0.0D0) YI = S
56016 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56017 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56021 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56022 DOUBLE PRECISION A,B
56024 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56026 DOUBLE PRECISION P,R,S,T,U
56027 P = DMAX1(DABS(A),DABS(B))
56028 IF (P .EQ. 0.0D0) GOTO 110
56029 R = (DMIN1(DABS(A),DABS(B))/P)**2
56032 IF (T .EQ. 4.0D0) GOTO 110
56034 U = 1.0D0 + 2.0D0*S
56042 C*********************************************************************
56045 C...Auxiliary to PYEICG
56047 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56048 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56049 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56050 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56052 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56053 C EIGENVALUES WHENEVER POSSIBLE.
56057 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56058 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56059 C DIMENSION STATEMENT.
56061 C N IS THE ORDER OF THE MATRIX.
56063 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56064 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56068 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56069 C RESPECTIVELY, OF THE BALANCED MATRIX.
56071 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56072 C ARE EQUAL TO ZERO IF
56073 C (1) I IS GREATER THAN J AND
56074 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56076 C SCALE CONTAINS INFORMATION DETERMINING THE
56077 C PERMUTATIONS AND SCALING FACTORS USED.
56079 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56080 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56081 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56082 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56083 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56084 C = D(J,J) J = LOW,...,IGH
56085 C = P(J) J = IGH+1,...,N.
56086 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56089 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56091 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56092 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56093 C K,L HAVE BEEN REVERSED.)
56095 C ARITHMETIC IS REAL THROUGHOUT.
56097 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56098 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56100 C THIS VERSION DATED AUGUST 1983.
56103 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56105 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56106 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56107 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56116 C .......... IN-LINE PROCEDURE FOR ROW AND
56117 C COLUMN EXCHANGE ..........
56119 IF (J .EQ. M) GOTO 130
56139 130 IF(IEXC.EQ.1) GOTO 140
56140 IF(IEXC.EQ.2) GOTO 180
56141 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56142 C AND PUSH THEM DOWN ..........
56143 140 IF (L .EQ. 1) GOTO 320
56145 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56146 150 DO 170 JJ = 1, L
56150 IF (I .EQ. J) GOTO 160
56151 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56160 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56161 C AND PUSH THEM LEFT ..........
56164 190 DO 210 J = K, L
56167 IF (I .EQ. J) GOTO 200
56168 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56175 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56177 220 SCALE(I) = 1.0D0
56178 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56179 230 NOCONV = .FALSE.
56186 IF (J .EQ. I) GOTO 240
56187 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56188 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56190 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56191 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
56195 250 IF (C .GE. G) GOTO 260
56200 270 IF (C .LT. G) GOTO 280
56204 C .......... NOW BALANCE ..........
56205 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
56207 SCALE(I) = SCALE(I) * F
56211 AR(I,J) = AR(I,J) * G
56212 AI(I,J) = AI(I,J) * G
56216 AR(J,I) = AR(J,I) * F
56217 AI(J,I) = AI(J,I) * F
56222 IF (NOCONV) GOTO 230
56229 C*********************************************************************
56232 C...Auxiliary to PYEICG.
56234 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56235 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56236 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56237 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56239 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56240 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56241 C BALANCED MATRIX DETERMINED BY CBAL.
56245 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56246 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56247 C DIMENSION STATEMENT.
56249 C N IS THE ORDER OF THE MATRIX.
56251 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56253 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56254 C AND SCALING FACTORS USED BY CBAL.
56256 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56258 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56259 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56260 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56264 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56265 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56266 C IN THEIR FIRST M COLUMNS.
56268 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56269 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56271 C THIS VERSION DATED AUGUST 1983.
56274 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56276 INTEGER I,J,K,M,N,II,NM,IGH,LOW
56277 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56280 IF (M .EQ. 0) GOTO 150
56281 IF (IGH .EQ. LOW) GOTO 120
56283 DO 110 I = LOW, IGH
56285 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56286 C IF THE FOREGOING STATEMENT IS REPLACED BY
56287 C S=1.0D0/SCALE(I). ..........
56289 ZR(I,J) = ZR(I,J) * S
56290 ZI(I,J) = ZI(I,J) * S
56294 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56295 C IGH+1 STEP 1 UNTIL N DO -- ..........
56296 120 DO 140 II = 1, N
56298 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56299 IF (I .LT. LOW) I = LOW - II
56301 IF (K .EQ. I) GOTO 140
56317 C*********************************************************************
56320 C...Auxiliary to PYEICG.
56322 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56323 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56324 C BY MARTIN AND WILKINSON.
56325 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56327 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56328 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56329 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56330 C UNITARY SIMILARITY TRANSFORMATIONS.
56334 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56335 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56336 C DIMENSION STATEMENT.
56338 C N IS THE ORDER OF THE MATRIX.
56340 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56341 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56342 C SET LOW=1, IGH=N.
56344 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56345 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56349 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56350 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56351 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56352 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56353 C HESSENBERG MATRIX.
56355 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56356 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56358 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56360 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56361 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56363 C THIS VERSION DATED AUGUST 1983.
56366 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56368 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56369 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56370 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56374 IF (LA .LT. KP1) GOTO 210
56381 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56383 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
56385 IF (SCALE .EQ. 0.0D0) GOTO 200
56387 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56390 ORTR(I) = AR(I,M-1) / SCALE
56391 ORTI(I) = AI(I,M-1) / SCALE
56392 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
56396 F = PYTHAG(ORTR(M),ORTI(M))
56397 IF (F .EQ. 0.0D0) GOTO 120
56400 ORTR(M) = (1.0D0 + G) * ORTR(M)
56401 ORTI(M) = (1.0D0 + G) * ORTI(M)
56406 C .......... FORM (I-(U*UT)/H) * A ..........
56407 130 DO 160 J = M, N
56410 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56413 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
56414 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
56421 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
56422 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
56426 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56430 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56433 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
56434 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
56441 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
56442 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
56447 ORTR(M) = SCALE * ORTR(M)
56448 ORTI(M) = SCALE * ORTI(M)
56449 AR(M,M-1) = -G * AR(M,M-1)
56450 AI(M,M-1) = -G * AI(M,M-1)
56456 C*********************************************************************
56459 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56462 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
56464 INTEGER N,NP,INDX(N)
56466 COMPLEX*16 A(NP,NP)
56467 PARAMETER (TINY=1.0D-20)
56469 REAL*8 AAMAX,VV(6),DUM
56470 COMPLEX*16 SUM,DUMC
56476 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
56478 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
56485 SUM=SUM-A(I,K)*A(K,J)
56493 SUM=SUM-A(I,K)*A(K,J)
56497 IF (DUM.GE.AAMAX) THEN
56512 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
56515 A(I,J)=A(I,J)/A(J,J)
56523 C*********************************************************************
56526 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56529 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
56531 INTEGER N,NP,INDX(N)
56532 COMPLEX*16 A(NP,NP),B(N)
56543 SUM=SUM-A(I,J)*B(J)
56545 ELSE IF (ABS(SUM).NE.0D0) THEN
56553 SUM=SUM-A(I,J)*B(J)
56560 C***********************************************************************
56563 C...Calculates full and partial widths of resonances.
56564 C....copy of PYWIDT, used for techniparticle widths
56566 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
56568 C...Double precision and integer declarations.
56569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56570 IMPLICIT INTEGER(I-N)
56571 INTEGER PYK,PYCHGE,PYCOMP
56572 C...Parameter statement to help give large particle numbers.
56573 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56574 &KEXCIT=4000000,KDIMEN=5000000)
56576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56577 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56578 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56579 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
56580 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56581 COMMON/PYINT1/MINT(400),VINT(400)
56582 COMMON/PYINT4/MWID(500),WIDS(500,5)
56583 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56584 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
56585 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
56586 &/PYINT4/,/PYMSSM/,/PYTCSM/
56587 C...Local arrays and saved variables.
56588 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
56590 SAVE MOFSV,WIDWSV,WID2SV
56591 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
56593 C...Compressed code and sign; mass.
56600 C...Reset width information.
56605 C...Common electroweak and strong constants.
56608 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
56611 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
56613 RADC=1D0+AS/PARU(1)
56615 IF(KFLA.EQ.23) THEN
56617 XWC=1D0/(16D0*XW*XW1)
56618 FAC=(AEM*XWC/3D0)*SHR
56620 DO 130 I=1,MDCY(KC,3)
56622 IF(MDME(IDC,1).LT.0) GOTO 130
56623 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56624 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56625 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
56629 AF=SIGN(1D0,EF+0.1D0)
56632 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
56633 ELSEIF(I.LE.16) THEN
56634 C...Z0 -> l+ + l-, nu + nubar
56636 AF=SIGN(1D0,EF+0.1D0)
56640 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
56641 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
56643 WDTP(0)=WDTP(0)+WDTP(I)
56647 ELSEIF(KFLA.EQ.24) THEN
56649 FAC=(AEM/(24D0*XW))*SHR
56650 DO 140 I=1,MDCY(KC,3)
56652 IF(MDME(IDC,1).LT.0) GOTO 140
56653 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56654 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56655 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
56658 C...W+/- -> q + qbar'
56659 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
56660 ELSEIF(I.LE.20) THEN
56661 C...W+/- -> l+/- + nu
56664 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
56665 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
56666 WDTP(0)=WDTP(0)+WDTP(I)
56669 C.....V8 -> quark anti-quark
56670 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
56673 IF(ITCM(2).EQ.0) THEN
56675 ELSEIF(ITCM(2).EQ.1) THEN
56678 DO 150 I=1,MDCY(KC,3)
56680 IF(MDME(IDC,1).LT.0) GOTO 150
56681 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
56683 IF(RM1.GT.0.25D0) GOTO 150
56685 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
56690 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
56691 IF(I.EQ.6) WID2=WIDS(6,1)
56692 WDTP(0)=WDTP(0)+WDTP(I)
56699 C*********************************************************************
56702 C...Calculates R-violating decays of sfermions.
56705 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
56707 C...Double precision and integer declarations.
56708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56709 IMPLICIT INTEGER(I-N)
56710 C...Parameter statement to help give large particle numbers.
56711 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56712 &KEXCIT=4000000,KDIMEN=5000000)
56714 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56715 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56716 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56717 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56718 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
56719 C...Local variables.
56720 DOUBLE PRECISION XLAM(0:400)
56721 INTEGER IDLAM(400,3), PYCOMP
56722 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
56724 C...IS R-VIOLATION ON ?
56725 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
56726 C...Mass eigenstate counter
56727 ICNT=INT(KFIN/KSUSY1)
56728 C...SM KF code of SUSY particle
56729 KFSM=KFIN-ICNT*KSUSY1
56730 C...Squared Sparticle Mass
56731 SM=PMAS(PYCOMP(KFIN),1)**2
56732 C... Squared mass of top quark
56733 SMT=PMAS(PYCOMP(6),1)**2
56734 C...IS L-VIOLATION ON ?
56735 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
56736 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56737 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
56743 C...~e,~mu,~tau -> nu_I + lepton-_J
56745 IDLAM(LKNT,1)= 12 +2*(I-1)
56746 IDLAM(LKNT,2)= 11 +2*(J-1)
56749 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56750 IF (IMSS(51).NE.0) XLAM(LKNT) =
56751 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56752 C...KINEMATICS CHECK
56753 IF (XLAM(LKNT).EQ.0D0) THEN
56759 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56765 IDLAM(LKNT,1)=-12 -2*(I-1)
56766 IDLAM(LKNT,2)= 11 +2*(K-1)
56769 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56770 IF (IMSS(51).NE.0) XLAM(LKNT) =
56771 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56772 C...KINEMATICS CHECK
56773 IF (XLAM(LKNT).EQ.0D0) THEN
56779 C...~e,~mu,~tau -> u_Jbar + d_K
56784 IDLAM(LKNT,1)=-2 -2*(J-1)
56785 IDLAM(LKNT,2)= 1 +2*(K-1)
56788 IF (IMSS(52).NE.0) THEN
56789 C...Use massive top quark
56790 IF (IDLAM(LKNT,1).EQ.-6) THEN
56791 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
56794 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56795 C...If no top quark, all decay products massless
56797 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56799 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56801 C...KINEMATICS CHECK
56802 IF (XLAM(LKNT).EQ.0D0) THEN
56809 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56810 C...No right-handed neutrinos
56812 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
56817 C...~nu_J -> lepton+_I + lepton-_K
56819 IDLAM(LKNT,1)=-11 -2*(I-1)
56820 IDLAM(LKNT,2)= 11 +2*(K-1)
56823 RM2=RVLAM(I,J,K)**2 * SM
56824 IF (IMSS(51).NE.0) XLAM(LKNT) =
56825 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56826 C...KINEMATICS CHECK
56827 IF (XLAM(LKNT).EQ.0D0) THEN
56833 C...~nu_I -> dbar_J + d_K
56838 IDLAM(LKNT,1)=-1 -2*(J-1)
56839 IDLAM(LKNT,2)= 1 +2*(K-1)
56842 RM2=3*RVLAMP(I,J,K)**2 * SM
56843 IF (IMSS(52).NE.0) XLAM(LKNT) =
56844 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56845 C...KINEMATICS CHECK
56846 IF (XLAM(LKNT).EQ.0D0) THEN
56853 C * SDOWN -> NU(BAR) + D and LEPTON- + U
56854 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56858 C...~d_J -> nu_Ibar + d_K
56860 IDLAM(LKNT,1)=-12 -2*(I-1)
56861 IDLAM(LKNT,2)= 1 +2*(K-1)
56864 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56865 IF (IMSS(52).NE.0) XLAM(LKNT) =
56866 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56867 C...KINEMATICS CHECK
56868 IF (XLAM(LKNT).EQ.0D0) THEN
56876 C...~d_K -> nu_I + d_J
56878 IDLAM(LKNT,1)= 12 +2*(I-1)
56879 IDLAM(LKNT,2)= 1 +2*(J-1)
56882 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56883 IF (IMSS(52).NE.0) XLAM(LKNT) =
56884 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56885 C...KINEMATICS CHECK
56886 IF (XLAM(LKNT).EQ.0D0) THEN
56889 C...~d_K -> lepton_I- + u_J
56891 IDLAM(LKNT,1)= 11 +2*(I-1)
56892 IDLAM(LKNT,2)= 2 +2*(J-1)
56895 IF (IMSS(52).NE.0) THEN
56896 C...Use massive top quark
56897 IF (IDLAM(LKNT,2).EQ.6) THEN
56898 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
56900 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
56901 C...If no top quark, all decay products massless
56903 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56905 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56907 C...KINEMATICS CHECK
56908 IF (XLAM(LKNT).EQ.0D0) THEN
56915 C * SUP -> LEPTON+ + D
56916 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56920 C...~u_J -> lepton_I+ + d_K
56922 IDLAM(LKNT,1)=-11 -2*(I-1)
56923 IDLAM(LKNT,2)= 1 +2*(K-1)
56926 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56927 IF (IMSS(52).NE.0) XLAM(LKNT) =
56928 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56929 C...KINEMATICS CHECK
56930 IF (XLAM(LKNT).EQ.0D0) THEN
56937 C...BARYON NUMBER VIOLATING DECAYS
56938 IF (IMSS(53).GE.1) THEN
56939 C * SUP -> DBAR + DBAR
56940 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56944 C...~u_I -> dbar_J + dbar_K
56946 C...(anti-) symmetry J <-> K.
56948 IDLAM(LKNT,1) = -1 -2*(J-1)
56949 IDLAM(LKNT,2) = -1 -2*(K-1)
56952 RM2 = 2.*(RVLAMB(I,J,K)**2)
56953 & * SFMIX(KFSM,2*ICNT)**2 * SM
56955 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56956 C...KINEMATICS CHECK
56957 IF (XLAM(LKNT).EQ.0D0) THEN
56964 C * SDOWN -> UBAR + DBAR
56965 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56969 C...LAMB coupling antisymmetric in J and K.
56971 C...~d_K -> ubar_I + dbar_K
56973 IDLAM(LKNT,1)= -2 -2*(I-1)
56974 IDLAM(LKNT,2)= -1 -2*(J-1)
56977 C...Use massive top quark
56978 IF (IDLAM(LKNT,1).EQ.-6) THEN
56979 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
56982 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56983 C...If no top quark, all decay products massless
56985 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56987 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56989 C...KINEMATICS CHECK
56990 IF (XLAM(LKNT).EQ.0D0) THEN
57003 C*********************************************************************
57006 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57009 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57011 C...Double precision and integer declarations.
57012 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57013 IMPLICIT INTEGER(I-N)
57014 C...Parameter statement to help give large particle numbers.
57015 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57016 &KEXCIT=4000000,KDIMEN=5000000)
57018 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57019 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57020 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57021 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57022 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57023 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57024 C...Local variables.
57025 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57027 DOUBLE PRECISION XLAM(0:400)
57028 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57029 INTEGER IDLAM(400,3), PYCOMP
57031 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57033 C...R-VIOLATING DECAYS
57034 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57036 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57037 C...WHICH NEUTRALINO ?
57039 IF (KFSM.EQ.23) NCHI=2
57040 IF (KFSM.EQ.25) NCHI=3
57041 IF (KFSM.EQ.35) NCHI=4
57042 C...SIGN OF MASS (Opposite convention as HERWIG)
57044 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57046 C...Useful parameters for the calculation of the A and B constants.
57047 WMASS = PMAS(PYCOMP(24),1)
57048 ECHG = 2*SQRT(PARU(103)*PARU(1))
57049 COSB=1/(SQRT(1+RMSS(5)**2))
57050 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57051 COSW=SQRT(1-PARU(102))
57052 SINW=SQRT(PARU(102))
57053 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57054 C...Run quark masses to neutralino mass squared (for Higgs-type
57056 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57058 RMQ(I)=PYMRUN(I,SQMCHI)
57060 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57062 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57063 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57064 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57065 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57067 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57068 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57069 C2=ECHG*ZPMIX(NCHI,1)
57070 C3=GW*ZPMIX(NCHI,2)/COSW
57074 C x=1-2 : Select A or B constant (1:A ; 2:B)
57075 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57076 C 11-16:e,nu_e,mu,...)
57077 C z=1-2 : Mass eigenstate number
57078 C...CALCULATE COUPLINGS
57080 CMS=PMAS(PYCOMP(I),1)
57081 C...Intermediate sleptons
57082 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57083 & *(C2-C3*SINW**2))
57084 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57085 & *(C2-C3*SINW**2))
57086 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57088 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57090 C...Inermediate sneutrinos
57092 AB(2,I+1,1)=5D-1*C3
57095 C...Inermediate sdown
57098 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57099 & *ED*(C2-C3*SINW**2))
57100 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57101 & *ED*(C2-C3*SINW**2))
57102 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57103 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57104 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57105 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57106 C...Inermediate sup
57109 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57110 & *EU*(C2-C3*SINW**2))
57111 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57112 & *EU*(C2-C3*SINW**2))
57113 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57114 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57115 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57116 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57119 IF (IMSS(51).GE.1) THEN
57120 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57121 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57122 C...STEP IN I,J,K USING SINGLE COUNTER
57124 C...LAMBDA COUPLING ASYM IN I,J
57125 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57127 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57128 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57129 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57131 C...Set coupling, and decay product masses on/off
57132 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57133 & ,MOD(ISC,3)+1)**2
57135 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57137 C...Resonance KF codes (1=I,2=J,3=K)
57138 KFR(1)=-IDLAM(LKNT,1)
57139 KFR(2)=-IDLAM(LKNT,2)
57140 KFR(3)=-IDLAM(LKNT,3)
57141 C...Calculate width.
57142 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57143 & IDLAM(LKNT,3),XLAM(LKNT))
57144 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57145 C...Charge conjugate mode.
57147 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57148 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57149 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57150 XLAM(LKNT)=XLAM(LKNT-1)
57151 C...KINEMATICS CHECK
57152 IF (XLAM(LKNT).EQ.0D0) THEN
57159 IF (IMSS(52).GE.1) THEN
57160 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57161 C * CHI0 -> NUBAR_I + DBAR_J + D_K
57164 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57165 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57166 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57168 C...Set coupling, and decay product masses on/off
57169 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57170 & ,MOD(ISC,3)+1)**2
57172 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57174 C...Resonance KF codes (1=I,2=J,3=K)
57175 KFR(1)=-IDLAM(LKNT,1)
57176 KFR(2)=-IDLAM(LKNT,2)
57177 KFR(3)=-IDLAM(LKNT,3)
57178 C...Calculate width.
57179 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57181 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57182 C...Charge conjugate mode.
57184 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57185 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57186 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57187 XLAM(LKNT)=XLAM(LKNT-1)
57188 C...KINEMATICS CHECK
57189 IF (XLAM(LKNT).EQ.0D0) THEN
57193 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57195 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57196 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57197 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57199 C...Set coupling, and decay product masses on/off
57200 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57201 & ,MOD(ISC,3)+1)**2
57203 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57204 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57205 C...Resonance KF codes (1=I,2=J,3=K)
57206 KFR(1)=-IDLAM(LKNT,1)
57207 KFR(2)=-IDLAM(LKNT,2)
57208 KFR(3)=-IDLAM(LKNT,3)
57209 C...Calculate width.
57210 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57212 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57213 C...Charge conjugate mode.
57215 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57216 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57217 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57218 XLAM(LKNT)=XLAM(LKNT-1)
57219 C...KINEMATICS CHECK
57220 IF (XLAM(LKNT).EQ.0D0) THEN
57226 IF (IMSS(53).GE.1) THEN
57227 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57228 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57230 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57231 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57233 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57234 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57235 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57237 C...Set coupling, and decay product masses on/off
57238 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
57239 & +1,MOD(ISC,3)+1)**2
57241 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57242 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57243 C...Resonance KF codes (1=I,2=J,3=K)
57244 KFR(1) = IDLAM(LKNT,1)
57245 KFR(2) = IDLAM(LKNT,2)
57246 KFR(3) = IDLAM(LKNT,3)
57247 C...Calculate width.
57248 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57249 & IDLAM(LKNT,3),XLAM(LKNT))
57250 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57251 C...Charge conjugate mode.
57253 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57254 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57255 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57256 XLAM(LKNT)=XLAM(LKNT-1)
57257 C...KINEMATICS CHECK
57258 IF (XLAM(LKNT).EQ.0D0) THEN
57270 C*********************************************************************
57273 C...Calculates R-violating chargino decay widths.
57276 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
57278 C...Double precision and integer declarations.
57279 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57280 IMPLICIT INTEGER(I-N)
57281 C...Parameter statement to help give large particle numbers.
57282 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57283 &KEXCIT=4000000,KDIMEN=5000000)
57285 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57286 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57287 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57288 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57289 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57290 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57291 C...Local variables.
57292 DOUBLE PRECISION XLAM(0:400)
57293 INTEGER IDLAM(400,3), PYCOMP
57294 C...Information from main routine to PYRVGW
57295 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57297 C...Auxiliary variables needed for BV (RV Gauge STOre)
57298 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57300 C...Running quark masses
57301 DOUBLE PRECISION RMQ(6)
57302 C...Decay product masses on/off
57304 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57308 C...IF R-VIOLATION ON.
57309 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57311 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
57312 C...WHICH CHARGINO ?
57314 IF (KFSM.EQ.37) NCHI = 2
57316 C...Useful parameters for calculating the A and B constants.
57317 C...SIGN OF MASS (Opposite convention as HERWIG)
57319 IF (SMW(NCHI).LT.0D0) ISM = -1
57320 WMASS = PMAS(PYCOMP(24),1)
57321 COSB = 1/(SQRT(1+RMSS(5)**2))
57322 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
57323 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
57324 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
57325 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
57328 C...Running masses at Q^2=MCHI^2.
57329 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
57331 RMQ(I)=PYMRUN(I,SQMCHI)
57334 C... AB(x,y,z) coefficients:
57335 C x=1-2 : A or B coefficient (1:A ; 2:B)
57336 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57337 C 11-16:e,nu_e,mu,...)
57338 C z=1-2 : Mass eigenstate number
57340 C...Intermediate sleptons
57343 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
57345 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
57347 C...Intermediate sneutrinos
57348 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
57350 AB(2,I+1,1) = ISM*C3
57352 C...Intermediate sdown
57354 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
57355 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
57356 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
57357 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
57358 C...Intermediate sup
57360 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
57361 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
57362 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
57363 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
57366 C...LLE TYPE R-VIOLATION
57367 IF (IMSS(51).GE.1) THEN
57368 C...LOOP OVER DECAY MODES
57371 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57372 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57374 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
57375 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
57376 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
57378 C...Set coupling, and decay product masses on/off
57379 RVLAMC = GW2 * 5D-1 *
57380 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57383 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
57384 C...Resonance KF codes (1=I,2=J,3=K).
57387 KFR(3) = -IDLAM(LKNT,3)+1
57388 C...Calculate width.
57389 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57390 & IDLAM(LKNT,3),XLAM(LKNT))
57391 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57392 C...KINEMATICS CHECK
57393 IF (XLAM(LKNT).EQ.0D0) THEN
57397 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57398 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
57400 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57401 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
57402 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
57404 C...Set coupling, and decay product masses on/off
57405 RVLAMC = GW2 * 5D-1 *
57406 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57407 C...I,J SYMMETRY => FACTOR 2
57410 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
57411 C...Resonance KF codes (1=I,2=J,3=K)
57412 KFR(1)=IDLAM(LKNT,1)-1
57413 KFR(2)=IDLAM(LKNT,2)-1
57415 C...Calculate width.
57416 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57417 & IDLAM(LKNT,3),XLAM(LKNT))
57418 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57419 C...KINEMATICS CHECK
57420 IF (XLAM(LKNT).EQ.0D0) THEN
57425 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57427 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57428 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57429 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57431 C...Set coupling, and decay product masses on/off
57432 RVLAMC = GW2 * 5D-1 *
57433 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57434 C...I,J SYMMETRY => FACTOR 2
57437 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
57438 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
57439 C...Resonance KF codes (1=I,2=J,3=K)
57440 KFR(1) =-IDLAM(LKNT,1)+1
57441 KFR(2) =-IDLAM(LKNT,2)+1
57443 C...Calculate width.
57444 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57445 & IDLAM(LKNT,3),XLAM(LKNT))
57446 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57447 C...KINEMATICS CHECK
57448 IF (XLAM(LKNT).EQ.0D0) THEN
57455 C...LQD TYPE R-VIOLATION
57456 IF (IMSS(52).GE.1) THEN
57457 C...LOOP OVER DECAY MODES
57460 C...CHI+ -> NUBAR_I + DBAR_J + U_K
57462 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57463 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57464 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57466 C...Set coupling, and decay product masses on/off
57467 RVLAMC = 3. * GW2 * 5D-1 *
57468 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57470 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
57472 C...Resonance KF codes (1=I,2=J,3=K)
57475 KFR(3)=-IDLAM(LKNT,3)+1
57476 C...Calculate width.
57477 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57479 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57480 C...KINEMATICS CHECK
57481 IF (XLAM(LKNT).EQ.0D0) THEN
57485 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57487 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57488 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57489 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57491 C...Set coupling, and decay product masses on/off
57492 RVLAMC = 3. * GW2 * 5D-1 *
57493 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57495 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
57496 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
57497 C...Resonance KF codes (1=I,2=J,3=K)
57500 KFR(3)=-IDLAM(LKNT,3)+1
57501 C...Calculate width.
57502 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57504 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57505 C...KINEMATICS CHECK
57506 IF (XLAM(LKNT).EQ.0D0) THEN
57510 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57512 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57513 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57514 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57516 C...Set coupling, and decay product masses on/off
57517 RVLAMC = 3. * GW2 * 5D-1 *
57518 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57520 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
57521 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57522 C...Resonance KF codes (1=I,2=J,3=K)
57523 KFR(1)=-IDLAM(LKNT,1)+1
57524 KFR(2)=-IDLAM(LKNT,2)+1
57526 C...Calculate width.
57527 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57529 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57530 C...KINEMATICS CHECK
57531 IF (XLAM(LKNT).EQ.0D0) THEN
57535 C * CHI+ -> NU_I + U_J + DBAR_K.
57537 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57538 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57539 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57541 C...Set coupling, and decay product masses on/off
57543 RVLAMC = 3. * GW2 * 5D-1 *
57544 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57545 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
57547 C...Resonance KF codes (1=I,2=J,3=K)
57548 KFR(1)=IDLAM(LKNT,1)-1
57549 KFR(2)=IDLAM(LKNT,2)-1
57551 C...Calculate width.
57552 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57554 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57555 C...KINEMATICS CHECK
57556 IF (XLAM(LKNT).EQ.0D0) THEN
57563 C...UDD TYPE R-VIOLATION
57564 C...These decays need special treatment since more than one BV coupling
57565 C...contributes (with interference). Consider e.g. (symbolically)
57566 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57567 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57568 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57569 C...The problem is that a single call to PYRVGW would evaluate all
57570 C...these terms and sum them, but without the different couplings. The
57571 C...way out is to call PYRVGW three times, once for the first line, once
57572 C...for the second line, and then once for all the lines (it is
57573 C...impossible to get just the last line out) without multiplying by
57574 C...couplings. The last line is then obtained as the result of the third
57575 C...call minus the results of the two first calls. Each term is then
57576 C...multiplied by its respective coupling before the whole thing is
57577 C...summed up in XLAM.
57578 C...Note that with three interfering resonances, this procedure becomes
57579 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57581 IF (IMSS(53).GE.1) THEN
57582 C...LOOP OVER DECAY MODES
57585 C...CHI+ -> U_I + U_J + D_K
57586 C...Decay mode I<->J symmetric.
57587 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
57589 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
57590 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57591 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57593 C...Set coupling, and decay product masses on/off
57594 RVLAMC= 6. * GW2 * 5D-1
57595 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
57597 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57599 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
57602 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
57603 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
57604 C...Resonance KF codes (1=I,2=J,3=K)
57605 KFR(1) = -IDLAM(LKNT,1)+1
57608 C...Calculate width.
57609 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57610 & IDLAM(LKNT,3),XRESI)
57611 C...Resonance KF codes (1=I,2=J,3=K)
57613 KFR(2) = -IDLAM(LKNT,2)+1
57615 C...Calculate width.
57616 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57617 & IDLAM(LKNT,3),XRESJ)
57618 C...Resonance KF codes (1=I,2=J,3=K)
57619 KFR(1) = -IDLAM(LKNT,1)+1
57620 KFR(2) = -IDLAM(LKNT,2)+1
57622 C...Calculate width.
57623 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57624 & IDLAM(LKNT,3),XRESIJ)
57625 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57626 XRESIJ = XRESIJ-XRESI-XRESJ
57630 C...CALCULATE TOTAL WIDTH
57631 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
57632 & + RVLJIK*RVLIJK * XRESIJ
57633 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57634 C...KINEMATICS CHECK
57635 IF (XLAM(LKNT).EQ.0D0) THEN
57639 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57640 C...Symmetry I<->J<->K.
57641 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
57642 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
57644 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
57645 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57646 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57648 C...Set coupling, and decay product masses on/off
57649 RVLAMC = 6. * GW2 * 5D-1
57650 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57652 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
57654 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
57657 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
57658 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
57659 C...Collect symmetry factors
57660 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
57661 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
57662 & RVLAMC = 5D-1 * RVLAMC
57663 C...Resonance KF codes (1=I,2=J,3=K)
57664 KFR(1) = IDLAM(LKNT,1)-1
57667 C...Calculate width.
57668 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57669 & IDLAM(LKNT,3),XRESI)
57670 C...Resonance KF codes (1=I,2=J,3=K)
57672 KFR(2) = IDLAM(LKNT,2)-1
57674 C...Calculate width.
57675 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57676 & IDLAM(LKNT,3),XRESJ)
57677 C...Resonance KF codes (1=I,2=J,3=K)
57680 KFR(3) = IDLAM(LKNT,3)-1
57681 C...Calculate width.
57682 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57683 & IDLAM(LKNT,3),XRESK)
57684 C...Resonance KF codes (1=I,2=J,3=K)
57685 KFR(1) = IDLAM(LKNT,1)-1
57686 KFR(2) = IDLAM(LKNT,2)-1
57688 C...Calculate width.
57689 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57690 & IDLAM(LKNT,3),XRESIJ)
57691 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
57692 XRESIJ = XRESI+XRESJ-XRESIJ
57696 C...Resonance KF codes (1=I,2=J,3=K)
57698 KFR(2) = IDLAM(LKNT,2)-1
57699 KFR(3) = IDLAM(LKNT,3)-1
57700 C...Calculate width.
57701 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57702 & IDLAM(LKNT,3),XRESJK)
57703 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
57704 XRESJK = XRESJ+XRESK-XRESJK
57708 C...Resonance KF codes (1=I,2=J,3=K)
57709 KFR(1) = IDLAM(LKNT,1)-1
57711 KFR(3) = IDLAM(LKNT,3)-1
57712 C...Calculate width.
57713 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57714 & IDLAM(LKNT,3),XRESIK)
57715 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
57716 XRESIK = XRESI+XRESK-XRESIK
57720 C...CALCULATE TOTAL WIDTH
57722 & RVLIJK**2 * XRESI
57723 & + RVLJKI**2 * XRESJ
57724 & + RVLKIJ**2 * XRESK
57725 & + RVLIJK*RVLJKI * XRESIJ
57726 & + RVLIJK*RVLKIJ * XRESIK
57727 & + RVLJKI*RVLKIJ * XRESJK
57728 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
57729 C...KINEMATICS CHECK
57730 IF (XLAM(LKNT).EQ.0D0) THEN
57742 C*********************************************************************
57745 C...Calculates R-violating gluino decay widths.
57746 C...See BV part of PYRVCH for comments about the way the BV decay width
57747 C...is calculated. Same comments apply here.
57750 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
57752 C...Double precision and integer declarations.
57753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57754 IMPLICIT INTEGER(I-N)
57755 C...Parameter statement to help give large particle numbers.
57756 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57757 &KEXCIT=4000000,KDIMEN=5000000)
57759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57760 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57761 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57762 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57763 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57764 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57765 C...Local variables.
57766 DOUBLE PRECISION XLAM(0:400)
57767 INTEGER IDLAM(400,3), PYCOMP
57768 C...Information from main routine to PYRVGW
57769 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57771 C...Auxiliary variables needed for BV (RV Gauge STOre)
57772 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57774 C...Running quark masses
57775 DOUBLE PRECISION RMQ(6)
57776 C...Decay product masses on/off
57778 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57781 C...IF LQD OR UDD TYPE R-VIOLATION ON.
57782 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
57786 C x=1-2 : Select A or B coupling (1:A ; 2:B)
57787 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57788 C 11-16:e,nu_e,mu,... not used here)
57789 C z=1-2 : Mass eigenstate number
57792 AB(1,I,1) = SFMIX(I,2)
57793 AB(1,I,2) = SFMIX(I,4)
57795 AB(2,I,1) = -SFMIX(I,1)
57796 AB(2,I,2) = -SFMIX(I,3)
57798 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
57800 IF (IMSS(52).GE.1) THEN
57801 C...STEP IN I,J,K USING SINGLE COUNTER
57803 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57805 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57806 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57807 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57809 C...Set coupling, and decay product masses on/off
57810 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57813 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57814 C...Resonance KF codes (1=I,2=J,3=K)
57816 KFR(2) = -IDLAM(LKNT,2)
57817 KFR(3) = -IDLAM(LKNT,3)
57818 C...Calculate width.
57819 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57822 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57823 C...Charge conjugate mode.
57825 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57826 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57827 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57828 XLAM(LKNT) = XLAM(LKNT-1)
57829 C...KINEMATICS CHECK
57830 IF (XLAM(LKNT).EQ.0D0) THEN
57834 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57836 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57837 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57838 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57840 C...Set coupling, and decay product masses on/off
57841 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57842 & **2* 5D-1 * GSTR2
57844 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57845 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57846 C...Resonance KF codes (1=I,2=J,3=K)
57848 KFR(2) = -IDLAM(LKNT,2)
57849 KFR(3) = -IDLAM(LKNT,3)
57850 C...Calculate width.
57851 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57853 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57854 C...Charge conjugate mode.
57856 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
57857 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
57858 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
57859 XLAM(LKNT) = XLAM(LKNT-1)
57860 C...KINEMATICS CHECK
57861 IF (XLAM(LKNT).EQ.0D0) THEN
57869 IF (IMSS(53).GE.1) THEN
57870 C...STEP IN I,J,K USING SINGLE COUNTER
57872 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57873 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57875 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57876 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57877 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57879 C...Set coupling, and decay product masses on/off. A factor of 2 for
57880 C...(N_C-1) has been used to cancel a factor 0.5.
57881 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57884 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57885 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57886 C...Resonance KF codes (1=I,2=J,3=K)
57887 KFR(1) = IDLAM(LKNT,1)
57890 C...Calculate width.
57891 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57893 C...Resonance KF codes (1=I,2=J,3=K)
57895 KFR(2) = IDLAM(LKNT,2)
57897 C...Calculate width.
57898 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57900 C...Resonance KF codes (1=I,2=J,3=K)
57903 KFR(3) = IDLAM(LKNT,3)
57904 C...Calculate width.
57905 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57907 C...Resonance KF codes (1=I,2=J,3=K)
57908 KFR(1) = IDLAM(LKNT,1)
57909 KFR(2) = IDLAM(LKNT,2)
57911 C...Calculate width.
57912 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57914 C...Calculate interference function. (Factor -1/2 to make up for factor
57916 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57917 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
57921 C...Resonance KF codes (1=I,2=J,3=K)
57923 KFR(2) = IDLAM(LKNT,2)
57924 KFR(3) = IDLAM(LKNT,3)
57925 C...Calculate width.
57926 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57928 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
57929 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
57933 C...Resonance KF codes (1=I,2=J,3=K)
57934 KFR(1) = IDLAM(LKNT,1)
57936 KFR(3) = IDLAM(LKNT,3)
57937 C...Calculate width.
57938 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57940 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
57941 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
57945 C...Calculate total width (factor 1/2 from 1/(N_C-1))
57946 XLAM(LKNT) = XRESI + XRESJ + XRESK
57947 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
57949 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57950 C...Charge conjugate mode.
57952 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57953 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57954 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57955 XLAM(LKNT) = XLAM(LKNT-1)
57956 C...KINEMATICS CHECK
57957 IF (XLAM(LKNT).EQ.0D0) THEN
57967 C*********************************************************************
57970 C...Auxiliary function to PYRVSF for calculating R-Violating
57971 C...sfermion widths. Though the decay products are most often treated
57972 C...as massless in the calculation, the kinematical boundary of phase
57973 C...space is tested using the true masses.
57974 C...MODE = 1: All decay products massive
57975 C...MODE = 2: Decay product 1 massless
57976 C...MODE = 3: Decay product 2 massless
57977 C...MODE = 4: All decay products massless
57979 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
57981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
57982 IMPLICIT INTEGER (I-N)
57983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57984 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57985 SAVE /PYDAT1/,/PYDAT2/
57986 DOUBLE PRECISION SM(3)
57987 INTEGER PYCOMP, KC(3)
57991 SM(1)=PMAS(KC(1),1)**2
57992 SM(2)=PMAS(KC(2),1)**2
57993 SM(3)=PMAS(KC(3),1)**2
57994 C...Kinematics check
57995 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
57999 C...CM momenta squared
58000 IF (MODE.EQ.1) THEN
58001 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
58002 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
58003 ELSE IF (MODE.EQ.2) THEN
58004 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
58005 ELSE IF (MODE.EQ.3) THEN
58006 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58010 C...Calculate Width
58011 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58015 C*********************************************************************
58018 C...Generalized Matrix Element for R-Violating 3-body widths.
58020 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58022 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58023 IMPLICIT INTEGER (I-N)
58024 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58025 &KEXCIT=4000000,KDIMEN=5000000)
58026 PARAMETER (EPS=1D-4)
58027 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58028 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58030 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58031 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58032 DOUBLE PRECISION XLIM(3,3)
58033 INTEGER KC(0:3), PYCOMP
58034 LOGICAL DCMASS, DCHECK(6)
58035 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58039 KC(0) = PYCOMP(KFIN)
58040 KC(1) = PYCOMP(ID1)
58041 KC(2) = PYCOMP(ID2)
58042 KC(3) = PYCOMP(ID3)
58043 RMS(0) = PMAS(KC(0),1)
58044 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58045 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58046 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58047 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58048 XLIM(1,1)=(RMS(1)+RMS(2))**2
58049 XLIM(1,2)=(RMS(0)-RMS(3))**2
58050 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58051 XLIM(2,1)=(RMS(2)+RMS(3))**2
58052 XLIM(2,2)=(RMS(0)-RMS(1))**2
58053 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58054 XLIM(3,1)=(RMS(1)+RMS(3))**2
58055 XLIM(3,2)=(RMS(0)-RMS(2))**2
58056 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58057 C...Check Phase Space
58058 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58062 C...INITIALIZE RESONANCE INFORMATION
58065 IRES = 2*(JRES-1)+IMASS
58067 DCHECK(IRES) =.FALSE.
58068 C...NO RIGHT-HANDED NEUTRINOS
58069 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58070 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58071 & .KFR(JRES).EQ.0) GOTO 100
58072 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58073 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58074 INTRES(IRES,1) = IABS(KFR(JRES))
58075 INTRES(IRES,2) = IMASS
58076 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58077 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58081 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58083 C...RESONANCE CONTRIBUTIONS
58084 C...(Only sum contributions where the resonance is off shell).
58085 C...Store whether diagram on/off in DCHECK.
58086 C...LOOP OVER MASS STATES
58089 IF(INTRES(IDR,1).NE.0) THEN
58091 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58092 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58093 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58094 DCHECK(IDR) =.TRUE.
58095 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58100 IF(INTRES(IDR,1).NE.0) THEN
58101 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58102 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58103 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58104 DCHECK(IDR) =.TRUE.
58105 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58110 IF(INTRES(IDR,1).NE.0) THEN
58111 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58112 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58113 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58114 DCHECK(IDR) =.TRUE.
58115 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58119 C... L-R INTERFERENCES
58120 C... (Only add contributions where both contributing diagrams
58121 C... are non-resonant).
58123 IF (DCHECK(1).AND.DCHECK(2)) THEN
58124 C...Bug corrected 11/12 2001. Skands.
58125 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58126 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58127 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58131 IF (DCHECK(3).AND.DCHECK(4)) THEN
58132 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58133 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58134 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58138 IF (DCHECK(5).AND.DCHECK(6)) THEN
58139 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58140 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58141 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58143 C... TRUE INTERFERENCES
58144 C... (Only add contributions where both contributing diagrams
58145 C... are non-resonant).
58147 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58152 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58153 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58154 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58155 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58160 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58161 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58162 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58163 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58168 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58169 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58170 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58171 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58179 C*********************************************************************
58182 C...Function to integrate resonance contributions
58184 FUNCTION PYRVI1(ID1,ID2,ID3)
58187 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58188 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58189 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58190 LOGICAL MFLAG,DCMASS
58191 EXTERNAL PYRVG1,PYGAUS
58192 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58194 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58195 SAVE/PYRVNV/,/PYRVPM/
58196 C...Initialize mass and width information
58202 RESM(1)= RES(IDR,1)
58203 RESW(1)= RES(IDR,2)
58204 C...A->B and B->A for antisparticles
58205 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58206 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58207 C...Integration boundaries and mass flag
58208 LO = (RM(1)+RM(2))**2
58209 HI = (RM(0)-RM(3))**2
58211 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
58215 C*********************************************************************
58218 C...Function to integrate L-R interference contributions
58220 FUNCTION PYRVI2(ID1,ID2,ID3)
58223 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58224 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58225 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58226 LOGICAL MFLAG,DCMASS
58227 EXTERNAL PYRVG2,PYGAUS
58228 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58230 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58231 SAVE/PYRVNV/,/PYRVPM/
58232 C...Initialize mass and width information
58238 RESM(1)= RES(IDR,1)
58239 RESW(1)= RES(IDR,2)
58240 RESM(2)= RES(IDR+1,1)
58241 RESW(2)= RES(IDR+1,2)
58242 C...A->B and B->A for antisparticles
58243 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58244 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58245 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58246 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58247 C...Boundaries and mass flag
58248 LO = (RM(1)+RM(2))**2
58249 HI = (RM(0)-RM(3))**2
58251 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
58255 C*********************************************************************
58258 C...Function to integrate true interference contributions
58260 FUNCTION PYRVI3(ID1,ID2,ID3)
58263 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58264 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58265 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58266 LOGICAL MFLAG,DCMASS
58267 EXTERNAL PYRVG3,PYGAUS
58268 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58270 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58271 SAVE/PYRVNV/,/PYRVPM/
58272 C...Initialize mass and width information
58278 RESM(1)= RES(IDR,1)
58279 RESW(1)= RES(IDR,2)
58280 RESM(2)= RES(IDR2,1)
58281 RESW(2)= RES(IDR2,2)
58282 C...A -> B and B -> A for antisparticles
58283 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58284 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58285 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58286 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58287 C...Boundaries and mass flag
58288 LO = (RM(1)+RM(2))**2
58289 HI = (RM(0)-RM(3))**2
58291 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
58295 C*********************************************************************
58298 C...Integrand for resonance contributions
58303 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58304 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58305 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58308 RVR = PYRVR(X,RESM(1),RESW(1))
58309 C1 = 2D0*SQRT(MAX(0D0,X))
58310 IF (.NOT.MFLAG) THEN
58312 E3 = (RM(0)**2-X)/C1
58314 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
58316 E2 = (X-RM(1)**2+RM(2)**2)/C1
58317 E3 = (RM(0)**2-X-RM(3)**2)/C1
58318 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58319 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58320 DELTAY = 4D0*SR1*SR2
58321 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
58322 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
58323 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
58328 C*********************************************************************
58331 C...Integrand for L-R interference contributions
58336 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58337 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58338 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58341 C1 = 2D0*SQRT(MAX(0D0,X))
58342 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
58343 IF (.NOT.MFLAG) THEN
58345 E3 = (RM(0)**2-X)/C1
58347 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
58349 E2 = (X-RM(1)**2+RM(2)**2)/C1
58350 E3 = (RM(0)**2-X-RM(3)**2)/C1
58351 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58352 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58353 DELTAY = 4D0*SR1*SR2
58354 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
58355 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
58356 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
58361 C*********************************************************************
58364 C...Function to do Y integration over true interference contributions
58369 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58370 C...Second Dalitz variable for PYRVG4
58372 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58373 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58374 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58376 EXTERNAL PYGAU2,PYRVG4
58377 SAVE/PYRVPM/,/PYG2DX/
58379 C1=2D0*SQRT(MAX(1D-9,X))
58381 IF (.NOT.MFLAG) THEN
58383 E3 = (RM(0)**2-X)/C1
58387 E2 = (X-RM(1)**2+RM(2)**2)/C1
58388 E3 = (RM(0)**2-X-RM(3)**2)/C1
58390 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58391 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58392 YMIN = SQ1-(SR1+SR2)**2
58393 YMAX = SQ1-(SR1-SR2)**2
58395 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
58399 C*********************************************************************
58402 C...Integrand for true intereference contributions
58407 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58409 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58411 SAVE /PYRVPM/,/PYG2DX/
58413 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
58414 IF (.NOT.MFLAG) THEN
58415 PYRVG4 = RVS*B(1)*B(2)*X*Y
58417 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
58418 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
58419 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
58420 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
58425 C*********************************************************************
58428 C...Breit-Wigner for resonance contributions
58430 FUNCTION PYRVR(Mab2,RM,RW)
58433 DOUBLE PRECISION Mab2,RM,RW,PYRVR
58434 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
58438 C*********************************************************************
58441 C...Interference function
58443 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
58446 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58447 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
58452 C*********************************************************************
58455 C...Stores one parton/particle in commonblock PYJETS.
58457 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
58459 C...Double precision and integer declarations.
58460 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58461 IMPLICIT INTEGER(I-N)
58462 INTEGER PYK,PYCHGE,PYCOMP
58464 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58465 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58466 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58467 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58469 C...Standard checks.
58471 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58472 IPA=MAX(1,IABS(IP))
58473 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
58474 &'(PY1ENT:) writing outside PYJETS memory')
58476 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
58478 C...Find mass. Reset K, P and V vectors.
58480 IF(MSTU(10).EQ.1) PM=P(IPA,5)
58481 IF(MSTU(10).GE.2) PM=PYMASS(KF)
58488 C...Store parton/particle in K and P vectors.
58490 IF(IP.LT.0) K(IPA,1)=2
58493 P(IPA,4)=MAX(PE,PM)
58494 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
58495 P(IPA,1)=PA*SIN(THE)*COS(PHI)
58496 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
58497 P(IPA,3)=PA*COS(THE)
58499 C...Set N. Optionally fragment/decay.
58501 IF(IP.EQ.0) CALL PYEXEC
58506 C*********************************************************************
58509 C...Stores two partons/particles in their CM frame,
58510 C...with the first along the +z axis.
58512 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
58514 C...Double precision and integer declarations.
58515 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58516 IMPLICIT INTEGER(I-N)
58517 INTEGER PYK,PYCHGE,PYCOMP
58519 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58520 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58521 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58522 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58524 C...Standard checks.
58526 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58527 IPA=MAX(1,IABS(IP))
58528 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
58529 &'(PY2ENT:) writing outside PYJETS memory')
58532 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
58533 &'(PY2ENT:) unknown flavour code')
58535 C...Find masses. Reset K, P and V vectors.
58537 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58538 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58540 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58541 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58550 C...Check flavours.
58551 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58552 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58553 IF(MSTU(19).EQ.1) THEN
58556 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
58557 & '(PY2ENT:) unphysical flavour combination')
58562 C...Store partons/particles in K vectors for normal case.
58565 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
58568 C...Store partons in K vectors for parton shower evolution.
58572 K(IPA,4)=MSTU(5)*(IPA+1)
58574 K(IPA+1,4)=MSTU(5)*IPA
58575 K(IPA+1,5)=K(IPA+1,4)
58578 C...Check kinematics and store partons/particles in P vectors.
58579 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
58580 &'(PY2ENT:) energy smaller than sum of masses')
58581 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
58584 P(IPA,4)=SQRT(PM1**2+PA**2)
58587 P(IPA+1,4)=SQRT(PM2**2+PA**2)
58590 C...Set N. Optionally fragment/decay.
58592 IF(IP.EQ.0) CALL PYEXEC
58597 C*********************************************************************
58600 C...Stores three partons or particles in their CM frame,
58601 C...with the first along the +z axis and the third in the (x,z)
58602 C...plane with x > 0.
58604 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
58606 C...Double precision and integer declarations.
58607 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58608 IMPLICIT INTEGER(I-N)
58609 INTEGER PYK,PYCHGE,PYCOMP
58611 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58612 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58613 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58614 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58616 C...Standard checks.
58618 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58619 IPA=MAX(1,IABS(IP))
58620 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
58621 &'(PY3ENT:) writing outside PYJETS memory')
58625 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
58626 &'(PY3ENT:) unknown flavour code')
58628 C...Find masses. Reset K, P and V vectors.
58630 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58631 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58633 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58634 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58636 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58637 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58646 C...Check flavours.
58647 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58648 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58649 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58650 IF(MSTU(19).EQ.1) THEN
58652 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
58653 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
58654 & KQ1+KQ3.EQ.4)) THEN
58656 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
58662 C...Store partons/particles in K vectors for normal case.
58665 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
58667 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
58670 C...Store partons in K vectors for parton shower evolution.
58676 IF(KQ1.EQ.-1) KCS=5
58677 K(IPA,KCS)=MSTU(5)*(IPA+1)
58678 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
58679 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58680 K(IPA+1,9-KCS)=MSTU(5)*IPA
58681 K(IPA+2,KCS)=MSTU(5)*IPA
58682 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58685 C...Check kinematics.
58687 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
58688 &0.5D0*X3*PECM.LE.PM3) MKERR=1
58689 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58690 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
58691 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
58692 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
58693 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
58694 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
58695 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
58696 IF(MKERR.NE.0) CALL PYERRM(13,
58697 &'(PY3ENT:) unphysical kinematical variable setup')
58699 C...Store partons/particles in P vectors.
58701 P(IPA,4)=SQRT(PA1**2+PM1**2)
58703 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
58704 P(IPA+2,3)=PA3*CTHE3
58705 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
58707 P(IPA+1,1)=-P(IPA+2,1)
58708 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
58709 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
58712 C...Set N. Optionally fragment/decay.
58714 IF(IP.EQ.0) CALL PYEXEC
58719 C*********************************************************************
58722 C...Stores four partons or particles in their CM frame, with
58723 C...the first along the +z axis, the last in the xz plane with x > 0
58724 C...and the second having y < 0 and y > 0 with equal probability.
58726 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58728 C...Double precision and integer declarations.
58729 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58730 IMPLICIT INTEGER(I-N)
58731 INTEGER PYK,PYCHGE,PYCOMP
58733 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58734 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58735 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58736 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58738 C...Standard checks.
58740 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58741 IPA=MAX(1,IABS(IP))
58742 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
58743 &'(PY4ENT:) writing outside PYJETS momory')
58748 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
58749 &'(PY4ENT:) unknown flavour code')
58751 C...Find masses. Reset K, P and V vectors.
58753 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58754 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58756 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58757 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58759 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58760 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58762 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
58763 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
58772 C...Check flavours.
58773 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58774 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58775 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58776 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
58777 IF(MSTU(19).EQ.1) THEN
58779 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
58780 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
58781 & KQ1+KQ4.EQ.4)) THEN
58782 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
58785 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
58792 C...Store partons/particles in K vectors for normal case.
58795 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
58797 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
58800 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
58803 C...Store partons for parton shower evolution from q-g-g-qbar or
58805 ELSEIF(KQ1+KQ2.NE.0) THEN
58811 IF(KQ1.EQ.-1) KCS=5
58812 K(IPA,KCS)=MSTU(5)*(IPA+1)
58813 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
58814 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58815 K(IPA+1,9-KCS)=MSTU(5)*IPA
58816 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
58817 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58818 K(IPA+3,KCS)=MSTU(5)*IPA
58819 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
58821 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58827 K(IPA,4)=MSTU(5)*(IPA+1)
58829 K(IPA+1,4)=MSTU(5)*IPA
58830 K(IPA+1,5)=K(IPA+1,4)
58831 K(IPA+2,4)=MSTU(5)*(IPA+3)
58832 K(IPA+2,5)=K(IPA+2,4)
58833 K(IPA+3,4)=MSTU(5)*(IPA+2)
58834 K(IPA+3,5)=K(IPA+3,4)
58837 C...Check kinematics.
58839 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
58840 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
58842 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58843 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
58844 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
58845 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
58846 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
58847 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
58848 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
58849 STHE4=SQRT(1D0-CTHE4**2)
58850 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
58851 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
58852 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
58853 STHE2=SQRT(1D0-CTHE2**2)
58854 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
58855 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
58856 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
58857 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
58858 IF(MKERR.EQ.1) CALL PYERRM(13,
58859 &'(PY4ENT:) unphysical kinematical variable setup')
58861 C...Store partons/particles in P vectors.
58863 P(IPA,4)=SQRT(PA1**2+PM1**2)
58865 P(IPA+3,1)=PA4*STHE4
58866 P(IPA+3,3)=PA4*CTHE4
58867 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
58869 P(IPA+1,1)=PA2*STHE2*CPHI2
58870 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
58871 P(IPA+1,3)=PA2*CTHE2
58872 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
58874 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
58875 P(IPA+2,2)=-P(IPA+1,2)
58876 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
58877 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
58880 C...Set N. Optionally fragment/decay.
58882 IF(IP.EQ.0) CALL PYEXEC
58887 C*********************************************************************
58890 C...An interface from a two-fermion generator to include
58891 C...parton showers and hadronization.
58893 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
58895 C...Double precision and integer declarations.
58896 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58897 IMPLICIT INTEGER(I-N)
58898 INTEGER PYK,PYCHGE,PYCOMP
58900 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58901 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58902 SAVE /PYJETS/,/PYDAT1/
58904 DIMENSION IJOIN(2),INTAU(2)
58906 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58912 C...Loop through entries and pick up all final fermions/antifermions.
58916 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
58918 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
58919 IF(K(I,2).GT.0) THEN
58923 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
58929 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
58935 C...Check that event is arranged according to conventions.
58936 IF(I1.EQ.0.OR.I2.EQ.0) THEN
58937 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
58940 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
58943 C...Check whether fermion pair is quarks or leptons.
58944 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
58946 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
58949 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
58952 C...Decide whether to allow or not photon radiation in showers.
58954 IF(IRAD.EQ.0) MSTJ(41)=1
58956 C...Do colour joining and parton showers.
58959 IF(IQL12.EQ.1) THEN
58962 CALL PYJOIN(2,IJOIN)
58964 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
58965 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
58966 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
58967 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
58970 C...Do fragmentation and decays. Possibly except tau decay.
58974 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
58988 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58996 C*********************************************************************
58999 C...An interface from a four-fermion generator to include
59000 C...parton showers and hadronization.
59002 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
59004 C...Double precision and integer declarations.
59005 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59006 IMPLICIT INTEGER(I-N)
59007 INTEGER PYK,PYCHGE,PYCOMP
59009 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59011 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59012 COMMON/PYINT1/MINT(400),VINT(400)
59013 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59015 DIMENSION IJOIN(2),INTAU(4)
59017 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59023 C...Loop through entries and pick up all final fermions/antifermions.
59029 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59031 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59032 IF(K(I,2).GT.0) THEN
59035 ELSEIF(I3.EQ.0) THEN
59038 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59043 ELSEIF(I4.EQ.0) THEN
59046 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59052 C...Check that event is arranged according to conventions.
59053 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59054 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59056 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59057 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59060 C...Check which fermion pairs are quarks and which leptons.
59061 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59063 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59066 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59068 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59070 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59073 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59076 C...Decide whether to allow or not photon radiation in showers.
59078 IF(IRAD.EQ.0) MSTJ(41)=1
59080 C...Decide on dipole pairing.
59085 IF(IQL12.EQ.IQL34) THEN
59088 DELTA=ATOTSQ-A1SQ-A2SQ
59089 IF(ISTRAT.EQ.1) THEN
59090 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59091 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59092 ELSEIF(ISTRAT.EQ.2) THEN
59093 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59094 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59096 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59102 C...If colour reconnection then bookkeep W+W- or Z0Z0
59103 C...and copy q qbar q qbar consecutively.
59104 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59113 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59117 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59131 P(N+1,J)=P(IP1,J)+P(IP2,J)
59132 P(N+2,J)=P(IP3,J)+P(IP4,J)
59144 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59146 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59152 C...Remove original q qbar q qbar and update counters.
59153 K(IP1,1)=K(IP1,1)+10
59154 K(IP2,1)=K(IP2,1)+10
59155 K(IP3,1)=K(IP3,1)+10
59156 K(IP4,1)=K(IP4,1)+10
59167 C...Do colour joinings and parton showers.
59168 IF(IQL12.EQ.1) THEN
59171 CALL PYJOIN(2,IJOIN)
59173 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59174 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59175 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59176 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59179 IF(IQL34.EQ.1) THEN
59182 CALL PYJOIN(2,IJOIN)
59184 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59185 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59186 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59187 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59190 C...Optionally do colour reconnection.
59193 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59194 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
59198 C...Do fragmentation and decays. Possibly except tau decay.
59202 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59216 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59224 C*********************************************************************
59227 C...An interface from a six-fermion generator to include
59228 C...parton showers and hadronization.
59230 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59232 C...Double precision and integer declarations.
59233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59234 IMPLICIT INTEGER(I-N)
59235 INTEGER PYK,PYCHGE,PYCOMP
59237 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59238 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59239 SAVE /PYJETS/,/PYDAT1/
59241 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
59243 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59249 C...Loop through entries and pick up all final fermions/antifermions.
59257 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59259 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59260 IF(K(I,2).GT.0) THEN
59263 ELSEIF(I3.EQ.0) THEN
59265 ELSEIF(I5.EQ.0) THEN
59268 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
59273 ELSEIF(I4.EQ.0) THEN
59275 ELSEIF(I6.EQ.0) THEN
59278 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
59284 C...Check that event is arranged according to conventions.
59285 IF(I5.EQ.0.OR.I6.EQ.0) THEN
59286 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
59288 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
59289 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
59292 C...Check which fermion pairs are quarks and which leptons.
59293 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59295 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59298 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
59300 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59302 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59305 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
59307 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
59309 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
59312 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
59315 C...Decide whether to allow or not photon radiation in showers.
59317 IF(IRAD.EQ.0) MSTJ(41)=1
59319 C...Allow dipole pairings only among leptons and quarks separately.
59322 IF(IQL34.EQ.IQL56) P13D=P13
59324 IF(IQL12.EQ.IQL34) P21D=P21
59326 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
59328 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
59330 IF(IQL12.EQ.IQL56) P32D=P32
59332 C...Decide whether t+tbar.
59334 IF(PYR(0).LT.PTOP) THEN
59337 C...If t+tbar: reconstruct t's.
59343 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
59344 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
59352 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
59354 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
59358 C...If t+tbar: colour join t's and let them shower.
59361 CALL PYJOIN(2,IJOIN)
59362 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
59363 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
59364 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
59366 C...If t+tbar: pick up the t's after shower.
59370 IF(K(I,2).EQ.6) ITNEW=I
59371 IF(K(I,2).EQ.-6) ITBNEW=I
59374 C...If t+tbar: loop over two top systems.
59389 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
59390 & '(PY6FRM:) not b in t decay')
59392 C...If t+tbar: find boost from original to new top frame.
59394 BETAO(J)=P(ITO,J)/P(ITO,4)
59395 BETAN(J)=P(ITN,J)/P(ITN,4)
59398 C...If t+tbar: boost copy of b by t shower and connect it in colour.
59408 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59409 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59410 K(IB,4)=MSTU(5)*ITN
59411 K(IB,5)=MSTU(5)*ITN
59412 K(ITN,4)=K(ITN,4)+IB
59413 K(ITN,5)=K(ITN,5)+IB
59414 K(ITN,1)=K(ITN,1)+10
59415 K(IBO,1)=K(IBO,1)+10
59417 C...If t+tbar: construct W recoiling against b.
59425 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
59426 IF(IABS(KCHW).EQ.3) THEN
59427 K(IW,2)=ISIGN(24,KCHW)
59429 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
59433 C...If t+tbar: construct W momentum, including boost by t shower.
59435 P(IW,J)=P(IW1,J)+P(IW2,J)
59437 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
59439 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59440 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59442 C...If t+tbar: boost b and W to top rest frame.
59444 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
59446 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59447 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59449 C...If t+tbar: let b shower and pick up modified W.
59450 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
59451 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
59452 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
59454 IF(IABS(K(I,2)).EQ.24) IWM=I
59457 C...If t+tbar: take copy of W decay products.
59466 K(IW1,1)=K(IW1,1)+10
59467 K(IW2,1)=K(IW2,1)+10
59468 K(IWM,1)=K(IWM,1)+10
59482 C...If t+tbar: boost W decay products, first by effects of t shower,
59483 C...then by those of b shower. b and its shower simple boost back.
59484 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59485 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59486 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59487 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
59488 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
59489 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
59490 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
59491 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
59492 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
59496 C...Decide on dipole pairing.
59500 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
59501 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
59505 ELSEIF(PRN.LT.P12D+P13D) THEN
59509 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
59513 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
59517 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
59527 C...Do colour joinings and parton showers
59528 C...(except ones already made for t+tbar).
59530 IF(IQL12.EQ.1) THEN
59533 CALL PYJOIN(2,IJOIN)
59535 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59536 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59537 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59538 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59541 IF(IQL34.EQ.1) THEN
59544 CALL PYJOIN(2,IJOIN)
59546 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59547 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59548 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59549 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59551 IF(IQL56.EQ.1) THEN
59554 CALL PYJOIN(2,IJOIN)
59556 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
59557 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
59558 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
59559 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
59562 C...Do fragmentation and decays. Possibly except tau decay.
59566 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59580 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59588 C*********************************************************************
59591 C...An interface from a four-parton generator to include
59592 C...parton showers and hadronization.
59594 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
59596 C...Double precision and integer declarations.
59597 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59598 IMPLICIT INTEGER(I-N)
59599 INTEGER PYK,PYCHGE,PYCOMP
59601 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59602 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59603 SAVE /PYJETS/,/PYDAT1/
59605 DIMENSION IJOIN(2),PTOT(4),BETA(3)
59607 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59613 C...Loop through entries and pick up all final partons.
59619 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59621 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
59622 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
59625 ELSEIF(I3.EQ.0) THEN
59628 CALL PYERRM(16,'(PY4JET:) more than two quarks')
59630 ELSEIF(K(I,2).LT.0) THEN
59633 ELSEIF(I4.EQ.0) THEN
59636 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
59641 ELSEIF(I4.EQ.0) THEN
59644 CALL PYERRM(16,'(PY4JET:) more than two gluons')
59650 C...Check that event is arranged according to conventions.
59651 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
59652 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
59654 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59655 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
59658 C...Check whether second pair are quarks or gluons.
59659 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59661 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
59664 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
59667 C...Boost partons to their cm frame.
59669 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
59671 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
59673 BETA(J)=PTOT(J)/PTOT(4)
59675 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59676 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59677 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59678 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59681 C...Decide and set up shower history for q qbar q' qbar' events.
59682 IF(IQG34.EQ.1) THEN
59683 W1=PY4JTW(0,I1,I3,I4)
59684 W2=PY4JTW(0,I2,I3,I4)
59685 IF(W1.GT.PYR(0)*(W1+W2)) THEN
59686 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59688 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59691 C...Decide and set up shower history for q qbar g g events.
59693 W1=PY4JTW(I1,I3,I2,I4)
59694 W2=PY4JTW(I1,I4,I2,I3)
59695 W3=PY4JTW(0,I3,I1,I4)
59696 W4=PY4JTW(0,I4,I1,I3)
59697 W5=PY4JTW(0,I3,I2,I4)
59698 W6=PY4JTW(0,I4,I2,I3)
59699 W7=PY4JTW(0,I1,I3,I4)
59700 W8=PY4JTW(0,I2,I3,I4)
59701 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
59703 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
59704 ELSEIF(W1+W2.GT.WR) THEN
59705 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
59706 ELSEIF(W1+W2+W3.GT.WR) THEN
59707 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
59708 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
59709 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
59710 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
59711 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
59712 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
59713 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
59714 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
59715 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59717 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59721 C...Boost back original partons and mark them as deleted.
59722 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
59723 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
59724 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
59725 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
59731 C...Rotate shower initiating partons to be along z axis.
59732 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
59733 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
59734 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
59735 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
59737 C...Set up copy of shower initiating partons as on mass shell.
59747 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
59758 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
59759 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
59761 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
59763 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
59766 C...Decide whether to allow or not photon radiation in showers.
59767 C...Connect up colours.
59769 IF(IRAD.EQ.0) MSTJ(41)=1
59772 CALL PYJOIN(2,IJOIN)
59774 C...Decide on maximum virtuality and do parton shower.
59775 IF(PMAX.LT.PARJ(82)) THEN
59780 CALL PYSHOW(NSAV+1,-100,PQMAX)
59782 C...Rotate and boost back system.
59783 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
59785 C...Do fragmentation and decays.
59788 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59797 C*********************************************************************
59800 C...Auxiliary to PY4JET, to evaluate weight of configuration.
59802 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
59804 C...Double precision and integer declarations.
59805 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59806 IMPLICIT INTEGER(I-N)
59807 INTEGER PYK,PYCHGE,PYCOMP
59809 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59812 C...First case: when both original partons radiate.
59813 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59816 P(N+1,J)=P(IA1,J)+P(IA2,J)
59817 P(N+2,J)=P(IA3,J)+P(IA4,J)
59819 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59821 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59823 Z1=P(IA1,4)/P(N+1,4)
59824 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
59825 Z2=P(IA3,4)/P(N+2,4)
59826 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
59828 C...Second case: when one original parton radiates to three.
59829 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59832 P(N+2,J)=P(IA3,J)+P(IA4,J)
59833 P(N+1,J)=P(N+2,J)+P(IA2,J)
59835 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59837 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59839 IF(K(IA2,2).EQ.21) THEN
59840 Z1=P(N+2,4)/P(N+1,4)
59841 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59844 Z1=P(IA2,4)/P(N+1,4)
59845 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59848 Z2=P(IA3,4)/P(N+2,4)
59849 IF(K(IA2,2).EQ.21) THEN
59850 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
59852 ELSEIF(K(IA3,2).EQ.21) THEN
59853 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
59855 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
59865 C*********************************************************************
59868 C...Auxiliary to PY4JET, to set up chosen configuration.
59870 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
59872 C...Double precision and integer declarations.
59873 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59874 IMPLICIT INTEGER(I-N)
59875 INTEGER PYK,PYCHGE,PYCOMP
59877 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59889 C...First case: when both original partons radiate.
59890 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59893 C...Set up flavour and history pointers for new partons.
59911 C...Set up momenta for new partons.
59913 P(N+1,J)=P(IA1,J)+P(IA2,J)
59914 P(N+2,J)=P(IA3,J)+P(IA4,J)
59920 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59922 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59924 QMAX=MIN(P(N+1,5),P(N+2,5))
59926 C...Second case: q radiates twice.
59927 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59928 C...IA5=N+2 does not radiate.
59929 ELSEIF(K(IA2,2).EQ.21) THEN
59931 C...Set up flavour and history pointers for new partons.
59949 C...Set up momenta for new partons.
59951 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59953 P(N+3,J)=P(IA3,J)+P(IA4,J)
59958 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59960 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
59964 C...Third case: q radiates g, g branches.
59965 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59966 C...IA5=N+2 does not radiate.
59969 C...Set up flavour and history pointers for new partons.
59987 C...Set up momenta for new partons.
59989 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59992 P(N+4,J)=P(IA3,J)+P(IA4,J)
59996 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59998 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
60008 C*********************************************************************
60011 C...Connects a sequence of partons with colour flow indices,
60012 C...as required for subsequent shower evolution (or other operations).
60014 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60016 C...Double precision and integer declarations.
60017 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60018 IMPLICIT INTEGER(I-N)
60019 INTEGER PYK,PYCHGE,PYCOMP
60021 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60024 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60028 C...Check that partons are of right types to be connected.
60029 IF(NJOIN.LT.2) GOTO 120
60033 IF(I.LE.0.OR.I.GT.N) GOTO 120
60034 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60036 IF(KC.EQ.0) GOTO 120
60037 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60038 IF(KQ.EQ.0) GOTO 120
60039 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60040 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60041 IF(IJN.EQ.1) KQS=KQ
60043 IF(KQSUM.NE.0) GOTO 120
60045 C...Connect the partons sequentially (closing for gluon loop).
60047 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60051 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60052 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60053 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60054 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60055 K(I,KCS)=MSTU(5)*IN
60056 K(I,9-KCS)=MSTU(5)*IP
60057 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60058 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60061 C...Error exit: no action taken.
60063 120 CALL PYERRM(12,
60064 &'(PYJOIN:) given entries can not be joined by one string')
60069 C*********************************************************************
60072 C...Sets values of commonblock variables.
60074 SUBROUTINE PYGIVE(CHIN)
60076 C...Double precision and integer declarations.
60077 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60078 IMPLICIT INTEGER(I-N)
60079 INTEGER PYK,PYCHGE,PYCOMP
60081 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60082 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60083 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60084 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60085 COMMON/PYDAT4/CHAF(500,2)
60087 COMMON/PYDATR/MRPY(6),RRPY(100)
60088 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60089 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60090 COMMON/PYINT1/MINT(400),VINT(400)
60091 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60092 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60093 COMMON/PYINT4/MWID(500),WIDS(500,5)
60094 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60095 COMMON/PYINT6/PROC(0:500)
60097 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60098 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60100 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60101 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60102 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60103 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60104 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60105 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60106 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60107 C...Local arrays and character variables.
60108 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60109 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60111 DIMENSION MSVAR(56,8)
60113 C...For each variable to be translated give: name,
60114 C...integer/real/character, no. of indices, lower&upper index bounds.
60115 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60116 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60117 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60118 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60119 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60120 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60121 &'ITCM','RTCM','IUED','RUED'/
60122 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60123 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60124 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60125 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60126 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60127 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60128 &1,1,1,6,4*0, 2,1,1,100,4*0,
60129 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60130 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60131 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60132 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60133 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60134 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60135 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60136 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60137 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60138 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60139 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60140 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60141 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60143 C...Length of character variable. Subdivide it into instructions.
60144 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60145 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60149 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60152 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60154 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60159 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60161 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60163 C...Send off decay-mode on/off commands to PYONOF.
60166 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60168 IF(IONOF.EQ.1) THEN
60173 C...Peel off any text following exclamation mark.
60175 DO 140 LLOW2=LHIG2,1,-1
60176 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60178 IF(LBIT.EQ.0) RETURN
60180 C...Identify commonblock variable.
60183 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60184 &LNAM.LE.6) GOTO 150
60185 CHNAM=CHBIT(1:LNAM-1)//' '
60186 DO 170 LCOM=1,LNAM-1
60188 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60189 & CHALP(2)(LALP:LALP)
60194 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
60197 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
60199 IF(LLOW.LT.LTOT) GOTO 120
60203 C...Identify any indices.
60208 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
60211 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
60213 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
60214 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
60215 & IVAR.EQ.37)) THEN
60216 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
60217 READ(CHIND,'(I8)') KF
60219 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
60221 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
60224 IF(LLOW.LT.LTOT) GOTO 120
60227 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60228 READ(CHIND,'(I8)') I1
60231 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60234 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60237 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
60239 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60240 READ(CHIND,'(I8)') I2
60242 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60245 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60248 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
60250 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60251 READ(CHIND,'(I8)') I3
60256 C...Check that indices allowed.
60258 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
60259 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
60261 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
60263 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
60265 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
60267 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
60270 IF(LLOW.LT.LTOT) GOTO 120
60274 C...Save old value of variable.
60277 ELSEIF(IVAR.EQ.2) THEN
60279 ELSEIF(IVAR.EQ.3) THEN
60281 ELSEIF(IVAR.EQ.4) THEN
60283 ELSEIF(IVAR.EQ.5) THEN
60285 ELSEIF(IVAR.EQ.6) THEN
60287 ELSEIF(IVAR.EQ.7) THEN
60289 ELSEIF(IVAR.EQ.8) THEN
60291 ELSEIF(IVAR.EQ.9) THEN
60293 ELSEIF(IVAR.EQ.10) THEN
60295 ELSEIF(IVAR.EQ.11) THEN
60297 ELSEIF(IVAR.EQ.12) THEN
60299 ELSEIF(IVAR.EQ.13) THEN
60301 ELSEIF(IVAR.EQ.14) THEN
60303 ELSEIF(IVAR.EQ.15) THEN
60305 ELSEIF(IVAR.EQ.16) THEN
60307 ELSEIF(IVAR.EQ.17) THEN
60308 CHOLD=CHAF(I1,I2)(1:8)
60309 ELSEIF(IVAR.EQ.18) THEN
60311 ELSEIF(IVAR.EQ.19) THEN
60313 ELSEIF(IVAR.EQ.20) THEN
60315 ELSEIF(IVAR.EQ.21) THEN
60317 ELSEIF(IVAR.EQ.22) THEN
60319 ELSEIF(IVAR.EQ.23) THEN
60321 ELSEIF(IVAR.EQ.24) THEN
60323 ELSEIF(IVAR.EQ.25) THEN
60325 ELSEIF(IVAR.EQ.26) THEN
60327 ELSEIF(IVAR.EQ.27) THEN
60329 ELSEIF(IVAR.EQ.28) THEN
60331 ELSEIF(IVAR.EQ.29) THEN
60333 ELSEIF(IVAR.EQ.30) THEN
60335 ELSEIF(IVAR.EQ.31) THEN
60337 ELSEIF(IVAR.EQ.32) THEN
60339 ELSEIF(IVAR.EQ.33) THEN
60340 IOLD=ICOL(I1,I2,I3)
60341 ELSEIF(IVAR.EQ.34) THEN
60343 ELSEIF(IVAR.EQ.35) THEN
60345 ELSEIF(IVAR.EQ.36) THEN
60347 ELSEIF(IVAR.EQ.37) THEN
60349 ELSEIF(IVAR.EQ.38) THEN
60351 ELSEIF(IVAR.EQ.39) THEN
60353 ELSEIF(IVAR.EQ.40) THEN
60355 ELSEIF(IVAR.EQ.41) THEN
60357 ELSEIF(IVAR.EQ.42) THEN
60358 ROLD=SIGT(I1,I2,I3)
60359 ELSEIF(IVAR.EQ.43) THEN
60361 ELSEIF(IVAR.EQ.44) THEN
60363 ELSEIF(IVAR.EQ.45) THEN
60365 ELSEIF(IVAR.EQ.46) THEN
60367 ELSEIF(IVAR.EQ.47) THEN
60369 ELSEIF(IVAR.EQ.48) THEN
60371 ELSEIF(IVAR.EQ.49) THEN
60373 ELSEIF(IVAR.EQ.50) THEN
60374 ROLD=RVLAM(I1,I2,I3)
60375 ELSEIF(IVAR.EQ.51) THEN
60376 ROLD=RVLAMP(I1,I2,I3)
60377 ELSEIF(IVAR.EQ.52) THEN
60378 ROLD=RVLAMB(I1,I2,I3)
60379 ELSEIF(IVAR.EQ.53) THEN
60381 ELSEIF(IVAR.EQ.54) THEN
60383 ELSEIF(IVAR.EQ.55) THEN
60385 ELSEIF(IVAR.EQ.56) THEN
60389 C...Print current value of variable. Loop back.
60390 IF(LNAM.GE.LBIT) THEN
60392 CHBIT(15:60)=' has the value '
60393 IF(MSVAR(IVAR,1).EQ.1) THEN
60394 WRITE(CHBIT(51:60),'(I10)') IOLD
60395 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60396 WRITE(CHBIT(47:60),'(F14.5)') ROLD
60397 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60402 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60404 IF(LLOW.LT.LTOT) GOTO 120
60408 C...Read in new variable value.
60409 IF(MSVAR(IVAR,1).EQ.1) THEN
60411 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
60412 READ(CHINI,'(I10)') INEW
60413 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60415 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
60417 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60418 CHNEW=CHBIT(LNAM+1:LBIT)//' '
60420 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
60423 C...Store new variable value.
60426 ELSEIF(IVAR.EQ.2) THEN
60428 ELSEIF(IVAR.EQ.3) THEN
60430 ELSEIF(IVAR.EQ.4) THEN
60432 ELSEIF(IVAR.EQ.5) THEN
60434 ELSEIF(IVAR.EQ.6) THEN
60436 ELSEIF(IVAR.EQ.7) THEN
60438 ELSEIF(IVAR.EQ.8) THEN
60440 ELSEIF(IVAR.EQ.9) THEN
60442 ELSEIF(IVAR.EQ.10) THEN
60444 ELSEIF(IVAR.EQ.11) THEN
60446 ELSEIF(IVAR.EQ.12) THEN
60448 ELSEIF(IVAR.EQ.13) THEN
60450 ELSEIF(IVAR.EQ.14) THEN
60452 ELSEIF(IVAR.EQ.15) THEN
60454 ELSEIF(IVAR.EQ.16) THEN
60456 ELSEIF(IVAR.EQ.17) THEN
60458 ELSEIF(IVAR.EQ.18) THEN
60460 ELSEIF(IVAR.EQ.19) THEN
60462 ELSEIF(IVAR.EQ.20) THEN
60464 ELSEIF(IVAR.EQ.21) THEN
60466 ELSEIF(IVAR.EQ.22) THEN
60468 ELSEIF(IVAR.EQ.23) THEN
60470 ELSEIF(IVAR.EQ.24) THEN
60472 ELSEIF(IVAR.EQ.25) THEN
60474 ELSEIF(IVAR.EQ.26) THEN
60476 ELSEIF(IVAR.EQ.27) THEN
60478 ELSEIF(IVAR.EQ.28) THEN
60480 ELSEIF(IVAR.EQ.29) THEN
60482 ELSEIF(IVAR.EQ.30) THEN
60484 ELSEIF(IVAR.EQ.31) THEN
60486 ELSEIF(IVAR.EQ.32) THEN
60488 ELSEIF(IVAR.EQ.33) THEN
60489 ICOL(I1,I2,I3)=INEW
60490 ELSEIF(IVAR.EQ.34) THEN
60492 ELSEIF(IVAR.EQ.35) THEN
60494 ELSEIF(IVAR.EQ.36) THEN
60496 ELSEIF(IVAR.EQ.37) THEN
60498 ELSEIF(IVAR.EQ.38) THEN
60500 ELSEIF(IVAR.EQ.39) THEN
60502 ELSEIF(IVAR.EQ.40) THEN
60504 ELSEIF(IVAR.EQ.41) THEN
60506 ELSEIF(IVAR.EQ.42) THEN
60507 SIGT(I1,I2,I3)=RNEW
60508 ELSEIF(IVAR.EQ.43) THEN
60510 ELSEIF(IVAR.EQ.44) THEN
60512 ELSEIF(IVAR.EQ.45) THEN
60514 ELSEIF(IVAR.EQ.46) THEN
60516 ELSEIF(IVAR.EQ.47) THEN
60518 ELSEIF(IVAR.EQ.48) THEN
60520 ELSEIF(IVAR.EQ.49) THEN
60522 ELSEIF(IVAR.EQ.50) THEN
60523 RVLAM(I1,I2,I3)=RNEW
60524 ELSEIF(IVAR.EQ.51) THEN
60525 RVLAMP(I1,I2,I3)=RNEW
60526 ELSEIF(IVAR.EQ.52) THEN
60527 RVLAMB(I1,I2,I3)=RNEW
60528 ELSEIF(IVAR.EQ.53) THEN
60530 ELSEIF(IVAR.EQ.54) THEN
60532 ELSEIF(IVAR.EQ.55) THEN
60534 ELSEIF(IVAR.EQ.56) THEN
60538 C...Write old and new value. Loop back.
60540 CHBIT(15:60)=' changed from to '
60541 IF(MSVAR(IVAR,1).EQ.1) THEN
60542 WRITE(CHBIT(33:42),'(I10)') IOLD
60543 WRITE(CHBIT(51:60),'(I10)') INEW
60544 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60545 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60546 WRITE(CHBIT(29:42),'(F14.5)') ROLD
60547 WRITE(CHBIT(47:60),'(F14.5)') RNEW
60548 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60549 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60552 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60554 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
60555 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
60558 IF(LLOW.LT.LTOT) GOTO 120
60560 C...Format statement for output on unit MSTU(11) (by default 6).
60561 5000 FORMAT(5X,A60)
60562 5100 FORMAT(5X,A88)
60567 C*********************************************************************
60570 C...Switches on and off decay channel by search for match.
60572 SUBROUTINE PYONOF(CHIN)
60574 C...Double precision and integer declarations.
60575 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60576 IMPLICIT INTEGER(I-N)
60577 INTEGER PYK,PYCHGE,PYCOMP
60579 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60580 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60581 SAVE /PYDAT1/,/PYDAT3/
60582 C...Local arrays and character variables.
60583 INTEGER KFCMP(10),KFTMP(10)
60584 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60586 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60587 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60589 C...Determine length of character variable.
60593 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
60596 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
60598 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
60600 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
60602 C...Find colon separator and particle code.
60604 120 LCOLON=LCOLON+1
60605 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
60607 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
60608 READ(CHCODE,'(I8)',ERR=300) KF
60611 C...Done if unknown code or no decay channels.
60613 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
60618 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
60619 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
60623 C...Find command name up to blank or equal sign.
60626 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
60627 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
60629 LMODE=LSEP-LCOLON-1
60630 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
60632 C...Convert to uppercase.
60633 DO 150 LCOM=1,LMODE
60635 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
60636 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
60640 C...Identify command. Failed if not identified.
60642 IF(CHMODE.EQ.'ALLOFF') MODE=1
60643 IF(CHMODE.EQ.'ALLON') MODE=2
60644 IF(CHMODE.EQ.'OFFIFANY') MODE=3
60645 IF(CHMODE.EQ.'ONIFANY') MODE=4
60646 IF(CHMODE.EQ.'OFFIFALL') MODE=5
60647 IF(CHMODE.EQ.'ONIFALL') MODE=6
60648 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
60649 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
60651 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
60655 C...Simple cases when all on or all off.
60656 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
60657 WRITE(MSTU(11),1000) KF,CHMODE
60658 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
60659 IF(MDME(IDC,1).LT.0) GOTO 160
60665 C...Identify matching list.
60669 IF(LBEG.GT.LEN) GOTO 190
60670 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
60671 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
60674 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
60675 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
60676 IF(LEND.LT.LEN) LEND=LEND-1
60678 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
60679 READ(CHCODE,'(I8)',ERR=300) KFREAD
60681 KFCMP(NCMP)=IABS(KFREAD)
60683 IF(NCMP.LT.10) GOTO 170
60685 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
60687 C...Only one matching required.
60688 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
60689 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
60690 IF(MDME(IDC,1).LT.0) GOTO 220
60692 KFNOW=IABS(KFDP(IDC,IKF))
60693 IF(KFNOW.EQ.0) GOTO 210
60695 IF(KFCMP(ICMP).EQ.KFNOW) THEN
60705 C...Multiple matchings required.
60706 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
60707 IF(MDME(IDC,1).LT.0) GOTO 260
60710 KFTMP(ITMP)=KFCMP(ITMP)
60714 KFNOW=IABS(KFDP(IDC,IKF))
60715 IF(KFNOW.EQ.0) GOTO 250
60718 IF(KFTMP(ITMP).EQ.KFNOW) THEN
60719 KFTMP(ITMP)=KFTMP(NTMP)
60725 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
60726 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
60727 & MDME(IDC,1)=MODE-7
60731 C...Error exit for impossible read of particle code.
60732 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
60735 C...Formats for output.
60736 1000 FORMAT(' Decays for',I8,' set ',A10)
60737 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
60741 C*********************************************************************
60744 C...Presets for a few specific underlying-event and min-bias tunes
60745 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60746 C...others require particular versions of pythia (e.g. the SCI and GAL
60747 C...models). See below for details.
60748 SUBROUTINE PYTUNE(ITUNE)
60750 C ITUNE NAME (detailed descriptions below)
60751 C 0 Default : No settings changed => defaults.
60753 C ====== Old UE, Q2-ordered showers ====================================
60754 C 100 A : Rick Field's CDF Tune A (Oct 2002)
60755 C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60756 C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60757 C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60758 C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60759 C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60760 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60761 C 107 ACR : Tune A modified with new CR model (Mar 2007)
60762 C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60763 C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60764 C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60765 C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60766 C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60767 C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60768 C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60769 C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60770 C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60771 C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60772 C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60773 C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60774 C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60775 C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60776 C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60778 C ====== Intermediate and Hybrid Models ================================
60779 C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60780 C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60781 C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60782 C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60783 C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60785 C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60786 C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60787 C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60788 C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60789 C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60790 C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60791 C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60792 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60793 C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60794 C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60795 C 311 S1-Pro : S1 -"- (Oct 2008)
60796 C 312 S2-Pro : S2 -"- (Oct 2008)
60797 C 313 S0A-Pro : S0A -"- (Oct 2008)
60798 C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60799 C 315 Old-Pro : Old -"- (Oct 2008)
60800 C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60801 C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60802 C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60803 C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60804 C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60805 C balance & different scaling to LHC & RHIC (Feb 2009)
60806 C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60807 C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60808 C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60809 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60810 C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60812 C ======= The Uppsala models ===========================================
60813 C ( NB! must be run with special modified Pythia 6.215 version )
60814 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60815 C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60816 C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60817 C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60818 C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60822 C Quick Dictionary:
60823 C BE : Bose-Einstein
60824 C BR : Beam Remnants
60825 C CR : Colour Reconnections
60826 C HAD: Hadronization
60827 C ISR/FSR: Initial-State Radiation / Final-State Radiation
60828 C FSI: Final-State Interactions (=CR+BE)
60829 C MB : Minimum-bias
60830 C MI : Multiple Interactions
60831 C UE : Underlying Event
60833 C=======================================================================
60834 C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60835 C=======================================================================
60837 C A (100) and AW (101). CTEQ5L parton distributions
60838 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60839 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60840 C...Key feature: extensively compared to CDF data (R.D. Field).
60841 C...* Large starting scale for ISR (PARP(67)=4)
60842 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60843 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60845 C BW (102). 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...* Small starting scale for ISR (PARP(67)=1)
60851 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60852 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60854 C DW (103) and DWT (104). CTEQ5L parton distributions
60855 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60856 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60857 C...Key feature: extensively compared to CDF data (R.D. Field).
60858 C...NB: Can also be run with Pythia 6.2 or 6.312+
60859 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60860 C...* DWT has a different reference energy, the same as the "S" models
60861 C... below, leading to more UE activity at the LHC, but less at RHIC.
60862 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60864 C QW (105). CTEQ61 parton distributions
60865 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60866 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60867 C...Key feature: uses CTEQ61 (external pdf library must be linked)
60869 C ATLAS-DC2 (106). CTEQ5L parton distributions
60870 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60871 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60872 C...Key feature: tune used by the ATLAS collaboration.
60874 C ACR (107). CTEQ5L parton distributions
60875 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60876 C...Key feature: Tune A modified to use annealing CR.
60877 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60879 C D6 (108) and D6T (109). CTEQ6L parton distributions
60880 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60882 C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60883 C Old UE model, Q2-ordered showers.
60884 C...Key feature: Rick Field's family of tunes revamped with the
60885 C...Professor Q2-ordered final-state shower and fragmentation tunes
60886 C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60887 C...Key feature: improved descriptions of LEP data.
60889 C Pro-Q20 (129). CTEQ5L parton distributions
60890 C Old UE model, Q2-ordered showers.
60891 C...Key feature: Complete retune of old model by Professor, including
60892 C...large amounts of both LEP and Tevatron data.
60893 C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60894 C...extreme in this tune, corresponding to using mu_R = pT/3 .
60896 C=======================================================================
60897 C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60898 C=======================================================================
60900 C IM1 (200). Intermediate model, Q2-ordered showers,
60901 C CTEQ5L parton distributions
60902 C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60903 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60904 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60906 C APT (201). Old UE model, pT-ordered final-state showers,
60907 C CTEQ5L parton distributions
60908 C...Key feature: Rick Field's Tune A, but with new final-state showers
60910 C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60911 C CTEQ5L parton distributions
60912 C...Key feature: APT revamped with the Professor pT-ordered final-state
60913 C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60914 C...Perugia MPI workshop in October 2008.
60916 C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60917 C CTEQ5L parton distributions
60918 C...Key feature: APT-Pro with final-state showers off the MPI,
60919 C...lower ISR renormalization scale to improve agreement with the
60920 C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60921 C...to min-bias at 630 GeV.
60923 C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60924 C CTEQ6L1 parton distributions.
60925 C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60926 C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60927 C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60929 C=======================================================================
60930 C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60931 C=======================================================================
60933 C S0 (300) and S0A (303). CTEQ5L parton distributions
60934 C...Key feature: large amount of multiple interactions
60935 C...* Somewhat faster than the other colour annealing scenarios.
60936 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60937 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60938 C...* Small amount of radiation.
60939 C...* Large amount of low-pT MI
60940 C...* Low degree of proton lumpiness (broad matter dist.)
60941 C...* CR Type S (driven by free triplets), of medium strength.
60942 C...* See: Pythia6402 update notes or later.
60944 C S1 (301). CTEQ5L parton distributions
60945 C...Key feature: large amount of radiation.
60946 C...* Large amount of low-pT perturbative ISR
60947 C...* Large amount of FSR off ISR partons
60948 C...* Small amount of low-pT multiple interactions
60949 C...* Moderate degree of proton lumpiness
60950 C...* Least aggressive CR type (S+S Type I), but with large strength
60951 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60953 C S2 (302). CTEQ5L parton distributions
60954 C...Key feature: very lumpy proton + gg string cluster formation allowed
60955 C...* Small amount of radiation
60956 C...* Moderate amount of low-pT MI
60957 C...* High degree of proton lumpiness (more spiky matter distribution)
60958 C...* Most aggressive CR type (S+S Type II), but with small strength
60959 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60961 C NOCR (304). CTEQ5L parton distributions
60962 C...Key feature: no colour reconnections (NB: "Best fit" only).
60963 C...* NB: <pT>(Nch) problematic in this tune.
60964 C...* Small amount of radiation
60965 C...* Small amount of low-pT MI
60966 C...* Low degree of proton lumpiness
60967 C...* Large BR composite x enhancement factor
60968 C...* Most clever colour flow without CR ("Lambda ordering")
60970 C ATLAS-CSC (306). CTEQ6L parton distributions
60971 C...Key feature: 11-parameter ATLAS tune of the new framework.
60972 C...* Old (pre-annealing) colour reconnections a la 305.
60973 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60975 C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60976 C...Key feature: the S0 family of tunes revamped with the Professor
60977 C...pT-ordered final-state shower and fragmentation tunes presented by
60978 C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60979 C...Key feature: improved descriptions of LEP data.
60981 C Perugia-0 (320). CTEQ5L parton distributions.
60982 C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60983 C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60984 C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60985 C...beam-remnant breakup (more baryon number transport), and suppression
60986 C...of CR in high-pT string pieces.
60988 C Perugia-HARD (321). CTEQ5L parton distributions.
60989 C...Key feature: More ISR, More FSR, Less MPI, Less BR
60990 C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60991 C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60992 C...baryon number transport), and more fragmentation pT.
60993 C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60994 C...DY pT spectrum is HARD.
60996 C Perugia-SOFT (322). CTEQ5L parton distributions.
60997 C...Key feature: Less ISR, Less FSR, More MPI, More BR
60998 C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60999 C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
61000 C...number transport), and less fragmentation pT.
61001 C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
61002 C...DY pT spectrum is SOFT
61004 C Perugia-3 (323). CTEQ5L parton distributions.
61005 C...Key feature: variant of Perugia-0 with more extreme energy scaling
61006 C...properties while still agreeing with Tevatron data from 630 to 1960.
61007 C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61008 C...allows FSR off the active end of dipoles stretched to the remnant.
61010 C Perugia-NOCR (324). CTEQ5L parton distributions.
61011 C...Key feature: Retune of NOCR-Pro with better scaling properties to
61012 C...lower energies and somewhat better agreement with Tevatron data
61015 C Perugia-* (325). MRST LO* parton distributions for generators
61016 C...Key feature: first attempt at using the LO* distributions
61017 C...(external pdf library must be linked).
61019 C Perugia-6 (326). CTEQ6L1 parton distributions
61020 C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61022 C Pro-pT0 (329). CTEQ5L parton distributions
61023 C...Key feature: Complete retune of new model by Professor, including
61024 C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61026 C=======================================================================
61028 C=======================================================================
61030 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61031 C...with an unmodified Pythia distribution.
61032 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61034 C ::: + Future improvements?
61035 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61036 C (problem: K-factor affects everything so only works as
61037 C intended for min-bias, not for UE ... probably need a
61038 C better long-term solution to handle UE as well. Anyway,
61039 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61041 C...Global statements
61042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61043 INTEGER PYK,PYCHGE,PYCOMP
61046 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61047 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61049 C...SCI and GAL Commonblocks
61050 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61052 C...SAVE statements
61053 SAVE /PYDAT1/,/PYPARS/
61056 C...Internal parameters
61057 PARAMETER(MXTUNS=500)
61058 CHARACTER*8 CHVERS, CHDOC
61059 PARAMETER (CHVERS='1.015 ',CHDOC='Jan 2009')
61060 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61061 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
61062 & CHPARJ(1:100), CH40
61065 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61066 DATA (CHNAMS(I),I=100,119)/
61067 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61068 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61069 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61070 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61071 1 'Tune D6-Pro','Tune D6T-Pro'/
61072 DATA (CHNAMS(I),I=120,129)/
61074 DATA (CHNAMS(I),I=300,309)/
61075 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61076 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61077 DATA (CHNAMS(I),I=310,315)/
61078 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61079 & 'NOCR-Pro','Old-Pro'/
61080 DATA (CHNAMS(I),I=320,329)/
61081 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61082 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61083 & 'Perugia 6',2*' ','Pro-pT0'/
61084 DATA (CHNAMS(I),I=200,229)/
61085 & 'IM Tune 1','Tune APT',8*' ',
61086 & ' ','Tune APT-Pro',8*' ',
61087 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61088 DATA (CHNAMS(I),I=400,409)/
61089 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61090 DATA (CHMSTJ(I),I=11,20)/
61091 & 'HAD choice of fragmentation function(s)',4*' ',
61092 & 'HAD treatment of small-mass systems',4*' '/
61093 DATA (CHMSTJ(I),I=41,50)/
61094 & 'FSR type (Q2 or pT) for old framework',9*' '/
61095 DATA (CHMSTP(I),I=51,100)/
61096 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
61097 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
61098 6 'ISR coherence option for 1st emission',
61099 6 'ISR phase space choice & ME corrections',' ',
61100 7 'ISR IR regularization scheme',' ',
61101 7 'ISR scheme for FSR off ISR',8*' ',
61103 8 'UE hadron transverse mass distribution',5*' ',
61104 8 'BR composite scheme','BR colour scheme',
61105 9 'BR primordial kT compensation',
61106 9 'BR primordial kT distribution',
61107 9 'BR energy partitioning scheme',2*' ',
61108 9 'FSI colour (re-)connection model',5*' '/
61109 DATA (CHPARP(I),I=61,100)/
61110 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
61111 6 2*' ','ISR Q2max factor',3*' ',
61112 7 'FSR Q2max factor for non-s-channel procs',5*' ',
61113 7 'FSI colour reco high-pT dampening strength',
61114 7 'FSI colour reconnection strength',
61115 7 'BR composite x enhancement','BR breakup suppression',
61116 8 2*'UE IR cutoff at reference ecm',
61117 8 2*'UE mass distribution parameter',
61118 8 'UE gg colour correlated fraction','UE total gg fraction',
61120 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61121 9 'BR primordial kT width <|kT|>',' ',
61122 9 'BR primordial kT UV cutoff',7*' '/
61123 DATA (CHPARJ(I),I=1,30)/
61124 & 'HAD diquark suppression','HAD strangeness suppression',
61125 & 'HAD strange diquark suppression',
61126 & 'HAD vector diquark suppression',6*' ',
61127 1 'HAD P(vector meson), u and d only',
61128 1 'HAD P(vector meson), contains s',
61129 1 'HAD P(vector meson), heavy quarks',7*' ',
61130 2 'HAD fragmentation pT',' ',' ',' ',
61131 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61132 DATA (CHPARJ(I),I=41,90)/
61133 4 'HAD string parameter a','HAD string parameter b',3*' ',
61134 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61135 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61136 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61138 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61140 C...1) Shorthand notation
61143 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
61144 CHNAME=CHNAMS(ITUNE)
61145 IF (ITUNE.EQ.0) GOTO 9999
61147 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
61152 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
61154 C...3) Tune parameters
61156 C=======================================================================
61157 C...S0, S1, S2, S0A, NOCR, Rap,
61158 C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61159 C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61161 IF ((ITUNE.GE.300.AND.ITUNE.LE.305)
61162 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
61163 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.326).OR.ITUNE.EQ.329) THEN
61164 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61165 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61166 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61168 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326.AND.ITUNE.NE.324.AND.
61169 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
61171 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61175 C...Use Professor's LEP pars if ITUNE >= 310
61176 C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61177 IF (ITUNE.LT.310) THEN
61180 C...# Old default flavour parameters
61187 ELSEIF (ITUNE.GE.310) THEN
61188 C...# Tuned flavour parameters:
61198 C...# Always use pT-ordered shower:
61200 C...# Switch on Bowler:
61202 C...# Fragmentation
61211 C...Remove middle digit now for Professor variants, since identical pars
61213 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
61214 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61217 C...PDFs: all use CTEQ5L as starting point
61220 IF (ITUNE.EQ.325) THEN
61221 C...MRST LO* for 325
61224 ELSEIF (ITUNE.EQ.326) THEN
61225 C...CTEQ6L1 for 326
61230 C...ISR: use Lambda_MSbar with default scale for S0(A)
61233 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.
61234 & ITUNE.EQ.326) THEN
61235 C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61238 ELSEIF (ITUNE.EQ.321) THEN
61239 C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61242 ELSEIF (ITUNE.EQ.322) THEN
61243 C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61246 ELSEIF (ITUNE.EQ.325) THEN
61247 C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61250 ELSEIF (ITUNE.EQ.329) THEN
61251 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61256 C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61259 C...Perugia tunes have stronger suppression, except HARD
61260 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61262 IF (ITUNE.EQ.321) PARP(67)=4D0
61263 IF (ITUNE.EQ.322) PARP(67)=0.5D0
61266 C...ISR IR cutoff type and FSR off ISR setting:
61267 C...Smooth ISR, low FSR-off-ISR
61270 IF (ITUNEB.EQ.301) THEN
61271 C...S1, S1-Pro: sharp ISR, high FSR
61274 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
61275 & .OR.ITUNE.EQ.325) THEN
61276 C...Perugia default is smooth ISR, high FSR-off-ISR
61279 ELSEIF (ITUNE.EQ.321) THEN
61280 C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61284 ELSEIF (ITUNE.EQ.322) THEN
61285 C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61289 ELSEIF (ITUNE.EQ.323) THEN
61290 C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61296 C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61297 C...by Professor tunes (with HARD and SOFT variations)
61299 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61301 IF (ITUNE.EQ.321) PARP(71)=4D0
61302 IF (ITUNE.EQ.322) PARP(71)=1D0
61304 IF (ITUNE.EQ.329) PARP(71)=2D0
61306 C...FSR: Lambda_FSR scale (only if not using professor)
61307 IF (ITUNE.LT.310) PARJ(81)=0.23D0
61308 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
61309 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
61311 C...UE on, new model
61314 C...UE: hadron-hadron overlap profile (expOfPow for all)
61316 C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61318 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
61319 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
61320 C...NOCR variants have very smooth distributions
61321 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
61322 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
61323 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61324 C...Perugia variants have slightly smoother profiles by default
61325 C...(to compensate for more tail by added radiation)
61326 C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61328 IF (ITUNE.EQ.322) PARP(83)=1.5D0
61329 IF (ITUNE.EQ.324) PARP(83)=1.8D0
61331 C...Professor-pT0 also has very smooth distribution
61332 IF (ITUNE.EQ.329) PARP(83)=1.8
61334 C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61336 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
61337 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
61338 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
61339 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
61340 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61341 C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61342 C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61343 C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61344 C...slightly higher, due to increased activity.
61346 IF (ITUNE.EQ.321) PARP(82)=2.3D0
61347 IF (ITUNE.EQ.322) PARP(82)=1.9D0
61348 IF (ITUNE.EQ.323) PARP(82)=2.2D0
61349 IF (ITUNE.EQ.324) PARP(82)=1.95D0
61350 IF (ITUNE.EQ.325) PARP(82)=2.2D0
61351 IF (ITUNE.EQ.326) PARP(82)=1.95D0
61353 C...Professor-pT0 maintains low pT0 vaue
61354 IF (ITUNE.EQ.329) PARP(82)=1.85D0
61356 C...UE: IR cutoff reference energy and default energy scaling pace
61359 C...S0A, S0A-Pro have tune A energy scaling
61360 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
61361 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61362 C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61364 IF (ITUNE.EQ.321) PARP(90)=0.30D0
61365 IF (ITUNE.EQ.322) PARP(90)=0.24D0
61366 IF (ITUNE.EQ.323) PARP(90)=0.32D0
61367 IF (ITUNE.EQ.324) PARP(90)=0.24D0
61368 C...LO* and CTEQ6L1 tunes have slower energy scaling
61369 IF (ITUNE.EQ.325) PARP(90)=0.23D0
61370 IF (ITUNE.EQ.326) PARP(90)=0.22D0
61372 C...Professor-pT0 has intermediate scaling
61373 IF (ITUNE.EQ.329) PARP(90)=0.22D0
61375 C...BR: MPI initiator color connections rap-ordered by default
61376 C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61378 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
61379 IF (ITUNE.EQ.322) MSTP(89)=0
61381 C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61383 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61384 C...Perugia tunes have more beam blowup by default
61386 IF (ITUNE.EQ.321) PARP(80)=0.01
61387 IF (ITUNE.EQ.323) PARP(80)=0.03
61388 IF (ITUNE.EQ.324) PARP(80)=0.01
61391 C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61394 IF (ITUNEB.EQ.304) PARP(79)=3D0
61395 IF (ITUNE.EQ.329) PARP(79)=1.18
61397 C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61401 C...Perugia-HARD only uses 1.0 GeV
61402 IF (ITUNE.EQ.321) PARP(91)=1.0D0
61403 C...Perugia-3 only uses 1.5 GeV
61404 IF (ITUNE.EQ.323) PARP(91)=1.5D0
61405 C...Professor-pT0 uses 7-GeV cutoff
61406 IF (ITUNE.EQ.329) PARP(93)=7.0
61408 C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61410 C...S1, S1-Pro: use S1
61411 IF (ITUNEB.EQ.301) MSTP(95)=2
61412 C...S2, S2-Pro: use S2
61413 IF (ITUNEB.EQ.302) MSTP(95)=4
61414 C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61415 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324) MSTP(95)=0
61416 C..."Old" and "Old"-Pro: use old CR
61417 IF (ITUNEB.EQ.305) MSTP(95)=1
61419 C...FSI: CR strength and high-pT dampening, default is S0
61420 IF (ITUNE.LT.320.OR.ITUNE.EQ.329) THEN
61423 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
61424 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
61425 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
61426 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
61427 IF (ITUNE.EQ.329) PARP(78)=0.17D0
61429 C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61432 IF (ITUNE.EQ.321) THEN
61433 C...HARD has HIGH amount of CR
61436 ELSEIF (ITUNE.EQ.322) THEN
61437 C...SOFT has LOW amount of CR
61440 ELSEIF (ITUNE.EQ.323) THEN
61441 C...Scaling variant appears to need slightly more than default
61444 ELSEIF (ITUNE.EQ.324) THEN
61451 C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61452 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
61453 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
61455 C...Switch off trial joinings
61458 C...S0 (300), S0A (303)
61459 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
61461 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61462 WRITE(M11,5030) CH60
61463 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61464 WRITE(M11,5030) CH60
61465 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61466 WRITE(M11,5030) CH60
61467 IF (ITUNE.GE.310) THEN
61468 CH60='LEP parameters tuned by Professor'
61469 WRITE(M11,5030) CH60
61474 ELSEIF(ITUNEB.EQ.301) THEN
61476 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61477 WRITE(M11,5030) CH60
61478 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61479 WRITE(M11,5030) CH60
61480 IF (ITUNE.GE.310) THEN
61481 CH60='LEP parameters tuned with Professor'
61482 WRITE(M11,5030) CH60
61487 ELSEIF(ITUNEB.EQ.302) THEN
61489 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61490 WRITE(M11,5030) CH60
61491 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61492 WRITE(M11,5030) CH60
61493 IF (ITUNE.GE.310) THEN
61494 CH60='LEP parameters tuned by Professor'
61495 WRITE(M11,5030) CH60
61500 ELSEIF(ITUNEB.EQ.304) THEN
61502 CH60='"best try" without colour reconnections'
61503 WRITE(M11,5030) CH60
61504 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61505 WRITE(M11,5030) CH60
61506 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61507 WRITE(M11,5030) CH60
61508 IF (ITUNE.GE.310) THEN
61509 CH60='LEP parameters tuned by Professor'
61510 WRITE(M11,5030) CH60
61514 C..."Lo FSR" retune (305)
61515 ELSEIF(ITUNEB.EQ.305) THEN
61517 CH60='"Lo FSR retune" with primitive colour reconnections'
61518 WRITE(M11,5030) CH60
61519 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61520 WRITE(M11,5030) CH60
61521 IF (ITUNE.GE.310) THEN
61522 CH60='LEP parameters tuned by Professor'
61523 WRITE(M11,5030) CH60
61527 C...Perugia Tunes (320-326)
61528 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61530 CH60='P. Skands, Perugia MPI workshop October 2008'
61531 WRITE(M11,5030) CH60
61532 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61533 WRITE(M11,5030) CH60
61534 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61535 WRITE(M11,5030) CH60
61536 CH60='LEP parameters tuned by Professor'
61537 WRITE(M11,5030) CH60
61538 IF (ITUNE.EQ.325) THEN
61539 CH70='NB! This tune requires MRST LO* pdfs to be '//
61540 & 'externally linked'
61541 WRITE(M11,5035) CH70
61542 ELSEIF (ITUNE.EQ.326) THEN
61543 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
61544 & 'externally linked'
61545 WRITE(M11,5035) CH70
61546 ELSEIF (ITUNE.EQ.321) THEN
61547 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61548 WRITE(M11,5030) CH60
61549 ELSEIF (ITUNE.EQ.322) THEN
61550 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61551 WRITE(M11,5030) CH60
61555 C...Professor-pT0 (329)
61556 ELSEIF(ITUNE.EQ.329) THEN
61558 CH60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61559 WRITE(M11,5030) CH60
61560 CH60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61561 WRITE(M11,5030) CH60
61562 CH60='LEP/Tevatron parameters tuned by Professor'
61563 WRITE(M11,5030) CH60
61570 WRITE(M11,5030) ' '
61571 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61572 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61573 IF (MSTP(70).EQ.0) THEN
61574 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
61575 ELSEIF (MSTP(70).EQ.1) THEN
61576 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
61577 CH60='(Note: PARP(81) replaces PARP(62).)'
61578 WRITE(M11,5030) CH60
61580 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
61581 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61582 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
61583 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
61584 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61585 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61586 WRITE(M11,5030) CH60
61587 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61588 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61589 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61590 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61591 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
61592 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61593 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61594 IF (MSTP(70).EQ.2) THEN
61595 CH60='(Note: PARP(82) replaces PARP(62).)'
61596 WRITE(M11,5030) CH60
61598 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61599 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61600 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61601 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61602 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61603 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61604 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61605 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61606 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
61607 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
61608 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61609 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61610 IF (MSTP(95).GE.1) THEN
61611 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61612 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
61614 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61615 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61616 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61617 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61618 IF (MSTJ(11).LE.3) THEN
61619 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61620 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61622 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61624 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61627 C=======================================================================
61628 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61629 ELSEIF (ITUNE.EQ.306) THEN
61630 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61631 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61632 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61643 C...UE on, new model.
61648 C...Switch off trial joinings
61650 C...Primordial kT cutoff
61653 CH60='see presentations by A. Moraes (ATLAS),'
61654 WRITE(M11,5030) CH60
61655 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61656 WRITE(M11,5030) CH60
61657 WRITE(M11,5030) ' '
61658 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61659 & 'externally linked'
61660 WRITE(M11,5035) CH70
61662 C...Smooth ISR, low FSR
61667 C...Transverse density profile.
61671 C...ISR & FSR in interactions after the first (default)
61674 C...No double-counting (default)
61676 C...Companion quark parent gluon (1-x) power
61678 C...Primordial kT compensation along chaings (default = 0 : uniform)
61680 C...Colour Reconnections
61683 C...Lambda_FSR scale.
61685 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61690 C...Peterson charm frag, and c and b hadr parameters
61696 WRITE(M11,5030) ' '
61697 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61698 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61699 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61700 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61701 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61702 WRITE(M11,5030) CH60
61703 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61704 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61705 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61706 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61707 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
61708 WRITE(M11,5030) CH60
61709 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61710 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61711 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61712 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61713 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61714 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61715 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
61716 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61717 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61718 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
61719 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61720 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61721 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61722 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61723 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61724 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61725 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61726 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61727 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61728 IF (MSTJ(11).LE.3) THEN
61729 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61730 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61732 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61734 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61737 C=======================================================================
61738 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61739 C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61740 C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61741 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
61742 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
61743 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
61744 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
61745 WRITE(M11,5010) ITUNE, CHNAME
61746 CH60='see R.D. Field, in hep-ph/0610012'
61747 WRITE(M11,5030) CH60
61748 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61749 WRITE(M11,5030) CH60
61750 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61751 CH60='LEP parameters tuned by Professor'
61752 WRITE(M11,5030) CH60
61754 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
61755 WRITE(M11,5010) ITUNE, CHNAME
61756 CH60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61757 WRITE(M11,5030) CH60
61758 CH60='LEP/Tevatron parameters tuned by Professor'
61759 WRITE(M11,5030) CH60
61762 C...Make sure we start from old default fragmentation parameters
61766 C...Use Professor's LEP pars if ITUNE >= 110
61767 C...(i.e., for A-Pro, DW-Pro etc)
61768 IF (ITUNE.LT.110) THEN
61771 C...# Old default flavour parameters
61778 C...# Tuned flavour parameters:
61788 C...# Switch on Bowler:
61790 C...# Fragmentation
61799 C...Remove middle digit now for Professor variants, since identical pars
61801 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61802 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61805 C...Multiple interactions on, old framework
61807 C...Fast IR cutoff energy scaling by default
61810 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61813 IF (ITUNEB.EQ.105) THEN
61816 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61822 C...Double Gaussian matter distribution.
61828 C...Fragmentation functions and c and b parameters
61829 C...(only if not using Professor)
61830 IF (ITUNE.LE.109) THEN
61837 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
61840 c...String drawing almost completely minimizes string length.
61843 C...ISR cutoff, muR scale factor, and phase space size
61847 C...Intrinsic kT, size, and max
61851 C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61852 IF (ITUNEB.EQ.101) THEN
61859 C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61860 ELSEIF (ITUNEB.EQ.102) THEN
61863 c...String drawing completely minimizes string length.
61866 C...ISR cutoff, muR scale factor, and phase space size
61870 C...Intrinsic kT, size, and max
61876 ELSEIF (ITUNEB.EQ.103) THEN
61879 c...String drawing completely minimizes string length.
61882 C...ISR cutoff, muR scale factor, and phase space size
61886 C...Intrinsic kT, size, and max
61892 ELSEIF (ITUNEB.EQ.104) THEN
61895 C...Run II ref scale and slow scaling
61898 c...String drawing completely minimizes string length.
61901 C...ISR cutoff, muR scale factor, and phase space size
61905 C...Intrinsic kT, size, and max
61911 ELSEIF(ITUNEB.EQ.105) THEN
61913 WRITE(M11,5030) ' '
61914 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61915 & 'externally linked'
61916 WRITE(M11,5035) CH70
61920 c...String drawing completely minimizes string length.
61923 C...ISR cutoff, muR scale factor, and phase space size
61927 C...Intrinsic kT, size, and max
61932 C...Tune D6 and D6T
61933 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61935 WRITE(M11,5030) ' '
61936 CH70='NB! This tune requires CTEQ6L pdfs to be '//
61937 & 'externally linked'
61938 WRITE(M11,5035) CH70
61940 C...The "Rick" proton, double gauss with 0.5/0.4
61944 c...String drawing completely minimizes string length.
61947 IF (ITUNEB.EQ.108) THEN
61948 C...D6: pT0, Run I ref scale, and fast energy scaling
61953 C...D6T: pT0, Run II ref scale, and slow energy scaling
61958 C...ISR cutoff, muR scale factor, and phase space size
61962 C...Intrinsic kT, size, and max
61967 C...Old ATLAS-DC2 5-parameter tune
61968 ELSEIF(ITUNEB.EQ.106) THEN
61970 WRITE(M11,5010) ITUNE, CHNAME
61971 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
61972 WRITE(M11,5030) CH60
61973 CH60=' R. Field in hep-ph/0610012,'
61974 WRITE(M11,5030) CH60
61975 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61976 WRITE(M11,5030) CH60
61980 C... Different ref and rescaling pacee
61983 C... Parameters of mass distribution
61986 C... Old default string drawing
61989 C... ISR, phase space equivalent to Tune B
62000 C...Professor's Pro-Q20 Tune
62001 ELSEIF(ITUNE.EQ.129) THEN
62003 CH60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
62004 WRITE(M11,5030) CH60
62024 WRITE(M11,5030) ' '
62025 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62026 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62027 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62028 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62029 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62030 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62031 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62032 WRITE(M11,5030) CH60
62033 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62034 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62035 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62036 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62037 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62038 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62039 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62040 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62041 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62042 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62043 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62044 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62045 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62046 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62047 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62048 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62049 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62050 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62051 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62052 IF (MSTJ(11).LE.3) THEN
62053 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62054 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62056 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62058 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62061 C=======================================================================
62062 C... ACR, tune A with new CR (107)
62063 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
62065 WRITE(M11,5010) ITUNE, CHNAME
62066 CH60='Tune A modified with new colour reconnections'
62067 WRITE(M11,5030) CH60
62068 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
62069 WRITE(M11,5030) CH60
62070 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
62071 WRITE(M11,5030) CH60
62072 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
62073 WRITE(M11,5030) CH60
62074 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62075 WRITE(M11,5030) CH60
62076 IF (ITUNE.EQ.117) THEN
62077 CH60='LEP parameters tuned by Professor'
62078 WRITE(M11,5030) CH60
62081 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
62082 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62083 & ' with tune. Using defaults.')
62087 C...Make sure we start from old default fragmentation parameters
62091 C...Use Professor's LEP pars if ITUNE >= 110
62092 C...(i.e., for A-Pro, DW-Pro etc)
62093 IF (ITUNE.LT.110) THEN
62096 C...# Old default flavour parameters
62103 C...# Tuned flavour parameters:
62113 C...# Switch on Bowler:
62115 C...# Fragmentation
62143 C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62145 C...Frag functions (only if not using Professor)
62146 IF (ITUNE.LE.109) THEN
62154 WRITE(M11,5030) ' '
62155 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62156 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62157 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62158 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62159 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62160 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62161 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62162 WRITE(M11,5030) CH60
62163 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62164 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62165 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62166 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62167 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62168 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62169 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62170 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62171 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62172 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62173 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62174 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62175 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62176 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62177 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62178 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62179 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62180 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62181 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62182 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62183 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62184 IF (MSTJ(11).LE.3) THEN
62185 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62186 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62188 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62190 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62193 C=======================================================================
62194 C...Intermediate model. Rap tune
62195 C...(retuned to post-6.406 IR factorization)
62196 ELSEIF(ITUNE.EQ.200) THEN
62198 WRITE(M11,5010) ITUNE, CHNAME
62199 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62200 WRITE(M11,5030) CH60
62202 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62203 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62221 C... ExpOfPow(1.8) overlap profile
62228 C... Default diquark, BR-g-BR supp
62231 C... Final state reconnect.
62234 C...Fragmentation functions and c and b parameters
62240 WRITE(M11,5030) ' '
62241 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62242 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62243 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62244 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62245 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62246 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62247 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62248 WRITE(M11,5030) CH60
62249 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62250 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62251 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62252 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62253 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62254 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62255 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62256 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62257 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62258 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62259 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62260 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62261 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62262 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62263 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62264 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62265 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62266 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62267 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62268 IF (MSTJ(11).LE.3) THEN
62269 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62270 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62272 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62274 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62277 C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62278 C...Old model for ISR and UE, new pT-ordered model for FSR
62279 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
62280 & .ITUNE.EQ.226) THEN
62282 WRITE(M11,5010) ITUNE, CHNAME
62283 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62284 WRITE(M11,5030) CH60
62285 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62286 WRITE(M11,5030) CH60
62287 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62288 WRITE(M11,5030) CH60
62289 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62290 WRITE(M11,5030) CH60
62291 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
62292 CH60='LEP parameters tuned by Professor'
62293 WRITE(M11,5030) CH60
62296 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
62297 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62300 C...First set as if Pythia tune A
62301 C...Multiple interactions on, old framework
62303 C...Fast IR cutoff energy scaling by default
62306 C...Default CTEQ5L (internal)
62309 C...Double Gaussian matter distribution.
62315 c...String drawing almost completely minimizes string length.
62318 C...ISR cutoff, muR scale factor, and phase space size
62322 C...Intrinsic kT, size, and max
62326 C...Use 2 GeV of primordial kT for "Perugia" version
62327 IF (ITUNE.EQ.221) THEN
62331 C...Use pT-ordered FSR
62333 C...Lambda_FSR scale for pT-ordering
62335 C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62337 C...Fragmentation functions and c and b parameters
62338 C...(overwritten for 211, i.e., if using Professor pars)
62342 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62343 IF (ITUNE.LT.210) THEN
62346 C...# Old default flavour parameters
62353 C...# Tuned flavour parameters:
62363 C...# Always use pT-ordered shower:
62365 C...# Switch on Bowler:
62367 C...# Fragmentation
62368 PARJ(21) = 3.1327e-01
62369 PARJ(41) = 4.8989e-01
62370 PARJ(42) = 1.2018e+00
62371 PARJ(47) = 1.0000e+00
62372 PARJ(81) = 2.5696e-01
62373 PARJ(82) = 8.0000e-01
62376 C...221, 226 : Perugia-APT and Perugia-APT6
62377 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
62383 C...The Perugia variants use Steve's showers off the old MPI
62385 C...And use a lower PARP(71) as suggested by Professor tunings
62386 C...(although not certain that applies to Q2-pT2 hybrid)
62389 C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62390 IF (ITUNE.EQ.226) THEN
62391 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
62392 & 'externally linked'
62393 WRITE(M11,5035) CH70
62403 WRITE(M11,5030) ' '
62404 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62405 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62406 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62407 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62408 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62409 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62410 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62411 WRITE(M11,5030) CH60
62412 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
62413 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62414 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62415 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62416 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62417 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62418 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62419 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62420 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62421 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62422 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62423 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62424 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62425 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62426 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62427 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62428 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62429 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62430 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62431 IF (MSTJ(11).LE.3) THEN
62432 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62433 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62435 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62437 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62440 C======================================================================
62441 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62442 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
62444 WRITE(M11,5010) ITUNE, CHNAME
62445 CH60='see J. Rathsman, PLB452(1999)364'
62446 WRITE(M11,5030) CH60
62447 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62448 C ? WRITE(M11,5030)
62449 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62450 WRITE(M11,5030) CH60
62451 WRITE(M11,5030) ' '
62452 CH70='NB! The GAL model must be run with modified '//
62454 WRITE(M11,5035) CH70
62455 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62456 WRITE(M11,5035) CH70
62457 WRITE(M11,5030) ' '
62459 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62472 IF(CHNAME.EQ.'GAL Tune 1') THEN
62473 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62479 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62480 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62481 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62482 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62483 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62487 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62488 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62489 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62494 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62495 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62496 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62497 CH40='FSI SCI/GAL selection'
62498 WRITE(M11,6040) 1, MSWI(1), CH40
62499 CH40='FSI SCI/GAL sea quark treatment'
62500 WRITE(M11,6040) 2, MSWI(2), CH40
62501 CH40='FSI SCI/GAL sea quark treatment parm'
62502 WRITE(M11,6050) 1, PARSCI(1), CH40
62503 CH40='FSI SCI/GAL string reco probability R_0'
62504 WRITE(M11,6050) 2, PARSCI(2), CH40
62505 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62506 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62508 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
62510 WRITE(M11,5010) ITUNE, CHNAME
62511 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62512 WRITE(M11,5030) CH60
62513 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62514 WRITE(M11,5030) CH60
62515 WRITE(M11,5030) ' '
62516 CH70='NB! The SCI model must be run with modified '//
62518 WRITE(M11,5035) CH70
62519 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62520 WRITE(M11,5035) CH70
62521 WRITE(M11,5030) ' '
62523 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62533 IF (CHNAME.EQ.'SCI Tune 1') THEN
62534 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62542 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62543 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62544 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62545 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62546 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62550 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62551 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62552 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62557 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62558 CH40='FSI SCI/GAL selection'
62559 WRITE(M11,6040) 1, MSWI(1), CH40
62560 CH40='FSI SCI/GAL sea quark treatment'
62561 WRITE(M11,6040) 2, MSWI(2), CH40
62562 CH40='FSI SCI/GAL sea quark treatment parm'
62563 WRITE(M11,6050) 1, PARSCI(1), CH40
62564 CH40='FSI SCI/GAL string reco probability R_0'
62565 WRITE(M11,6050) 2, PARSCI(2), CH40
62566 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62570 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
62574 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
62578 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
62579 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62580 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
62581 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
62582 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
62583 5030 FORMAT(' *',3x,10x,A60,3x,'*')
62584 5035 FORMAT(' *',3x,A70,3x,'*')
62585 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
62586 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
62587 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
62588 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
62589 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
62590 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
62591 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62592 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
62593 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
62597 C*********************************************************************
62600 C...Administrates the fragmentation and decay chain.
62604 C...Double precision and integer declarations.
62605 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62606 IMPLICIT INTEGER(I-N)
62607 INTEGER PYK,PYCHGE,PYCOMP
62609 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62610 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62611 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62612 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62613 COMMON/PYINT1/MINT(400),VINT(400)
62614 COMMON/PYINT4/MWID(500),WIDS(500,5)
62615 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
62617 DIMENSION PS(2,6),IJOIN(100)
62619 C...Initialize and reset.
62621 IF(MSTU(12).NE.12345) CALL PYLIST(0)
62623 MSTU(31)=MSTU(31)+1
62627 IF(MSTU(17).LE.0) MSTU(90)=0
62630 C...Sum up momentum, energy and charge for starting entries.
62638 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
62640 PS(1,J)=PS(1,J)+P(I,J)
62642 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
62646 C...Start by all decays of coloured resonances involved in shower.
62649 IF(K(I,1).EQ.3) THEN
62651 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
62655 C...Prepare system for subsequent fragmentation/decay.
62657 IF(MINT(51).NE.0) RETURN
62659 C...Loop through jet fragmentation and particle decays.
62665 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
62668 C...Deal with any remaining undecayed resonance
62669 C...(normally the task of PYEVNT, so seldom used).
62670 ELSEIF(MWID(KC).NE.0) THEN
62672 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
62675 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
62676 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
62679 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
62680 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
62683 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
62691 IF(MINT(51).NE.0) RETURN
62693 C...Particle decay if unstable and allowed. Save long-lived particle
62694 C...decays until second pass after Bose-Einstein effects.
62695 ELSEIF(KCHG(KC,2).EQ.0) THEN
62696 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
62697 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
62700 C...Decay products may develop a shower.
62701 IF(MSTJ(92).GT.0) THEN
62703 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
62704 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
62706 CALL PYSHOW(IP1,IP1+1,QMAX)
62708 IF(MINT(51).NE.0) RETURN
62710 ELSEIF(MSTJ(92).LT.0) THEN
62713 CALL PYSHOW(IP1,-3,P(IP,5))
62715 IF(MINT(51).NE.0) RETURN
62719 C...Jet fragmentation: string or independent fragmentation.
62720 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
62722 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
62723 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
62724 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
62725 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
62726 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
62729 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
62730 IF(MFRAG.EQ.2) CALL PYINDF(IP)
62731 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
62732 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
62735 C...Loop back if enough space left in PYJETS and no error abort.
62736 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
62737 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
62739 ELSEIF(IP.LT.N) THEN
62740 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
62743 C...Include simple Bose-Einstein effect parametrization if desired.
62744 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
62749 C...Check that momentum, energy and charge were conserved.
62751 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
62753 PS(2,J)=PS(2,J)+P(I,J)
62755 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
62757 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
62758 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
62759 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
62760 &'(PYEXEC:) four-momentum was not conserved')
62761 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
62762 &'(PYEXEC:) charge was not conserved')
62767 C*********************************************************************
62770 C...Rearranges partons along strings.
62771 C...Special considerations for systems with junctions, with
62772 C...possibility of junction-antijunction annihilation.
62773 C...Allows small systems to collapse into one or two particles.
62774 C...Checks flavours and colour singlet invariant masses.
62776 SUBROUTINE PYPREP(IP)
62778 C...Double precision and integer declarations.
62779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62780 INTEGER PYK,PYCHGE,PYCOMP
62782 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62783 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62784 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
62785 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62786 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62787 COMMON/PYINT1/MINT(400),VINT(400)
62788 C...The common block of colour tags.
62789 COMMON/PYCTAG/NCT,MCT(4000,2)
62790 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
62795 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
62796 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
62797 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
62798 &IJCP(0:6),TJUOLD(5)
62801 C...Function to give four-product.
62802 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)
62804 C...Rearrange parton shower product listing along strings: begin loop.
62812 DO 100 I=MAX(1,IP),N
62813 C...First store junction positions.
62814 IF(K(I,1).EQ.42) THEN
62822 DO 240 I=MAX(1,IP),N
62823 C...Special treatment for junctions
62824 IF (K(I,1).LE.0) GOTO 240
62825 IF(K(I,1).EQ.42) THEN
62826 C...MQGST=2: Look for junction-junction strings (not detected in the
62827 C...main search below).
62828 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
62829 IF (NJJSTR.EQ.0) THEN
62830 NJJSTR = (3*NJUNC-NPIECE)/2
62832 C...Check how many already identified strings end on this junction
62835 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
62837 C...If less than 3, remaining must be to another junction
62840 C...Multiple j-j connections not handled yet.
62842 & '(PYPREP:) Too many junction-junction strings.')
62846 C...The colour information in the junction is unreadable for the
62847 C...colour space search further down in this routine, so we must
62848 C...start on the colour mother of this junction and then "artificially"
62849 C...prevent the colour mother from connecting here again.
62850 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
62852 IF (MOD(ITJUNC,2).EQ.0) KCS=5
62853 C...Switch colour if the junction-junction leg is presumably a
62854 C...junction mother leg rather than a junction daughter leg.
62855 IF (ITJUNC.GE.3) KCS=9-KCS
62856 IF (MINT(33).EQ.0) THEN
62857 C...Find the unconnected leg and reorder junction daughter pointers so
62858 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62860 IA=MOD(K(I,4),MSTU(5))
62861 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
62862 ITMP=MOD(K(I,5),MSTU(5))
62863 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
62864 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
62865 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
62867 K(I,5)=K(I,5)+(IA-ITMP)
62869 K(I,4)=K(I,4)+(ITMP-IA)
62872 IF (ITJUNC.LE.2) THEN
62873 C...Beam baryon junction
62874 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
62875 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
62876 C...Else 1 -> 2 decay junction
62878 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
62879 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
62884 C...Alternatively use colour tag information.
62886 C...Find a final state parton with appropriate dangling colour tag.
62890 DO 140 J1=MAX(1,IP),N
62891 IF (K(J1,1).NE.3) GOTO 140
62892 C...Check for matching final-state colour tag
62894 DO 120 J2=MAX(1,IP),N
62895 IF (K(J2,1).NE.3) GOTO 120
62896 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
62898 IF (IMATCH.EQ.1) GOTO 140
62899 C...Check whether this colour tag belongs to the present junction
62900 C...by seeing whether any parton with this colour tag has the same
62901 C...mother as the junction.
62904 DO 130 J2=MINT(84)+1,N
62906 C...First scattering partons have IMO1 = 3 and 4.
62907 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
62909 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
62912 IF (IMATCH.EQ.0) GOTO 140
62915 C...Check for junction-junction strings without intermediate final state
62916 C...glue (not detected above).
62920 IF (IJU2.EQ.I) GOTO 160
62921 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
62922 C...Only opposite types of junctions can connect to each other.
62923 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
62926 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
62928 IF (IS.EQ.3) GOTO 160
62933 C...Switch to other side of adjacent parton and step from there.
62939 ELSE IF (ILC.NE.3) THEN
62944 C...Look for coloured string endpoint, or (later) leftover gluon.
62945 IF(K(I,1).NE.3) GOTO 240
62947 IF(KC.EQ.0) GOTO 240
62949 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
62951 C...Pick up loose string end.
62953 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
62959 IF(NSTP.GT.4*N) THEN
62960 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
62965 C...Copy undecayed parton. Finished if reached string endpoint.
62966 IF(K(IA,1).EQ.3) THEN
62967 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
62968 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62975 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
62985 IF(K(I1,1).EQ.1) GOTO 240
62988 C...Also finished (for now) if reached junction; then copy to end.
62989 IF(K(IA,1).EQ.42) THEN
62991 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
62992 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62997 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
62998 DO 200 ICOPY=1,NCOPY
63000 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
63001 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
63002 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
63006 C...For junction-junction strings, find end leg and reorder junction
63007 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
63008 C...junction-junction string piece.
63009 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
63010 ITMP=MOD(K(IA,4),MSTU(5))
63011 IF (ITMP.NE.IB) THEN
63012 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
63013 K(IA,5)=K(IA,5)+(ITMP-IB)
63015 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
63017 K(IA,4)=K(IA,4)+(IB-ITMP)
63022 C...0: endpoint in original ER
63025 C...3: Parton immediately next to junction
63028 IPIECE(NPIECE,1)=MSTU32+1
63029 IPIECE(NPIECE,2)=MSTU32+NCOPY
63030 IPIECE(NPIECE,3)=IB
63031 IPIECE(NPIECE,4)=IA
63032 MSTU32=MSTU32+NCOPY
63037 C...GOTO next parton in colour space.
63039 IF (MINT(33).EQ.0) THEN
63040 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
63042 IA=MOD(K(IB,KCS),MSTU(5))
63043 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
63046 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
63047 & MSTU(5)).EQ.0) KCS=9-KCS
63048 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
63049 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
63052 IF(IA.LE.0.OR.IA.GT.N) THEN
63053 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
63054 IF(NERRPR.LT.5) THEN
63056 WRITE(MSTU(11),*) 'started at:', I
63057 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
63058 WRITE(MSTU(11),*) 'MQGST =',MQGST
63064 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
63065 & ,MSTU(5)).EQ.IB) THEN
63066 IF(MREV.EQ.1) KCS=9-KCS
63067 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
63068 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
63070 IF(MREV.EQ.0) KCS=9-KCS
63071 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
63072 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
63074 IF(IA.NE.I) GOTO 170
63075 C...Use colour tag information
63077 C...First create colour tags starting on IB if none already present.
63078 IF (MCT(IB,KCS-3).EQ.0) THEN
63079 CALL PYCTTR(IB,KCS,IB)
63080 IF(MINT(51).NE.0) RETURN
63084 C...Find final state tag partner
63085 DO 210 IT=MAX(1,IP),N
63086 IF (IT.EQ.IB) GOTO 210
63087 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
63093 C...Just copy and goto next if exactly one partner found.
63094 IF (IFOUND.EQ.1) THEN
63096 C...When no match found, match is presumably junction.
63097 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
63098 C...Check whether this colour tag matches a junction
63099 C...by seeing whether any parton with this colour tag has the same
63100 C...mother as a junction.
63101 C...NB: Only type 1 and 2 junctions handled presently.
63103 IJUMO=K(IJUNC(IJU,0),3)
63104 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
63105 C...Colours only connect to junctions, anti-colours to antijunctions:
63106 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
63108 DO 220 J1=MAX(1,IP),N
63109 IF (K(J1,1).LE.0) GOTO 220
63110 C...First scattering partons have IMO1 = 3 and 4.
63112 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
63114 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
63115 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
63117 C...Attempt at handling type > 3 junctions also. Not tested.
63118 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
63121 IF (IMATCH.EQ.0) GOTO 230
63126 IF (IFOUND.EQ.1) THEN
63128 ELSEIF (IFOUND.EQ.0) THEN
63130 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
63132 IF(NERRPR.LT.5) THEN
63139 ELSEIF (IFOUND.GE.2) THEN
63142 & ,'(PYPREP:) too many occurences of colour line: '//
63144 IF(NERRPR.LT.5) THEN
63156 C...Junction systems remain.
63162 260 IJUCNT=IJUCNT+1
63163 IF (IJUCNT.LE.NJUNC) THEN
63164 C...If we are not processing a j-j string, treat this junction as new.
63165 IF (IJJSTR.EQ.0) THEN
63166 IJU=IJUNC(IJUCNT,0)
63168 C...If junction has already been read, ignore it.
63169 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
63170 C...If we are on a j-j string, goto second j-j junction.
63175 C...Mark selected junction read.
63177 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
63179 C...Determine junction type
63180 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
63181 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63182 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63183 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63184 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
63187 C...Find which quarks belong to given junction.
63189 DO 290 IPC=1,NPIECE
63190 IF (IPIECE(IPC,4).EQ.IJU) THEN
63192 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
63194 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
63196 C...IHK = 3 is special. Either normal string piece, or j-j string.
63198 IF (MREV.NE.1) THEN
63199 DO 300 IPC=1,NPIECE
63200 C...If there is a j-j string starting on the present junction which has
63201 C...zero length, insert next junction immediately.
63202 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
63203 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
63209 C...If MREV is 1 and IHK is 3 we are finished with this system.
63216 C...If we've gotten this far, then either IHK < 3, or
63217 C...an interjunction string exists, or just a third normal string.
63218 IJUNC(IJUCNT,IHK)=0
63220 C..Order pieces belonging to this junction. Also look for j-j.
63221 DO 310 IPC=1,NPIECE
63222 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
63223 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
63224 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
63225 IJUNC(IJUCNT,IHK)=IPC
63230 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63231 IPC=IJUNC(IJUCNT,IHK)
63232 C...Temporary solution to cover for bug.
63234 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
63238 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
63241 K(I1,J)=K(MSTU(4)-ICP,J)
63242 P(I1,J)=P(MSTU(4)-ICP,J)
63243 V(I1,J)=V(MSTU(4)-ICP,J)
63247 C...Mark last quark.
63248 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
63249 C...Do not insert junctions at wrong places.
63250 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
63251 C...Insert junction.
63254 C...Shift to end junction if a j-j string has been processed.
63255 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
63265 K(IJUS,1)=K(IJUS,1)+10
63268 360 IF (IHK.LT.3) GOTO 280
63270 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
63274 IF (IJUCNT.NE.NJUNC) GOTO 260
63278 C...Rearrange three strings from junction, e.g. in case one has been
63279 C...shortened by shower, so the last is the largest-energy one.
63280 IF(NJUNC.GE.1) THEN
63281 C...Find systems with exactly one junction.
63285 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
63286 ELSEIF(K(I,1).EQ.41) THEN
63288 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
63293 C...Sum up energy-momentum in each junction string.
63300 DO 390 I1=NBEG,NEND
63301 IF(K(I1,2).NE.21) THEN
63306 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
63309 C...Find which of them has highest energy (minus mass) in rest frame.
63311 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63313 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
63316 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
63317 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
63319 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
63320 C...Decide how to rearrange so that new last has highest energy.
63321 IF(PJU(1,6).LT.PJU(2,6)) THEN
63323 IRNG(1,2)=IJUR(2)-1
63325 IRNG(2,2)=IJUR(3)+1
63326 IRNG(4,1)=IJUR(3)-1
63330 IRNG(1,2)=IJUR(3)+1
63332 IRNG(2,2)=IJUR(3)-1
63333 IRNG(4,1)=IJUR(2)-1
63338 C...Copy in correct order below bottom of current event record.
63341 DO 430 I1=IRNG(II,1),IRNG(II,2),
63342 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
63344 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
63346 & '(PYPREP:) no more memory left in PYJETS')
63356 IF(K(I2,1).EQ.1) K(I2,1)=2
63360 C...Copy back up, overwriting but now in correct order.
63361 DO 460 I1=NBEG,NEND
63375 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63376 C...to two q-qbar systems.
63377 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63378 IF (MSTJ(19).NE.1) THEN
63382 C...Force collapse when MSTJ(19)=2.
63383 IF (MSTJ(19).EQ.2) THEN
63387 C...Find systems with exactly two junctions.
63389 C...Count junctions
63390 IF (K(I,1).EQ.41) THEN
63392 C...Check for interjunction gluons
63393 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
63396 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
63397 C...If end of system reached with either zero or one junction, restart
63398 C...with next system.
63402 ELSEIF(K(I,1).EQ.1) THEN
63403 C...If end of system reached with exactly two junctions, compute string
63404 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63405 C...length measure for the (q-qbar)(q-qbar) topology.
63407 C...Loop down through chain.
63409 DO 480 I1=NBEG,NEND
63410 C...Store string piece division locations in event record
63411 IF (K(I1,2).NE.21) THEN
63416 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63418 IF (PYR(0).LT.0.5D0) ISW=1
63419 C...Randomly choose which qqbar string gets the jj gluons.
63421 IF (PYR(0).GT.0.5D0) IGS=2
63422 C...Only compute string lengths when no topology forced.
63423 IF (MSTJ(19).EQ.0) THEN
63424 C...Repeat following for each junction
63426 C...Initialize iterative procedure for finding JRF
63432 C...Start iteration. Sum up momenta in string pieces
63434 C...JD=-1 for first junction, +1 for second junction.
63435 C...Find out where piece starts and ends and which direction to go.
63438 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
63439 IB = IJCP((IJU-1)*7 - JD*IJS)
63440 ELSEIF (IJS.EQ.3) THEN
63442 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
63443 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
63445 C...Initialize junction pull 4-vector.
63449 C...Initialize weight
63452 C...Sum up (weighted) momenta along each string piece
63453 DO 530 ISP=IA,IB,JD
63454 C...If present parton not last in chain
63455 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
63456 C...If last parton was a junction, store present weight
63457 IF (K(ISP-JD,2).EQ.88) THEN
63459 C...If last parton was a quark, reset to stored weight.
63460 ELSEIF (K(ISP-JD,2).NE.21) THEN
63464 C...Skip next parton if weight already large
63465 IF (PWT.GT.10D0) GOTO 530
63466 C...Compute momentum in TJUOLD frame:
63467 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
63469 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
63471 TMP=P(ISP,J)+TJUOLD(J)*BFC
63472 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
63475 TMP=TJUOLD(4)*P(ISP,4)+TDP
63476 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
63478 PWT=PWT+TMP/PARJ(48)
63479 C...Put |p| rather than m in 5th slot
63480 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
63487 C...Combine new boost (T) with old boost (TJUOLD)
63488 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
63490 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
63493 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
63495 C...If last boost small, accept JRF, else iterate.
63496 C...Also prevent possibility of infinite loop.
63497 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
63498 & IJRFIT.LT.MSTJ(18))THEN
63500 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
63501 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
63503 C...Store final boost, with change of sign since TJJ motion vector.
63505 TJJ(IJU,IX)=-TJUOLD(IX)
63507 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
63510 C...String length measure for (q-qbar)(q-qbar) topology.
63511 C...Note only momenta of nearest partons used (since rest of system
63513 IF (JJGLUE.EQ.0) THEN
63514 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
63515 & -1,IJCP(5-ISW)+1)
63517 C...Put jj gluons on selected string (IGS selected randomly above).
63519 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63520 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
63522 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
63523 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63527 C...String length measure for q-q-j-j-q-q topology.
63536 C...Note only momenta of nearest partons used (since rest of system
63539 IF (IX.EQ.4) ISGN=1
63540 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
63541 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
63542 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
63543 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
63544 IF (JJGLUE.EQ.0) THEN
63545 C...Junction motion vector dot product gives length when inter-junction
63547 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
63549 C...Junction motion vector dot products with gluon momenta give length
63550 C...when inter-junction gluons present.
63551 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
63552 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
63555 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
63556 IF (JJGLUE.EQ.0) THEN
63557 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
63559 DELMJJ=DELMJJ*4D0*T1G1*T2G2
63562 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63563 C...(Always the case for MSTJ(19)=2 due to initialization above)
63564 IF (DELMJJ.GT.DELMQQ) THEN
63565 C...Put new system at end of event record
63568 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
63571 P(NCOP,IX)=P(ICOP,IX)
63572 K(NCOP,IX)=K(ICOP,IX)
63575 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
63576 C...Insert inter-junction gluon string piece (reversed)
63578 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
63582 P(NCOP,IX)=P(ICOP,IX)
63583 K(NCOP,IX)=K(ICOP,IX)
63588 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
63591 P(NCOP,IX)=P(ICOP,IX)
63592 K(NCOP,IX)=K(ICOP,IX)
63597 C...Copy system back in right order
63598 DO 670 ICOP=NBEG,NEND-2
63600 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
63601 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
63604 C...Shift down rest of event record
63605 DO 690 ICOP=NEND+1,N
63607 P(ICOP-2,IX)=P(ICOP,IX)
63608 K(ICOP-2,IX)=K(ICOP,IX)
63611 C...Update length of event record.
63621 C...Done if no checks on small-mass systems.
63622 IF(MSTJ(14).LT.0) RETURN
63623 IF(MSTJ(14).EQ.0) GOTO 1140
63625 C...Find lowest-mass colour singlet jet system.
63630 DO 770 I=MAX(1,IP),N
63631 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
63632 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
63639 DPS(5)=PYMASS(K(I,2))
63640 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
63642 DPS(J)=DPS(J)+P(I,J)
63645 DPS(5)=DPS(5)+PYMASS(K(I,2))
63646 ELSEIF(K(I,1).EQ.2) THEN
63648 DPS(J)=DPS(J)+P(I,J)
63650 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63652 DPS(J)=DPS(J)+P(I,J)
63655 DPS(5)=DPS(5)+PYMASS(K(I,2))
63656 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
63658 IF(PD.LT.PDMIN) THEN
63672 C...Done if lowest-mass system above threshold for string frag.
63673 IF(PDMIN.GE.PARJ(32)) GOTO 1140
63675 C...Fill small-mass system as cluster.
63677 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
63687 C...Set up history, assuming cluster -> 2 hadrons.
63693 IF(MSTU(16).NE.2) THEN
63708 C...Find total flavour content - complicated by presence of junctions.
63712 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
63715 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
63719 C...If several diquarks, split up one to give even number of flavours.
63720 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
63722 IF(IABS(KFQ(3)).LT.1000) I1=1
63723 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
63724 KFQ(I1)=KFQ(I1)/1000
63729 C...If four quark ends, join two to diquark.
63730 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
63733 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
63734 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
63735 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63736 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63737 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63738 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63744 C...If two quark ends, plus quark or diquark, join quarks to diquark.
63748 IF(IABS(KFQ(I1)).GT.1000) I1=3
63749 IF(IABS(KFQ(I2)).GT.1000) I2=3
63750 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63751 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63752 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63753 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63759 C...Form two particles from flavours of lowest-mass system, if feasible.
63761 790 NTRY = NTRY + 1
63763 C...Open string with two specified endpoint flavours.
63767 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
63768 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63769 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63770 IF(KQ1+KQ2.NE.0) GOTO 1140
63771 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63773 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
63775 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
63776 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
63777 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
63779 C...Open string with four specified flavours.
63780 ELSEIF(NQ.EQ.4) THEN
63785 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
63786 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63787 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63788 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
63789 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
63790 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
63791 C...Combine flavours pairwise to form two hadrons.
63794 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63795 & IABS(KFQ(2)).GT.1000)) I2=3
63796 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63797 & IABS(KFQ(3)).GT.1000))) I2=4
63801 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
63802 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
63803 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
63807 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
63808 C...No room for popcorn mesons in closed string -> 2 hadrons.
63810 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
63811 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
63812 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
63813 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
63815 P(N+2,5)=PYMASS(K(N+2,2))
63816 P(N+3,5)=PYMASS(K(N+3,2))
63818 C...If it does not work: try again (a number of times), give up (if no
63819 C...place to shuffle momentum or too many flavours), or form one hadron.
63820 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
63821 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
63823 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
63830 C...Perform two-particle decay of jet system.
63831 C...First step: find reference axis in decaying system rest frame.
63832 C...(Borrow slot N+2 for temporary direction.)
63836 DO 850 I=IC1+1,IC2-1
63837 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
63838 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63839 IF (ABS(FOUR(IC1,I)+FOUR(IC2,I)).GT.0.D0) THEN
63840 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
63845 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
63849 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
63851 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
63852 PHI1=PYANGL(P(N+2,1),P(N+2,2))
63854 C...Second step: generate isotropic/anisotropic decay.
63855 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
63856 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
63858 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
63859 PT2=(1D0-UE(3)**2)*PA**2
63860 IF(MSTJ(16).LE.0) THEN
63863 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
63864 PR1=P(N+2,5)**2+PT2
63865 PR2=P(N+3,5)**2+PT2
63866 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
63868 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63869 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
63871 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
63873 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
63874 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
63879 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
63880 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
63882 C...Third step: move back to event frame and set production vertex.
63883 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
63893 C...Else form one particle, if possible.
63901 C...Select hadron flavour from available quark flavours.
63902 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
63904 ELSEIF(NQ.EQ.2) THEN
63905 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
63907 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
63908 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
63910 IF(K(N+2,2).EQ.0) GOTO 910
63911 P(N+2,5)=PYMASS(K(N+2,2))
63913 C...Use old algorithm for E/p conservation? (EN)
63914 IF (MSTJ(16).LE.0) GOTO 1080
63916 C...Find the string piece closest to the cluster by a loop
63917 C...over the undecayed partons not in present cluster. (EN)
63922 DO 940 I1=MAX(1,IP),N-1
63923 IF(K(I1,1).EQ.1) NJUNC=0
63924 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
63925 IF(K(I1,1).EQ.41) GOTO 940
63926 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
63928 ELSEIF(K(I1,1).EQ.2) THEN
63932 IF(K(I2,1).EQ.41) GOTO 940
63933 IF(K(I2,1).GT.10) GOTO 920
63934 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
63935 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
63936 & NJUNC.EQ.0) GOTO 940
63937 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
63938 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
63939 & K(I2,1).NE.1)) GOTO 940
63941 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63943 E1(J)=P(I1,J)/P(I1,4)
63944 E2(J)=P(I2,J)/P(I2,4)
63945 ECL(J)=P(N+1,J)/P(N+1,4)
63950 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63951 E3S=E3(1)**2+E3(2)**2+E3(3)**2
63952 E4S=E4(1)**2+E4(2)**2+E4(3)**2
63953 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
63954 IF(E34.LE.0D0) THEN
63956 ELSEIF(E34.LT.E3S) THEN
63957 DDMIN=E4S-E34**2/E3S
63959 DDMIN=E4S-2D0*E34+E3S
63962 C...Is this the smallest so far?
63963 IF(DDMIN.LT.DGLOMI) THEN
63968 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
63973 C... Check if there are any strings to connect to the new gluon. (EN)
63974 IF (IBEG.EQ.0) GOTO 1080
63976 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63977 IF (P(N+1,5).GE.P(N+2,5)) THEN
63979 C...Construct 'gluon' that is needed to put hadron on the mass shell.
63980 FRAC=P(N+2,5)/P(N+1,5)
63982 P(N+2,J)=FRAC*P(N+1,J)
63983 PG(J)=(1D0-FRAC)*P(N+1,J)
63986 C... Copy string with new gluon put in.
63990 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
63991 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
64012 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
64015 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
64016 C...from string piece endpoints.
64019 C...Begin by copying string that should give energy to cluster.
64023 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
64024 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
64036 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
64039 C...Set initial Phad.
64041 P(NSAV+2,J)=P(NSAV+1,J)
64044 C...Calculate Pg, a part of which will be added to Phad later. (EN)
64045 1020 IF(MSTJ(16).EQ.1) THEN
64049 IF (ABS(FOUR(I1,I2)).GT.0.D0) THEN
64050 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
64051 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
64058 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
64060 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
64062 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
64063 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
64065 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
64066 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
64067 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
64069 C...If all gluon energy eaten, zero it and take a step back.
64071 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
64074 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
64080 IF(K(I1,1).EQ.41) ITER=-1
64082 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
64085 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
64091 IF(K(I2,1).EQ.41) ITER=-1
64093 IF(ITER.EQ.1) GOTO 1020
64095 C...If also all endpoint energy eaten, revert to old procedure.
64096 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
64097 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
64108 C... Construct the collapsed hadron and modified string partons.
64110 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
64111 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
64112 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
64114 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
64115 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
64117 C...Finished with string collapse in new scheme.
64121 C... Use old algorithm; by choice or when in trouble.
64123 C...Find parton/particle which combines to largest extra mass.
64128 IF(IR.NE.0) GOTO 1100
64129 DO 1090 I=MAX(1,IP),N
64130 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
64131 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
64132 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
64133 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
64134 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
64135 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
64137 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
64138 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
64139 IF(HSR.GT.HSM) THEN
64147 C...Shuffle energy and momentum to put new particle on mass shell.
64152 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
64153 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
64154 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
64156 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
64157 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
64161 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
64165 C...Mark collapsed system and store daughter pointers. Iterate.
64166 1120 DO 1130 I=IC1,IC2
64167 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
64168 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
64170 IF(MSTU(16).NE.2) THEN
64175 K(I,5)=NSAV+1+NBODY
64178 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
64180 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
64182 C...Check flavours and invariant masses in parton systems.
64190 DO 1180 I=MAX(1,IP),N
64191 IF(K(I,1).EQ.41) NJU=NJU+1
64192 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
64194 IF(KC.EQ.0) GOTO 1180
64195 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64196 IF(KQ.EQ.0) GOTO 1180
64202 DPS(5)=DPS(5)+PYMASS(K(I,2))
64205 DPS(J)=DPS(J)+P(I,J)
64207 IF(K(I,1).EQ.1) THEN
64209 IF(NJU.EQ.0.AND.NP.NE.1) THEN
64210 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
64211 ELSEIF(NJU.EQ.1) THEN
64212 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
64213 ELSEIF(NJU.EQ.2) THEN
64214 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
64215 ELSEIF(NJU.GE.3) THEN
64218 IF(NFERR.EQ.1) THEN
64219 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
64223 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
64224 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
64225 & '(PYPREP:) too small mass in jet system')
64239 C*********************************************************************
64242 C...Handles the fragmentation of an arbitrary colour singlet
64243 C...jet system according to the Lund string fragmentation model.
64245 SUBROUTINE PYSTRF(IP)
64247 C...Double precision and integer declarations.
64248 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64249 IMPLICIT INTEGER(I-N)
64250 INTEGER PYK,PYCHGE,PYCOMP
64252 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64253 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64254 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64255 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
64256 C...Local arrays. All MOPS variables ends with MO
64257 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
64258 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
64259 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
64260 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
64261 &PBST(3,5),TJUOLD(5)
64263 C...Function: four-product of two vectors.
64264 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)
64265 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
64268 C...Reset counters.
64283 C...Identify parton system.
64286 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
64287 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
64288 IF(MSTU(21).GE.1) RETURN
64290 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
64292 IF(KC.EQ.0) GOTO 110
64293 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64294 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
64295 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
64296 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64297 IF(MSTU(21).GE.1) RETURN
64300 C...Take copy of partons to be considered. Check flavour sum.
64305 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
64307 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
64309 IF(KQ.NE.2) KQSUM=KQSUM+KQ
64310 IF(K(I,1).EQ.41) THEN
64311 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
64319 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
64320 IF(MOD(KQSUM,3).NE.0) THEN
64321 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
64322 IF(MSTU(21).GE.1) RETURN
64324 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
64326 C...Boost copied system to CM frame (for better numerical precision).
64327 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
64330 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
64334 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
64336 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
64337 IF(P(I,3).GT.0D0) THEN
64338 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
64339 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
64340 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64342 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
64343 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
64344 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64349 C...Search for very nearby partons that may be recombined.
64358 IF(MJU(1).GT.0) NRMIN=NRMIN+2
64359 IF(MJU(2).GT.0) NRMIN=NRMIN+2
64360 140 IF(NR.GT.NRMIN) THEN
64363 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
64365 IF(I.EQ.N+NR) I1=N+1
64366 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
64367 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
64369 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
64371 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
64372 & P(I1,2)**2+P(I1,3)**2))
64373 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
64374 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
64375 IF(PDR.LT.PDRMIN) THEN
64381 C...Recombine very nearby partons to avoid machine precision problems.
64382 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
64384 P(N+1,J)=P(N+1,J)+P(N+NR,J)
64386 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
64390 ELSEIF(PDRMIN.LT.PARU12) THEN
64392 P(IR,J)=P(IR,J)+P(IR+1,J)
64394 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
64396 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
64397 DO 190 I=IR+1,N+NR-1
64404 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
64406 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
64407 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
64413 C...Reset particle counter. Skip ahead if no junctions are present;
64414 C...this is usually the case!
64415 NRS=MAX(5*NR+11,NP)
64418 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64422 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
64423 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64424 IF(MSTU(21).GE.1) RETURN
64428 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
64429 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
64430 & ' junction strings not handled by MSTJ(12)>3 options')
64433 IF(MJU(JT).EQ.0) GOTO 640
64437 C...Find and sum up momentum on three sides of junction.
64438 C...Begin with previous boost = zero.
64443 C...Prevent IJU (specifically IJU(5)) from containing junk below
64449 C...Beginning and end of string system in event record.
64450 I1BEG=N+1+(JT-1)*(NR-1)
64451 I1END=N+NR+(JT-1)*(1-NR)
64452 C...Look for junction string piece end points
64453 DO 230 I1=I1BEG,I1END,JS
64454 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
64455 C...Store junction string piece end points.
64456 C 1-junction systems 2-junction systems
64457 C IU : 1 2 3 4 1 2 3 4 5 6
64458 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
64462 C...Sum over momenta, from junction outwards.
64466 C...Initialize junction drag and string piece 4-vectors.
64471 C...First two branches. Inwards out means opposite direction to JS.
64472 C...(JS is 1 for JT=1, -1 for JT=2)
64477 C...Last branch (gq or gjgqgq). Direction now reversed.
64483 DO 270 I1=I1A,I1B,IDIR
64484 C...Sum up momentum directions with exponential suppression
64485 C...for use in finding junction rest frame below.
64486 IF (K(I1,2).EQ.88) THEN
64487 C...gjgqgq type system encountered. Use current PWT as start
64488 C...for both strings.
64491 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
64492 C...Sum up string piece (boosted) 4-momenta.
64494 PJU(IU,J)=PJU(IU,J)+P(I1,J)
64496 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64497 C...boost is zero, see above). Skip parton if suppression factor large.
64498 IF (PWT.GT.10D0) GOTO 270
64499 C...Compute momentum in current frame:
64500 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
64501 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
64503 PTMP=P(I1,J)+TJUOLD(J)*BFC
64504 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
64507 PTMP=TJUOLD(4)*P(I1,4)+TDP
64508 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
64509 PWT=PWT+PTMP/PARJ(48)
64512 C...Put |p| rather than m in 5th slot.
64513 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
64514 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
64517 C...Calculate boost from present frame to next JRF candidate.
64519 CALL PYJURF(PBST,TJU)
64521 C...After some iterations do not take full step in new direction.
64522 IF(IJRFIT.GT.5) THEN
64523 REDUCE=0.8D0**(IJRFIT-5)
64524 TJU(1)=REDUCE*TJU(1)
64525 TJU(2)=REDUCE*TJU(2)
64526 TJU(3)=REDUCE*TJU(3)
64527 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64530 C...Combine new boost (TJU) with old boost (TJUOLD)
64531 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
64533 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
64535 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
64537 C...If last boost small, accept JRF, else iterate.
64538 C...Also prevent possibility of infinite loop.
64539 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
64540 & IJRFIT.LT.MSTJ(18)) THEN
64542 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
64543 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
64546 C...Now store total boost in TJU and change perception.
64547 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64548 C...TJU = junction motion vector in string CM, so the sign changes.
64552 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64556 C...Calculate string piece energies in junction rest frame.
64558 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
64560 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
64561 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
64564 C...Start preparing for fragmentation of two strings from junction.
64567 320 NTRYER=NTRYER+1
64570 NS=IABS(IJU(IU+1)-IJU(IU))
64572 C...Junction strings: find longitudinal string directions.
64574 IS1=IJU(IU)+JS*(IS-1)
64577 DP(1,J)=0.5D0*P(IS1,J)
64578 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
64579 DP(2,J)=0.5D0*P(IS2,J)
64580 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
64581 & (PJU(IU,5)/PBST(IU,5))
64583 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
64584 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
64588 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
64589 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64590 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64595 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64596 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64597 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64599 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64601 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64602 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64606 C...Junction strings: initialize flavour, momentum and starting pos.
64610 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64614 ELSEIF(NTRY.GT.100) THEN
64615 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64616 IF(MSTU(21).GE.1) RETURN
64621 IE(1)=K(N+1+(JT/2)*(NP-1),3)
64622 IF (MOD(JT+IU,2).NE.0) THEN
64624 IF (NP-NR.NE.0) THEN
64625 C...If gluons have disappeared. Original IJU must be used.
64629 IF (K(IT,2).NE.21) THEN
64632 IF (NE.EQ.IU+4*(JT-1)) THEN
64634 ELSEIF (IT.LE.IP+NP) THEN
64637 CALL PYERRM(14,'(PYSTRF:) '//
64638 & 'Original IJU could not be reconstructed!')
64646 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
64652 KFL(1)=K(IJU(IU),2)
64660 C...Junction strings: find initial transverse directions.
64663 DP(2,J)=P(IN(4)+1,J)
64667 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64668 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64669 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64670 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64671 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64672 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64673 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64674 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64675 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64677 DHCX1=DFOUR(3,1)/DHC12
64678 DHCX2=DFOUR(3,2)/DHC12
64679 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64680 DHCY1=DFOUR(4,1)/DHC12
64681 DHCY2=DFOUR(4,2)/DHC12
64682 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64683 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64685 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64687 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64691 C...Junction strings: produce new particle, origin.
64693 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
64694 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64695 IF(MSTU(21).GE.1) RETURN
64703 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64704 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
64705 IF(K(I,2).EQ.0) GOTO 360
64706 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
64707 & IABS(KFL(3)).GT.10) THEN
64708 IF(PYR(0).GT.PARJ(19)) GOTO 440
64710 P(I,5)=PYMASS(K(I,2))
64711 CALL PYPTDI(KFL(1),PX(3),PY(3))
64712 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
64713 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
64714 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
64715 & MSTU(90).LT.8) THEN
64716 MSTU(90)=MSTU(90)+1
64717 MSTU(90+MSTU(90))=I
64718 PARU(90+MSTU(90))=Z
64720 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
64725 C...Junction strings: stepping within 'low' string region.
64726 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
64727 & P(IN(1),5)**2.GE.PR(1)) THEN
64728 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
64729 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
64731 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
64734 C...Has used up energy of junction string, i.e. no more hadrons in it.
64735 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
64740 C...Stepping from 'low' string region
64741 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
64742 P(IN(2)+2,4)=P(IN(2)+2,3)
64745 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64746 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64747 P(IN(1)+2,4)=P(IN(1)+2,3)
64753 C...Junction strings: find new transverse directions.
64754 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
64755 & IN(1).GT.IN(2)) GOTO 360
64756 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
64763 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64764 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64766 IF(DHC12.LE.1D-2) THEN
64767 P(IN(1)+2,4)=P(IN(1)+2,3)
64773 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64774 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64775 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64776 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64777 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64778 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64779 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64780 DHCX1=DFOUR(3,1)/DHC12
64781 DHCX2=DFOUR(3,2)/DHC12
64782 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64783 DHCY1=DFOUR(4,1)/DHC12
64784 DHCY2=DFOUR(4,2)/DHC12
64785 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64786 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64788 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64790 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64793 C...Express pT with respect to new axes, if sensible.
64794 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
64795 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
64796 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
64802 C...Junction strings: sum up known four-momentum, coefficients for m2.
64805 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
64806 & PY(3)*P(IN(3)+1,J)
64807 DO 510 IN1=IN(4),IN(1)-4,4
64808 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
64810 DO 520 IN2=IN(5),IN(2)-4,4
64811 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
64815 DHM(2)=2D0*FOUR(I,IN(1))
64816 DHM(3)=2D0*FOUR(I,IN(2))
64817 DHM(4)=2D0*FOUR(IN(1),IN(2))
64819 C...Junction strings: find coefficients for Gamma expression.
64820 DO 550 IN2=IN(1)+1,IN(2),4
64821 DO 540 IN1=IN(1),IN2-1,4
64822 DHC=2D0*FOUR(IN1,IN2)
64823 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
64824 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
64825 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
64826 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
64830 C...Junction strings: solve (m2, Gamma) equation system for energies.
64831 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
64832 IF(ABS(DHS1).LT.1D-4) GOTO 360
64833 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
64834 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
64835 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
64836 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
64837 & ABS(DHS1)-DHS2/DHS1)
64838 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
64839 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
64840 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
64842 C...Junction strings: step to new region if necessary.
64843 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
64844 P(IN(2)+2,4)=P(IN(2)+2,3)
64847 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64848 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64849 P(IN(1)+2,4)=P(IN(1)+2,3)
64854 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
64855 P(IN(1)+2,4)=P(IN(1)+2,3)
64861 C...Junction strings: particle four-momentum, remainder, loop back.
64863 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
64864 & P(IN(2)+2,4)*P(IN(2),J)
64865 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
64867 IF(P(I,4).LT.P(I,5)) GOTO 360
64868 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64869 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64870 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
64875 IF(IN(3).NE.IN(6)) THEN
64877 P(IN(6),J)=P(IN(3),J)
64878 P(IN(6)+1,J)=P(IN(3)+1,J)
64883 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
64884 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
64889 C...Junction strings: save quantities left after each string.
64890 IF(IABS(KFL(1)).GT.10) GOTO 360
64894 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
64897 C...Junction strings: loopback if much unused energy in both strings.
64898 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64899 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64900 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
64902 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
64903 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
64904 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
64905 & .AND.NTRYER.LT.10) GOTO 320
64907 C...Junction strings: put together to new effective string endpoint.
64909 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
64910 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
64911 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
64912 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
64914 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
64915 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
64917 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
64922 C...Open versus closed strings. Choose breakup region for latter.
64923 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
64926 ELSEIF(MJU(1).NE.0) THEN
64929 ELSEIF(MJU(2).NE.0) THEN
64932 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
64939 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
64940 W2SUM=W2SUM+P(N+NR+IS,1)
64945 W2SUM=W2SUM-P(N+NR+NB,1)
64946 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
64949 C...Find longitudinal string directions (i.e. lightlike four-vectors).
64951 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
64952 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
64955 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
64956 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
64958 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
64959 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
64961 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
64962 & DP(1,2)**2-DP(1,3)**2))
64963 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
64964 & DP(2,2)**2-DP(2,3)**2))
64968 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
64969 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64970 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64971 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64973 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64975 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64976 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64980 C...Begin initialization: sum up energy, set starting position.
64984 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64988 ELSEIF(NTRY.GT.100) THEN
64989 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64990 IF(MSTU(21).GE.1) RETURN
64997 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
65002 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
65003 IF(NS.GT.NR) IRANK(JT)=1
65005 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
65006 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
65007 IN(3*JT+2)=IN(3*JT+1)+1
65008 IN(3*JT+3)=N+NR+4*NS+2*JT-1
65009 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
65016 C.. MOPS variables and switches
65022 C...Initialize flavour and pT variables for open string.
65026 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
65030 KFL(JT)=K(IE(JT),2)
65031 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
65032 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
65034 PMQ(JT)=PYMASS(KFL(JT))
65038 C...Closed string: random initial breakup flavour, pT and vertex.
65040 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65042 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
65043 C.. Closed string: first vertex diq attempt => enforced second
65045 IF(IABS(KFL(1)).GT.10)THEN
65050 IF(IBMO.EQ.1) MSTU(121)=-1
65052 CALL PYPTDI(KFL(1),PX(1),PY(1))
65055 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
65056 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
65057 ZR=PR3/(Z*P(N+NR+1,5)**2)
65058 IF(ZR.GE.1D0) GOTO 780
65061 PMQ(JT)=PYMASS(KFL(JT))
65062 GAM(JT)=PR3*(1D0-Z)/Z
65063 IN1=N+NR+3+4*(JT/2)*(NS-1)
65066 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
65069 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
65075 PM2QMO(JT)=PMQ(JT)**2
65076 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
65079 C...Find initial transverse directions (i.e. spacelike four-vectors).
65081 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
65090 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65091 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65092 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65093 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65094 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65095 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65096 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65097 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65098 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65100 DHCX1=DFOUR(3,1)/DHC12
65101 DHCX2=DFOUR(3,2)/DHC12
65102 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65103 DHCY1=DFOUR(4,1)/DHC12
65104 DHCY2=DFOUR(4,2)/DHC12
65105 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65106 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65108 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65110 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65115 P(IN3+2,J)=P(IN3,J)
65116 P(IN3+3,J)=P(IN3+1,J)
65121 C...Remove energy used up in junction string fragmentation.
65122 IF(MJU(1)+MJU(2).GT.0) THEN
65124 IF(NJS(JT).EQ.0) GOTO 860
65126 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
65130 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65131 WMIN=PARJST+PMQ(1)+PMQ(2)
65132 WREM2=FOUR(N+NRS,N+NRS)
65133 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
65135 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
65140 C...Produce new particle: side, origin.
65142 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
65143 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65144 IF(MSTU(21).GE.1) RETURN
65146 C.. New side priority for popcorn systems
65147 IF(MSTU(121).LE.0)THEN
65149 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
65150 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
65154 IRANK(JT)=IRANK(JT)+1
65159 C...Generate flavour, hadron and pT.
65161 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
65162 IF(K(I,2).EQ.0) GOTO 710
65164 IF(MSTU(121).EQ.-1) GOTO 910
65165 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
65166 &IABS(KFL(3)).GT.10) THEN
65167 IF(PYR(0).GT.PARJ(19)) GOTO 880
65169 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65171 P(I,5)=PYMASS(K(I,2))
65172 CALL PYPTDI(KFL(JT),PX(3),PY(3))
65173 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
65175 C...Final hadrons for small invariant mass.
65177 PMQ(3)=PYMASS(KFL(3))
65179 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65180 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
65181 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
65182 &WMIN-0.5D0*PARJ(36)*PMQ(3)
65183 WREM2=FOUR(N+NRS,N+NRS)
65184 IF(WREM2.LT.0.10D0) GOTO 710
65185 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
65186 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
65188 C...Choose z, which gives Gamma. Shift z for heavy flavours.
65189 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
65190 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
65191 &MSTU(90).LT.8) THEN
65192 MSTU(90)=MSTU(90)+1
65193 MSTU(90+MSTU(90))=I
65194 PARU(90+MSTU(90))=Z
65198 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65199 &MOD(KFL2A/1000,10)).GE.4) THEN
65200 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65201 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
65202 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
65203 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65204 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
65206 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
65208 C.. MOPS baryon model modification
65209 XTMO3=(1D0-Z)*XTMO(JT)
65210 IF(IABS(KFL(3)).LE.10) NRVMO=0
65211 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
65215 IF(IABS(KFL(JT)).LE.10)THEN
65216 XBMO=MIN(XTMO3,1D0-(2D-10))
65219 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
65220 GTSTMO=1D0-PARF(192)**PGMO
65222 IF(IRANK(JT).EQ.1) THEN
65227 IF(XBMO.LT.1D0-(1D-10))THEN
65228 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
65229 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
65232 IF(MSTJ(12).GE.5)THEN
65233 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
65234 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
65235 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
65240 C.. MOPS Accepting popcorn system hadron.
65241 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
65242 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
65244 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
65246 & '(PYSTRF:) no more memory left in PYJETS')
65247 IF(MSTU(21).GE.1) RETURN
65259 DO 890 LINE=1,I-N-NR
65260 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
65261 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
65268 C..Reject popcorn system, flag=-1 if enforcing new one
65270 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
65275 C..Lift restoring string outside MOPS block
65276 910 IF(MSTU(121).LT.0) THEN
65277 IF(MSTU(121).EQ.-2) MSTU(121)=0
65280 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
65291 DO 920 LINE=1,I-N-NR
65292 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
65293 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
65301 C.. MOPS end of modification
65307 C...Stepping within or from 'low' string region easy.
65308 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
65309 &P(IN(1),5)**2.GE.PR(JT)) THEN
65310 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
65311 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
65313 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
65316 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
65317 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65320 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65321 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65322 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65328 C...Find new transverse directions (i.e. spacelike string vectors).
65329 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
65330 &IN(1).GT.IN(2)) GOTO 710
65331 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
65338 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65339 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65341 IF(DHC12.LE.1D-2) THEN
65342 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65348 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65349 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65350 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65351 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65352 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65353 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65354 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65355 DHCX1=DFOUR(3,1)/DHC12
65356 DHCX2=DFOUR(3,2)/DHC12
65357 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65358 DHCY1=DFOUR(4,1)/DHC12
65359 DHCY2=DFOUR(4,2)/DHC12
65360 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65361 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65363 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65365 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65368 C...Express pT with respect to new axes, if sensible.
65369 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
65370 & FOUR(IN(3*JT+3)+1,IN(3)))
65371 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
65372 & FOUR(IN(3*JT+3)+1,IN(3)+1))
65373 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
65379 C...Sum up known four-momentum. Gives coefficients for m2 expression.
65382 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
65383 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
65384 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
65385 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
65387 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
65388 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
65392 DHM(2)=2D0*FOUR(I,IN(1))
65393 DHM(3)=2D0*FOUR(I,IN(2))
65394 DHM(4)=2D0*FOUR(IN(1),IN(2))
65396 C...Find coefficients for Gamma expression.
65397 DO 1030 IN2=IN(1)+1,IN(2),4
65398 DO 1020 IN1=IN(1),IN2-1,4
65399 DHC=2D0*FOUR(IN1,IN2)
65400 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
65401 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
65402 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
65403 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
65407 C...Solve (m2, Gamma) equation system for energies taken.
65408 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
65409 IF(ABS(DHS1).LT.1D-4) GOTO 710
65410 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
65411 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
65412 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
65413 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
65414 &ABS(DHS1)-DHS2/DHS1)
65415 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
65416 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
65417 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
65419 C...Step to new region if necessary.
65420 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
65421 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65424 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65425 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65426 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65431 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
65432 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65438 C...Four-momentum of particle. Remaining quantities. Loop back.
65440 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
65441 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
65443 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
65444 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
65446 IF(P(I,4).LT.P(I,5)) GOTO 710
65452 IF(IN(3).NE.IN(3*JT+3)) THEN
65454 P(IN(3*JT+3),J)=P(IN(3),J)
65455 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
65460 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
65461 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
65463 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65467 C...Final hadron: side, flavour, hadron, mass.
65473 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
65474 IF(K(I,2).EQ.0) GOTO 710
65475 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
65477 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65479 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65481 P(I,5)=PYMASS(K(I,2))
65482 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65484 C...Final two hadrons: find common setup of four-vectors.
65486 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
65487 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
65488 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
65489 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
65490 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
65491 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
65492 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
65493 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
65494 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
65495 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
65498 C...Solve kinematics for final two hadrons, if possible.
65499 WREM2=2D0*DHR1*DHR2*DHC12
65500 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
65501 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
65502 IF(FD.GE.1D0) GOTO 710
65503 FA=WREM2+PR(JT)-PR(JR)
65504 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
65506 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65507 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
65508 FB=SIGN(FB,JS*(PYR(0)-PREV))
65511 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65512 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
65513 &4D0*WREM2*PR(JT))),DBLE(JS))
65515 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
65516 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
65517 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
65518 P(I,J)=P(N+NRS,J)-P(I-1,J)
65520 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
65521 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
65522 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
65523 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
65525 IF(NTRYFN.LT.100) GOTO 140
65526 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
65529 C...Mark jets as fragmented and give daughter pointers.
65531 DO 1100 I=NSAV+1,NSAV+NP
65534 IF(MSTU(16).NE.2) THEN
65543 C...Document string system. Move up particles.
65554 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
65558 K(I,J)=K(I+NRS-1,J)
65559 P(I,J)=P(I+NRS-1,J)
65564 DO 1140 IZ=MSTU90+1,MSTU91
65565 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
65566 PARU9T(IZ)=PARU(90+IZ)
65570 C...Order particles in rank along the chain. Update mother pointer.
65573 K(I-NSAV+N,J)=K(I,J)
65574 P(I-NSAV+N,J)=P(I,J)
65578 DO 1190 I=N+1,2*N-NSAV
65579 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
65585 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65586 DO 1180 IZ=MSTU90+1,MSTU91
65587 IF(MSTU9T(IZ).EQ.I) THEN
65588 MSTU(90)=MSTU(90)+1
65589 MSTU(90+MSTU(90))=I1
65590 PARU(90+MSTU(90))=PARU9T(IZ)
65594 DO 1220 I=2*N-NSAV,N+1,-1
65595 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
65601 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65602 DO 1210 IZ=MSTU90+1,MSTU91
65603 IF(MSTU9T(IZ).EQ.I) THEN
65604 MSTU(90)=MSTU(90)+1
65605 MSTU(90+MSTU(90))=I1
65606 PARU(90+MSTU(90))=PARU9T(IZ)
65611 C...Boost back particle system. Set production vertices.
65614 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
65618 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65619 IF(P(I,3).GT.0D0) THEN
65620 HHPEZ=(P(I,4)+P(I,3))*HHBZ
65621 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65622 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65624 HHPEZ=(P(I,4)-P(I,3))/HHBZ
65625 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65626 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65639 C*********************************************************************
65642 C...From three given input vectors in PJU the boost VJU from
65643 C...the "lab frame" to the junction rest frame is constructed.
65645 SUBROUTINE PYJURF(PJU,VJU)
65647 C...Double precision and integer declarations.
65648 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65649 IMPLICIT INTEGER(I-N)
65651 C...Input, output and local arrays.
65652 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
65653 DATA TWOPI/6.283186D0/
65655 C...Calculate masses and other invariants.
65657 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
65659 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
65660 PSUM(5)=SQRT(PSUM2)
65663 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
65664 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
65668 C...Pick I to be most massive parton and J to be the one closest to I.
65671 IF(A(2,2).GT.A(1,1)) I=2
65672 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
65676 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
65687 C...Trivial find new parton energies if all three partons are massless.
65688 IF(PMI2.LT.1D-4) THEN
65689 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
65690 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
65691 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
65693 C...Else find momentum range for parton I and values at extremes.
65699 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
65700 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
65701 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
65702 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
65703 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
65704 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
65705 HI=PEIMAX**2-0.25D0*PAIMAX**2
65706 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
65707 & 0.5D0*PAIMAX*AIJ)/HI
65708 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
65709 & 0.5D0*PAIMAX*AIK)/HI
65710 PEJMAX=SQRT(PAJMAX**2+PMJ2)
65711 PEKMAX=SQRT(PAKMAX**2+PMK2)
65712 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
65714 C...If unexpected values at upper endpoint then pick another parton.
65715 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
65717 IF(A(I1,I1).GE.1D-4) THEN
65723 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
65729 C..Start binary + linear search to find solution inside range.
65733 PAI=0.5D0*(PAIMIN+PAIMAX)
65736 C...Derive momentum of other two partons and distance to root.
65737 PEI=SQRT(PAI**2+PMI2)
65738 HI=PEI**2-0.25D0*PAI**2
65739 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
65740 PEJ=SQRT(PAJ**2+PMJ2)
65741 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
65742 PEK=SQRT(PAK**2+PMK2)
65743 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
65745 C...Pick next I momentum to explore, hopefully closer to root.
65746 IF(FNOW.GT.0D0) THEN
65755 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
65757 PAI=0.5D0*(PAIMIN+PAIMAX)
65759 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
65760 & ABS(FNOW).GT.1D-12*PSUM2) THEN
65761 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
65766 C...Now know energies in junction rest frame.
65771 C...Boost (copy of) partons to their rest frame.
65772 VXCM=-PSUM(1)/PSUM(5)
65773 VYCM=-PSUM(2)/PSUM(5)
65774 VZCM=-PSUM(3)/PSUM(5)
65775 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
65777 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
65778 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
65779 PCM(I,1)=PJU(I,1)+FAC2*VXCM
65780 PCM(I,2)=PJU(I,2)+FAC2*VYCM
65781 PCM(I,3)=PJU(I,3)+FAC2*VZCM
65782 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
65783 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65786 C...Construct difference vectors and boost to junction rest frame.
65788 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
65789 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
65791 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
65792 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
65793 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
65794 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
65795 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
65796 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
65797 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
65798 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
65799 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
65800 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
65801 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
65803 C...Add two boosts, giving final result.
65804 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
65805 VJU(1)=VXJU+FCM*VXCM
65806 VJU(2)=VYJU+FCM*VYCM
65807 VJU(3)=VZJU+FCM*VZCM
65808 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
65811 C...In case of error in reconstruction: revert to CM frame of system.
65812 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65813 &(PCM(1,5)*PCM(2,5))
65814 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65815 &(PCM(1,5)*PCM(3,5))
65816 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65817 &(PCM(2,5)*PCM(3,5))
65818 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65819 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65821 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
65822 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
65823 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
65824 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
65825 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
65826 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
65827 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65829 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65830 &(PCM(1,5)*PCM(2,5))
65831 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65832 &(PCM(1,5)*PCM(3,5))
65833 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65834 &(PCM(2,5)*PCM(3,5))
65835 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65836 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65837 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
65847 C*********************************************************************
65850 C...Handles the fragmentation of a jet system (or a single
65851 C...jet) according to independent fragmentation models.
65853 SUBROUTINE PYINDF(IP)
65855 C...Double precision and integer declarations.
65856 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65857 IMPLICIT INTEGER(I-N)
65858 INTEGER PYK,PYCHGE,PYCOMP
65860 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65861 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65862 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65863 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65865 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
65866 &KFLO(2),PXO(2),PYO(2),WO(2)
65868 C.. MOPS error message
65869 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
65870 &' are not treated as expected in independent fragmentation')
65872 C...Reset counters. Identify parton system and take copy. Check flavour.
65882 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65883 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
65884 IF(MSTU(21).GE.1) RETURN
65886 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
65888 IF(KC.EQ.0) GOTO 110
65889 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65890 IF(KQ.EQ.0) GOTO 110
65892 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65894 K(NSAV+NJET,J)=K(I,J)
65895 P(NSAV+NJET,J)=P(I,J)
65896 DPS(J)=DPS(J)+P(I,J)
65899 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
65900 &K(I+1,1).EQ.2)) GOTO 110
65901 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
65902 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
65903 IF(MSTU(21).GE.1) RETURN
65906 C...Boost copied system to CM frame. Find CM energy and sum flavours.
65909 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
65910 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
65916 DO 140 I=NSAV+1,NSAV+NJET
65920 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
65921 ELSEIF(KFA.GT.1000) THEN
65922 KFLA=MOD(KFA/1000,10)
65923 KFLB=MOD(KFA/100,10)
65924 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
65925 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
65929 C...Loop over attempts made. Reset counters.
65932 IF(NTRY.GT.200) THEN
65933 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
65934 IF(MSTU(21).GE.1) RETURN
65944 C...Loop over jets to be fragmented.
65945 DO 230 IP1=NSAV+1,NSAV+NJET
65950 C...Initial flavour and momentum values. Jet along +z axis.
65951 KFLH=IABS(K(IP1,2))
65952 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
65954 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
65956 C...Initial values for quark or diquark jet.
65957 170 IF(IABS(K(IP1,2)).NE.21) THEN
65960 CALL PYPTDI(0,PXO(1),PYO(1))
65963 C...Initial values for gluon treated like random quark jet.
65964 ELSEIF(MSTJ(2).LE.2) THEN
65966 IF(MSTJ(2).EQ.2) MSTJ(91)=1
65967 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65968 CALL PYPTDI(0,PXO(1),PYO(1))
65971 C...Initial values for gluon treated like quark-antiquark jet pair,
65972 C...sharing energy according to Altarelli-Parisi splitting function.
65975 IF(MSTJ(2).EQ.4) MSTJ(91)=1
65976 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65978 CALL PYPTDI(0,PXO(1),PYO(1))
65981 WO(1)=WF*PYR(0)**(1D0/3D0)
65985 C...Initial values for rank, flavour, pT and W+.
65995 C...New hadron. Generate flavour and hadron species.
65997 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
65998 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
65999 IF(MSTU(21).GE.1) RETURN
66006 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
66007 IF(K(I,2).EQ.0) GOTO 180
66008 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
66009 IF(PYR(0).GT.PARJ(19)) GOTO 200
66012 C...Find hadron mass. Generate four-momentum.
66013 P(I,5)=PYMASS(K(I,2))
66014 CALL PYPTDI(KFL1,PX2,PY2)
66017 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
66018 CALL PYZDIS(KFL1,KFL2,PR,Z)
66020 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
66022 MSTU(90)=MSTU(90)+1
66023 MSTU(90+MSTU(90))=I
66024 PARU(90+MSTU(90))=Z
66026 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
66027 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
66028 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
66029 & P(I,3).LE.0.001D0) THEN
66030 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
66036 C...Remaining flavour and momentum.
66045 C...Check if pL acceptable. Go back for new hadron if enough energy.
66046 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
66048 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
66050 IF(W.GT.PARJ(31)) GOTO 190
66053 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
66054 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
66056 C...Rotate jet to new direction.
66057 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
66058 PHI=PYANGL(P(IP1,1),P(IP1,2))
66060 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
66061 K(K(IP1,3),4)=NSAV1+1
66064 C...End of jet generation loop. Skip conservation in some cases.
66066 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
66067 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
66069 C...Subtract off produced hadron flavours, finished if zero.
66070 DO 240 I=NSAV+NJET+1,N
66072 KFLA=MOD(KFA/1000,10)
66073 KFLB=MOD(KFA/100,10)
66074 KFLC=MOD(KFA/10,10)
66076 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
66077 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
66079 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
66080 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
66081 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
66084 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66085 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66086 IF(NREQ.EQ.0) GOTO 320
66088 C...Take away flavour of low-momentum particles until enough freedom.
66092 DO 260 I=NSAV+NJET+1,N
66093 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
66094 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
66095 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
66097 IF(IREM.EQ.0) GOTO 150
66099 KFA=IABS(K(IREM,2))
66100 KFLA=MOD(KFA/1000,10)
66101 KFLB=MOD(KFA/100,10)
66102 KFLC=MOD(KFA/10,10)
66103 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
66104 IF(K(IREM,1).EQ.8) GOTO 250
66106 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
66107 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
66108 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
66110 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
66111 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
66112 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
66115 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66116 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66117 IF(NREQ.GT.NREM) GOTO 250
66118 DO 270 I=NSAV+NJET+1,N
66119 IF(K(I,1).EQ.8) K(I,1)=1
66122 C...Find combination of existing and new flavours for hadron.
66124 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
66125 IF(NREQ.LT.NREM) NFET=1
66126 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
66128 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
66129 KFLF(J)=ISIGN(1,NFL(1))
66130 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
66131 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
66133 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
66135 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
66136 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
66137 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
66138 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
66139 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
66140 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
66141 IF(NFET.LE.2) KFLF(3)=0
66142 IF(KFLF(3).NE.0) THEN
66143 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
66144 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
66145 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
66146 & KFLFC=KFLFC+ISIGN(2,KFLFC)
66150 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
66151 IF(KF.EQ.0) GOTO 280
66152 DO 300 J=1,MAX(2,NFET)
66153 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
66156 C...Store hadron at random among free positions.
66157 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
66158 DO 310 I=NSAV+NJET+1,N
66159 IF(K(I,1).EQ.7) NPOS=NPOS-1
66160 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
66163 P(I,5)=PYMASS(K(I,2))
66164 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66167 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66168 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66169 IF(NREM.GT.0) GOTO 280
66171 C...Compensate for missing momentum in global scheme (3 options).
66172 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
66175 DO 330 I=NSAV+NJET+1,N
66176 PSI(J)=PSI(J)+P(I,J)
66179 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
66181 DO 350 I=NSAV+NJET+1,N
66182 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
66183 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66184 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66185 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
66187 DO 370 I=NSAV+NJET+1,N
66188 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
66189 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66190 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66191 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
66193 P(I,J)=P(I,J)-PSI(J)*PW/PWS
66195 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66198 C...Compensate for missing momentum withing each jet separately.
66199 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
66200 DO 390 I=N+1,N+NJET
66206 DO 410 I=NSAV+NJET+1,N
66209 K(IR2,1)=K(IR2,1)+1
66210 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66211 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66213 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
66215 P(IR2,4)=P(IR2,4)+P(I,4)
66216 P(IR2,5)=P(IR2,5)+PLS
66219 DO 420 I=N+1,N+NJET
66220 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
66222 DO 440 I=NSAV+NJET+1,N
66225 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66226 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66228 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
66231 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66235 C...Scale momenta for energy conservation.
66236 IF(MOD(MSTJ(3),5).NE.0) THEN
66240 DO 450 I=NSAV+NJET+1,N
66243 PQS=PQS+P(I,5)**2/P(I,4)
66245 IF(PMS.GE.PECM) GOTO 150
66248 PFAC=(PECM-PQS)/(PES-PQS)
66251 DO 480 I=NSAV+NJET+1,N
66255 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66257 PQS=PQS+P(I,5)**2/P(I,4)
66259 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
66262 C...Origin of produced particles and parton daughter pointers.
66263 490 DO 500 I=NSAV+NJET+1,N
66264 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
66265 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
66267 DO 510 I=NSAV+1,NSAV+NJET
66270 IF(MSTU(16).NE.2) THEN
66274 K(I1,4)=K(I1,4)-NJET+1
66275 K(I1,5)=K(I1,5)-NJET+1
66276 IF(K(I1,5).LT.K(I1,4)) THEN
66283 C...Document independent fragmentation system. Remove copy of jets.
66294 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
66296 DO 540 I=NSAV+NJET,N
66298 K(I-NJET+1,J)=K(I,J)
66299 P(I-NJET+1,J)=P(I,J)
66300 V(I-NJET+1,J)=V(I,J)
66304 DO 550 IZ=MSTU90+1,MSTU(90)
66305 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
66308 C...Boost back particle system. Set production vertices.
66309 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
66310 &DPS(2)/DPS(4),DPS(3)/DPS(4))
66320 C*********************************************************************
66323 C...Handles the decay of unstable particles.
66325 SUBROUTINE PYDECY(IP)
66327 C...Double precision and integer declarations.
66328 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
66329 IMPLICIT INTEGER(I-N)
66330 INTEGER PYK,PYCHGE,PYCOMP
66332 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
66333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
66334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
66335 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
66336 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
66338 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
66339 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
66341 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66343 C...Functions: momentum in two-particle decays and four-product.
66344 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
66345 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)
66347 C...Initial values.
66351 KFS=ISIGN(1,K(IP,2))
66355 C...Choose lifetime and determine decay vertex.
66356 IF(K(IP,1).EQ.5) THEN
66358 ELSEIF(K(IP,1).NE.4) THEN
66359 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
66362 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
66365 C...Determine whether decay allowed or not.
66367 IF(MSTJ(22).EQ.2) THEN
66368 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
66369 ELSEIF(MSTJ(22).EQ.3) THEN
66370 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
66371 ELSEIF(MSTJ(22).EQ.4) THEN
66372 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
66373 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
66375 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
66380 C...Interface to external tau decay library (for tau polarization).
66381 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
66383 C...Starting values for pointers and momenta.
66387 PCMTAU(J)=P(ITAU,J)
66390 C...Iterate to find position and code of mother of tau.
66392 120 IMTAU=K(IMTAU,3)
66394 IF(IMTAU.EQ.0) THEN
66395 C...If no known origin then impossible to do anything further.
66399 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
66400 C...If tau -> tau + gamma then add gamma energy and loop.
66401 IF(K(K(IMTAU,4),2).EQ.22) THEN
66403 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
66405 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
66407 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
66412 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
66413 C...If coming from weak decay of hadron then W is not stored in record,
66414 C...but can be reconstructed by adding neutrino momentum.
66415 KFORIG=-ISIGN(24,K(ITAU,2))
66417 DO 160 II=K(IMTAU,4),K(IMTAU,5)
66418 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
66420 PCMTAU(J)=PCMTAU(J)+P(II,J)
66426 C...If coming from resonance decay then find latest copy of this
66427 C...resonance (may not completely agree).
66430 DO 170 II=IMTAU+1,IP-1
66431 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
66432 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
66435 PCMTAU(J)=P(IORIG,J)
66439 C...Boost tau to rest frame of production process (where known)
66440 C...and rotate it to sit along +z axis.
66442 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
66444 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
66445 & -DBETAU(2),-DBETAU(3))
66446 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
66447 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
66448 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
66449 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
66451 C...Call tau decay routine (if meaningful) and fill extra info.
66452 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66453 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
66454 DO 200 II=NSAV+1,NSAV+NDECAY
66463 C...Boost back decay tau and decay products.
66467 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66468 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
66469 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
66470 & DBETAU(2),DBETAU(3))
66472 C...Skip past ordinary tau decay treatment.
66480 C...B-Bbar mixing: flip sign of meson appropriately.
66482 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
66484 IF(KFA.EQ.531) XBBMIX=PARJ(77)
66485 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
66486 IF(MMIX.EQ.1) KFS=-KFS
66489 C...Check existence of decay channels. Particle/antiparticle rules.
66491 IF(MDCY(KC,2).GT.0) THEN
66492 MDMDCY=MDME(MDCY(KC,2),2)
66493 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
66495 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
66496 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
66499 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
66500 IF(KCHG(KC,3).EQ.0) THEN
66503 IF(PYR(0).GT.0.5D0) KFS=-KFS
66504 ELSEIF(KFS.GT.0) THEN
66512 C...Sum branching ratios of allowed decay channels.
66515 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
66516 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66517 & KFSN*MDME(IDL,1).NE.3) GOTO 230
66518 IF(MDME(IDL,2).GT.100) GOTO 230
66520 BRSU=BRSU+BRAT(IDL)
66523 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
66527 C...Select decay channel among allowed ones.
66528 240 RBR=BRSU*PYR(0)
66531 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66532 &KFSN*MDME(IDL,1).NE.3) THEN
66533 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66534 ELSEIF(MDME(IDL,2).GT.100) THEN
66535 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66539 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
66542 C...Start readout of decay channel: matrix element, reset counters.
66545 IF(MOD(NTRY,200).EQ.0) THEN
66546 WRITE(CIDC,'(I4)') IDC
66547 C...Do not print warning for some well-known special cases.
66548 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
66549 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
66553 IF(NTRY.GT.1000) THEN
66554 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66555 IF(MSTU(21).GE.1) RETURN
66561 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
66564 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
66566 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
66572 IF(KFA.GT.80) MHADDY=1
66573 C.. Random flavour and popcorn system memory.
66579 C...Read out decay products. Convert to standard flavour code.
66581 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
66583 IF(JT.LE.5) KP=KFDP(IDC,JT)
66584 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
66585 IF(KP.EQ.0) GOTO 280
66588 IF(KPA.GT.80) MHADDY=1
66589 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
66591 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
66593 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
66594 KFP=-KFS*MOD(KFA/10,10)
66595 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
66596 KFP=KFS*(100*MOD(KFA/10,100)+3)
66597 ELSEIF(KPA.EQ.81) THEN
66598 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
66599 ELSEIF(KP.EQ.82) THEN
66600 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
66601 IF(KFP.EQ.0) GOTO 260
66605 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
66606 ELSEIF(KP.EQ.-82) THEN
66609 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
66611 C...Add decay product to event record or to quark flavour list.
66614 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
66617 C...set rndmflav popcorn system pointer
66618 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
66620 PSQ=PSQ+PYMASS(KFLO(NQ))
66621 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
66622 & MOD(NQ,2).EQ.1) THEN
66627 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
66628 IF(K(I,2).EQ.0) GOTO 260
66630 P(I,5)=PYMASS(K(I,2))
66635 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
66636 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
66638 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
66639 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
66649 C...Check masses for resonance decays.
66650 IF(MHADDY.EQ.0) THEN
66651 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
66654 C...Choose decay multiplicity in phase space model.
66655 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
66657 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
66658 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
66660 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66661 IF(IRNDMO.EQ.0) THEN
66664 ELSEIF(IRNDMO.EQ.1) THEN
66669 IF(NTRY.GT.1000) THEN
66670 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66671 IF(MSTU(21).GE.1) RETURN
66673 IF(MMAT.LE.20) THEN
66674 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
66675 & SIN(PARU(2)*PYR(0))
66676 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
66677 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
66678 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
66679 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
66680 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
66684 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66686 IF(MSTU(121).GT.MSTU(125)) GOTO 300
66688 C...Form hadrons from flavour content.
66692 IF(ND.EQ.NP+NQ/2) GOTO 330
66693 DO 320 I=N+NP+1,N+ND-NQ/2
66694 C.. Stick to started popcorn system, else pick side at random
66696 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
66697 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
66698 IF(K(I,2).EQ.0) GOTO 300
66699 MSTU(125)=MSTU(125)-1
66701 IF(MSTU(121).GT.0) JTMO=JT
66707 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
66708 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
66709 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
66712 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
66713 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
66714 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
66715 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
66717 C...Check that sum of decay product masses not too large.
66719 DO 340 I=N+NP+1,N+ND
66724 P(I,5)=PYMASS(K(I,2))
66727 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
66729 C...Rescale energy to subtract off spectator quark mass.
66730 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
66731 & .AND.NP.GE.3) THEN
66733 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
66735 P(N+NP,J)=PQT*PV(1,J)
66736 PV(1,J)=(1D0-PQT)*PV(1,J)
66738 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
66742 C...Fully specified final state: check mass broadening effects.
66744 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
66748 C...Determine position of grandmother, number of sisters.
66754 IF(IM.LT.0.OR.IM.GE.IP) IM=0
66755 IF(IM.NE.0) KFAM=IABS(K(IM,2))
66757 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
66758 IF(K(IL,3).EQ.IM) NM=NM+1
66759 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
66761 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
66762 & MOD(KFAM/1000,10).NE.0) NM=0
66764 KFAS=IABS(K(ISIS,2))
66765 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
66766 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
66771 C...Kinematics of one-particle decays.
66779 C...Calculate maximum weight ND-particle decay.
66782 WTMAX=1D0/WTCOR(ND-2)
66783 PMAX=PV(1,5)-PS+P(N+ND,5)
66785 DO 380 IL=ND-1,1,-1
66786 PMAX=PMAX+P(N+IL,5)
66787 PMIN=PMIN+P(N+IL+1,5)
66788 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
66792 C...Find virtual gamma mass in Dalitz decay.
66793 390 IF(ND.EQ.2) THEN
66794 ELSEIF(MMAT.EQ.2) THEN
66795 PMES=4D0*PMAS(11,1)**2
66796 PMRHO2=PMAS(131,1)**2
66797 PGRHO2=PMAS(131,2)**2
66798 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
66799 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
66800 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
66801 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
66802 IF(WT.LT.PYR(0)) GOTO 400
66803 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
66805 C...M-generator gives weight. If rejected, try again.
66810 DO 420 IL2=IL1-1,1,-1
66811 IF(RSAV.LE.RORD(IL2)) GOTO 430
66812 RORD(IL2+1)=RORD(IL2)
66814 430 RORD(IL2+1)=RSAV
66818 DO 450 IL=ND-1,1,-1
66819 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
66821 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66823 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
66826 C...Perform two-particle decays in respective CM frame.
66827 460 DO 480 IL=1,ND-1
66828 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66829 UE(3)=2D0*PYR(0)-1D0
66831 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
66832 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
66835 PV(IL+1,J)=-PA*UE(J)
66837 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
66838 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
66841 C...Lorentz transform decay products to lab frame.
66845 DO 530 IL=ND-1,1,-1
66847 BE(J)=PV(IL,J)/PV(IL,4)
66849 GA=PV(IL,4)/PV(IL,5)
66851 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
66853 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
66855 P(I,4)=GA*(P(I,4)+BEP)
66859 C...Check that no infinite loop in matrix element weight.
66861 IF(NTRY.GT.800) GOTO 560
66863 C...Matrix elements for omega and phi decays.
66865 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
66866 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
66867 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
66868 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
66870 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66871 ELSEIF(MMAT.EQ.2) THEN
66872 FOUR12=FOUR(N+1,N+2)
66873 FOUR13=FOUR(N+1,N+3)
66874 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
66875 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
66876 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
66878 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66879 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66880 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66881 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
66883 FOUR12=FOUR(IP,N+1)
66884 FOUR02=FOUR(IM,N+1)
66888 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
66889 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
66890 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
66891 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
66892 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
66893 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
66895 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66896 ELSEIF(MMAT.EQ.4) THEN
66897 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66898 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
66899 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
66900 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
66901 & ((1D0-HX3)/(HX1*HX2))**2
66902 IF(WT.LT.2D0*PYR(0)) GOTO 390
66903 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
66906 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66907 ELSEIF(MMAT.EQ.41) THEN
66908 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66909 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
66910 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
66911 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
66913 C...Matrix elements for weak decays (only semileptonic for c and b)
66914 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66915 & .AND.ND.EQ.3) THEN
66916 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
66917 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
66918 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66919 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
66923 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
66926 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
66927 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
66928 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66931 C...Scale back energy and reattach spectator.
66932 560 IF(MREM.EQ.1) THEN
66934 PV(1,J)=PV(1,J)/(1D0-PQT)
66940 C...Low invariant mass for system with spectator quark gives particle,
66941 C...not two jets. Readjust momenta accordingly.
66942 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
66944 PM2=PYMASS(K(N+2,2))
66946 PM3=PYMASS(K(N+3,2))
66947 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
66948 & (PARJ(32)+PM2+PM3)**2) GOTO 630
66951 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
66952 IF(K(N+2,2).EQ.0) GOTO 260
66953 P(N+2,5)=PYMASS(K(N+2,2))
66954 PS=P(N+1,5)+P(N+2,5)
66959 ELSEIF(MMAT.EQ.44) THEN
66961 PM3=PYMASS(K(N+3,2))
66963 PM4=PYMASS(K(N+4,2))
66964 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
66965 & (PARJ(32)+PM3+PM4)**2) GOTO 600
66968 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
66969 IF(K(N+3,2).EQ.0) GOTO 260
66970 P(N+3,5)=PYMASS(K(N+3,2))
66972 P(N+3,J)=P(N+3,J)+P(N+4,J)
66974 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)
66975 HA=P(N+1,4)**2-P(N+2,4)**2
66976 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
66977 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
66978 & (P(N+1,3)-P(N+2,3))**2
66979 HD=(PV(1,4)-P(N+3,4))**2
66980 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
66983 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
66985 PCOR=HH*(P(N+1,J)-P(N+2,J))
66986 P(N+1,J)=P(N+1,J)+PCOR
66987 P(N+2,J)=P(N+2,J)-PCOR
66989 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)
66990 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)
66994 C...Check invariant mass of W jets. May give one particle or start over.
66995 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66996 &.AND.IABS(K(N+1,2)).LT.10) THEN
66997 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
66999 PM1=PYMASS(K(N+1,2))
67001 PM2=PYMASS(K(N+2,2))
67002 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
67003 KFLDUM=INT(1.5D0+PYR(0))
67004 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
67005 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
67006 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
67007 PSM=PYMASS(KF1)+PYMASS(KF2)
67008 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
67009 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
67010 IF(MMAT.EQ.48) GOTO 390
67011 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
67014 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
67015 IF(K(N+1,2).EQ.0) GOTO 260
67016 P(N+1,5)=PYMASS(K(N+1,2))
67019 PS=P(N+1,5)+P(N+2,5)
67020 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
67027 C...Phase space decay of partons from W decay.
67028 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
67034 PV(1,J)=P(N+1,J)+P(N+2,J)
67043 PSQ=PYMASS(KFLO(1))
67045 PSQ=PSQ+PYMASS(KFLO(2))
67050 C...Boost back for rapidly moving particle.
67054 BE(J)=P(IP,J)/P(IP,4)
67058 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
67060 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
67062 P(I,4)=GA*(P(I,4)+BEP)
67066 C...Fill in position of decay vertex.
67074 C...Set up for parton shower evolution from jets.
67075 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
67079 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67080 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67081 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67082 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67083 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67084 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67086 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
67089 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67090 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
67091 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
67092 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67094 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67095 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
67098 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67099 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
67100 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
67101 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67103 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67104 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
67106 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
67111 KCP=PYCOMP(K(NSAV+1,2))
67112 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
67114 IF(KQP.LT.0) JCON=5
67115 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
67116 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
67117 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
67118 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
67120 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
67123 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
67124 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67125 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67126 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
67130 C...Mark decayed particle; special option for B-Bbar mixing.
67131 IF(K(IP,1).EQ.5) K(IP,1)=15
67132 IF(K(IP,1).LE.10) K(IP,1)=11
67133 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
67141 C*********************************************************************
67144 C...Handles flavour production in the decay of unstable particles
67145 C...and small string clusters.
67147 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
67149 C...Double precision and integer declarations.
67150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67151 IMPLICIT INTEGER(I-N)
67152 INTEGER PYK,PYCHGE,PYCOMP
67154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67155 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67156 SAVE /PYDAT1/,/PYDAT2/
67159 C.. Call PYKFDI directly if no popcorn option is on
67160 IF(MSTJ(12).LT.2) THEN
67161 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67168 IF(KFL1.EQ.0) RETURN
67173 NMAX=MIN(MSTU(125),10)
67175 C.. Identify rank 0 cluster qq
67177 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
67180 C.. Join jets: Fails if store not empty
67181 IF(MSTU(121).GT.0) THEN
67185 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67186 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
67187 C.. Pick popcorn meson from store, return same qq, decrease store
67188 KF=MSTU(NSTO+MSTU(121))
67190 MSTU(121)=MSTU(121)-1
67192 C.. Generate new flavour. Then done if no diquark is generated
67193 100 CALL PYKFDI(KFL1,0,KFL3,KF)
67194 IF(MSTU(121).EQ.-1) GOTO 100
67196 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
67198 C.. Simple case if no dynamical popcorn suppressions are considered
67199 IF(MSTJ(12).LT.4) THEN
67200 IF(MSTU(121).EQ.0) RETURN
67203 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67204 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67205 IF(IABS(KFL3).LE.10)THEN
67212 C test output qq against fake Gamma, then return if no popcorn.
67215 CALL PYZDIS(1,2103,5D0,Z)
67217 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
67222 IF(MSTU(121).EQ.0) RETURN
67224 C..Set store size memory. Pick fake dynamical variables of qq.
67226 CALL PYPTDI(1,PX3,PY3)
67232 C.. Pick next popcorn meson, test with fake dynamical variables
67236 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67237 IF(MSTU(121).EQ.-1) GOTO 100
67238 CALL PYPTDI(KFL3,PX3,PY3)
67239 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
67240 CALL PYZDIS(KFPREV,KFL3,PM,Z)
67247 IF(MSTJ(12).GT.4)THEN
67248 POPMN=SQRT((1D0-X)*(G/X-GB))
67249 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
67250 PTST=EXP((POPM-POPMN)*PARF(193))
67255 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
67258 IF(RTST.GT.PTST*GTST)THEN
67260 IF(RTST.GT.PTST) MSTU(121)=-1
67265 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
67266 IF(MSTU(121).GT.0) GOTO 110
67268 C.. Test accepted system size. If OK set global popcorn size variable.
67269 IF(NMES.GT.NMAX)THEN
67280 C********************************************************************
67283 C...Generates a new flavour pair and combines off a hadron
67285 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
67287 C...Double precision and integer declarations.
67288 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67289 IMPLICIT INTEGER(I-N)
67290 INTEGER PYK,PYCHGE,PYCOMP
67292 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67293 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67294 SAVE /PYDAT1/,/PYDAT2/
67298 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
67300 C...Default flavour values. Input consistency checks.
67305 IF(KF1A.EQ.0) RETURN
67307 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
67308 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
67309 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
67312 C...Check if tabulated flavour probabilities are to be used.
67313 IF(MSTJ(15).EQ.1) THEN
67314 IF(MSTJ(12).GE.5) CALL PYERRM(29,
67315 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67316 & ' together with MSTJ(12)>=5 modification')
67318 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
67319 KFL1A=MOD(KF1A/1000,10)
67320 KFL1B=MOD(KF1A/100,10)
67322 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
67323 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
67324 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
67325 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
67329 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
67330 KFL2A=MOD(KF2A/1000,10)
67331 KFL2B=MOD(KF2A/100,10)
67333 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
67334 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
67335 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
67337 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
67340 C.. Recognize rank 0 diquark case
67342 KFDIQ=MAX(KF1A,KF2A)
67343 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
67345 C.. Join two flavours to meson or baryon. Test for popcorn.
67348 IF(KFDIQ.GT.10) THEN
67349 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
67350 & CALL PYNMES(KFDIQ)
67351 IF(MSTU(121).NE.0) THEN
67362 C.. Separate incoming flavours, curtain flavour consistency check
67368 KFL1A=MOD(KF1A/1000,10)
67369 KFL1B=MOD(KF1A/100,10)
67372 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
67373 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
67374 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
67376 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
67380 KFQOLD=KFL1A+KFL1B-KFQPOP
67383 C...Meson/baryon choice. Set number of mesons if starting a popcorn
67386 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
67387 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
67391 ELSEIF(KF1A.GT.10)THEN
67393 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
67394 IF(MSTU(121).GT.0) MBARY=-1
67397 C..x->H+q: Choose single vertex quark. Jump to form hadron.
67398 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
67399 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
67400 KFL3=ISIGN(KFQVER,-KFIN)
67404 C..x->H+qq: (IDW=proper PARF position for diquark weights)
67407 IF(MSTU(121).EQ.0) IDW=150
67409 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
67410 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
67411 C.. Shift to s-curtain parameters if needed
67412 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
67413 PARF(194)=PARF(138)*PARF(139)
67414 PARF(193)=PARJ(8)+PARJ(9)
67418 C.. x->H+qq: Get vertex quark
67419 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67421 MSTU(121)=MSTU(121)-1
67422 IF(IDW.EQ.170) THEN
67423 IF(MSTU(121).EQ.0)THEN
67424 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
67426 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
67429 IF(MSTU(121).EQ.0)THEN
67430 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
67432 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
67438 RMES=PYR(0)*PARF(194)
67440 RMES=RMES-PARF(IPOS+IMES)
67441 IF(IMES.EQ.30) THEN
67446 IF(RMES.GT.0D0) GOTO 120
67449 IF(KMUL.EQ.2) KFJ=10003
67450 IF(KMUL.EQ.3) KFJ=10001
67451 IF(KMUL.EQ.4) KFJ=20003
67452 IF(KMUL.EQ.5) KFJ=5
67454 KFQVER=MOD(IMES,5)+1
67455 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
67456 IF(KFQVER.GT.3)THEN
67461 IF(MBARY.EQ.-1) IDW=170
67463 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
67464 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
67465 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
67466 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
67468 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
67472 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67474 IF(KFQPOP.NE.KFQVER)THEN
67476 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
67477 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
67478 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
67480 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
67482 KFL3=ISIGN(KFDIQ,KFIN)
67484 C..x->M+y: flavour for meson.
67485 130 IF(MBARY.LE.0)THEN
67486 KFLA=MAX(KFQOLD,KFQVER)
67487 KFLB=MIN(KFQOLD,KFQVER)
67489 IF(KFLA.NE.KFQOLD) KFS=-KFS
67490 C... Form meson, with spin and flavour mixing for diagonal states.
67491 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67492 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
67493 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
67496 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
67497 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
67498 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
67499 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
67500 IF(PYR(0).LT.PARJ(14)) KMUL=2
67501 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
67503 IF(RMUL.LT.PARJ(15)) KMUL=3
67504 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
67505 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
67508 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
67509 IF(KMUL.EQ.5) KFLS=5
67510 IF(KFLA.NE.KFLB)THEN
67511 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
67514 IMIX=2*KFLA+10*KMUL
67515 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
67516 & INT(RMIX+PARF(IMIX)))+KFLS
67517 IF(KFLA.GE.4) KF=110*KFLA+KFLS
67519 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
67520 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
67522 C..Optional extra suppression of eta and eta'.
67523 C..Allow shift to qq->B+q in old version (set IRANK to 0)
67524 IF(KF.EQ.221.OR.KF.EQ.331)THEN
67525 IF(PYR(0).GT.PARJ(25+KF/300))THEN
67526 IF(KF2A.GT.0) GOTO 130
67527 IF(MSTJ(12).LT.4) IRANK=0
67533 C.. x->B+y: Flavour for baryon
67536 IF(KF1A.LE.10) KFLA=KFQOLD
67537 KFLB=MOD(KFDIQ/1000,10)
67538 KFLC=MOD(KFDIQ/100,10)
67539 KFLDS=MOD(KFDIQ,10)
67540 KFLD=MAX(KFLA,KFLB,KFLC)
67541 KFLF=MIN(KFLA,KFLB,KFLC)
67542 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67544 C... SU(6) factors for formation of baryon.
67548 IF(KFLB.NE.KFLC)THEN
67551 IF(KFLB.GT.2) KDMAX=KDMAX+2
67553 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
67558 SU6MAX=PARF(140+KDMAX)
67561 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
67566 SU6OCT=PARF(60+KBARY)
67567 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
67568 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
67569 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
67571 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
67573 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
67575 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67576 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
67578 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
67582 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67585 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
67586 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
67588 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
67590 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
67591 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
67593 C -------------------------------------------------------------------------
67594 C Extracted from a private e-mail exchange with Torbjorn Sjostrand
67596 C No, Lambda(1520) is not included and not foreseen.
67597 C So if you want it in Pythia, it would have to be a hack.
67598 C What you could do is:
67599 C 1) In PYKFDI, just before the RETURN above label 140, you could check if
67600 C a Lambda, Sigma0 or Sigma*0 has been produced, and with some small
67601 C probability switch such a particle to the Lambda(1520) code. That is,
67602 C if KF = 3122, 3212, or 3214 and a random number below some number, switch
67603 C to KF = 3124. (And correspondingly for anticparticles.)
67604 C 2) Use the PYUPDA routine (see manual) to include particle and decay data
67605 C for the Lambda(1520).
67606 C -------------------------------------------------------------------------
67608 IF (IABS(KF).EQ.3122) THEN
67609 C Converting a fraction (0.20) of Lambda0 to Lambda(1520) + c.c.
67610 C This fraction is based on the experimental measurement at ISR
67611 C Bobbink 83, NP B217,11 (1983)
67612 C The region 0.5 < XF < 1.0 has been extrapolated to XF=0
67613 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
67616 IF(IABS(KF).EQ.3212) THEN
67617 C Converting a fraction (0.20) of Sigma0 to Lambda(1520) + c.c.
67618 C We suppose the same fraction as for Lambda0
67619 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
67622 IF (IABS(KF).EQ.3214) THEN
67623 C Converting a fraction (0.30) of Sigma0(1385) to Lambda(1520) + c.c.
67624 C This is conservative extimate supposing that the ratio
67625 C scales as (M_Sigma1385/M_Lambda0)^2 ~ 1.5
67626 IF(PYR(0).LE.0.30) KF=ISIGN(3124,KF)
67630 C...Use tabulated probabilities to select new flavour and hadron.
67631 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
67634 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
67637 ELSEIF(KTAB2.EQ.0) THEN
67646 DO 150 KT3=KT3L,KT3U
67647 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
67653 DO 170 KT3=KT3L,KT3U
67655 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
67656 IF(RFL.LE.0D0) GOTO 190
67661 C...Reconstruct flavour of produced quark/diquark.
67662 IF(KTAB3.LE.6) THEN
67665 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
67668 IF(KTAB3.GE.8) KFL3A=2
67669 IF(KTAB3.GE.11) KFL3A=3
67670 IF(KTAB3.GE.16) KFL3A=4
67671 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
67672 KFL3=1000*KFL3A+100*KFL3B+1
67673 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
67675 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
67678 C...Reconstruct meson code.
67679 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
67681 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67682 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
67684 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
67685 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67686 & 25*KTABS)) KF=330+2*KTABS+1
67687 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
67688 KFLA=MAX(KTAB1,KTAB3)
67689 KFLB=MIN(KTAB1,KTAB3)
67691 IF(KFLA.NE.KF1A) KFS=-KFS
67692 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67693 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
67695 IF(KFL1A.EQ.KFL3A) THEN
67696 KFLA=MAX(KFL1B,KFL3B)
67697 KFLB=MIN(KFL1B,KFL3B)
67698 IF(KFLA.NE.KFL1B) KFS=-KFS
67699 ELSEIF(KFL1A.EQ.KFL3B) THEN
67703 ELSEIF(KFL1B.EQ.KFL3A) THEN
67706 ELSEIF(KFL1B.EQ.KFL3B) THEN
67707 KFLA=MAX(KFL1A,KFL3A)
67708 KFLB=MIN(KFL1A,KFL3A)
67709 IF(KFLA.NE.KFL1A) KFS=-KFS
67711 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
67714 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67716 C...Reconstruct baryon code.
67718 IF(KTAB1.GE.7) THEN
67727 KFLD=MAX(KFLA,KFLB,KFLC)
67728 KFLF=MIN(KFLA,KFLB,KFLC)
67729 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67730 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
67731 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
67734 C...Check that constructed flavour code is an allowed one.
67735 IF(KFL2.NE.0) KFL3=0
67738 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
67746 C*********************************************************************
67749 C...Generates number of popcorn mesons and stores some relevant
67752 SUBROUTINE PYNMES(KFDIQ)
67754 C...Double precision and integer declarations.
67755 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67756 IMPLICIT INTEGER(I-N)
67757 INTEGER PYK,PYCHGE,PYCOMP
67759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67760 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67761 SAVE /PYDAT1/,/PYDAT2/
67764 IF(MSTJ(12).LT.2) RETURN
67766 C..Old version: Get 1 or 0 popcorn mesons
67767 IF(MSTJ(12).LT.5)THEN
67769 IF(KFDIQ.NE.0) THEN
67771 KFA=MOD(KFDIQA/1000,10)
67772 KFB=MOD(KFDIQA/100,10)
67775 IF(KFA.EQ.3) POPWT=PARF(133)
67776 IF(KFB.EQ.3) POPWT=PARF(134)
67777 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
67779 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
67783 C..New version: Store popcorn- or rank 0 diquark parameters
67786 PARF(194)=PARF(139)
67787 IF(KFDIQ.NE.0) THEN
67790 PARF(194)=PARF(140)
67792 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
67793 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
67794 & '(PYNMES:) Neglecting too large popcorn possibility')
67798 C..New version: Get number of popcorn mesons
67801 110 MSTU(121)=MSTU(121)+1
67802 RTST=RTST/PARF(194)
67803 IF(RTST.LT.1D0) GOTO 110
67804 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
67805 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
67809 C***************************************************************
67812 C...Precalculates a set of diquark and popcorn weights.
67816 C...Double precision and integer declarations.
67817 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67818 IMPLICIT INTEGER(I-N)
67819 INTEGER PYK,PYCHGE,PYCOMP
67821 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67822 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67823 SAVE /PYDAT1/,/PYDAT2/
67825 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
67829 C..Diquark indices for dimensional variables
67838 C.. *** SU(6) factors **
67839 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67841 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
67842 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
67843 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67846 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
67848 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
67849 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
67851 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
67852 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
67855 C..SU(6)max q q' s,c,b
67856 SU6MUD =MAX(SU6(1) , SU6(8) )
67857 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
67858 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
67859 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
67860 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
67861 SU6M(IUS0)=SU6M(ISU0)
67862 SU6M(ISS1)=SU6M(IUU1)
67863 SU6M(IUS1)=SU6M(ISU1)
67865 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67867 PARF(142)=SU6M(IUD1)
67868 PARF(143)=SU6M(ISU0)
67869 PARF(144)=SU6M(ISU1)
67870 PARF(145)=SU6M(ISS1)
67872 C..diquark SU(6) survival =
67873 C..sum over quark (quark tunnel weight)*(SU(6)).
67874 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
67875 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
67876 DMB(IUS0)=DMB(ISU0)
67877 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
67878 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
67879 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
67880 DMB(IUS1)=DMB(ISU1)
67881 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
67883 C.. *** Tunneling factors for Diquark production***
67884 C.. T: half a curtain pair = sqrt(curtain pair factor)
67885 IF(MSTJ(12).GE.5) THEN
67887 PMUD1=PYMASS(2103)-PMUD0
67888 PMUS0=PYMASS(3201)-PMUD0
67889 PMUS1=PYMASS(3203)-PMUS0-PMUD0
67890 PMSS1=PYMASS(3303)-PMUS0-PMUD0
67891 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
67892 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
67893 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
67894 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
67895 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
67896 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
67897 QBB(IUD1)=QBB(IUU1)
67899 PAR2M=SQRT(PARJ(2))
67900 PAR3M=SQRT(PARJ(3))
67901 PAR4M=SQRT(PARJ(4))
67902 QBB(ISU0)=PAR2M*PAR3M
67904 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
67906 QBB(ISU1)=PAR4M*QBB(ISU0)
67907 QBB(IUS1)=PAR4M*QBB(IUS0)
67911 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67912 QBM(ISU0)=QBB(ISU0)
67913 QBM(IUS0)=PARJ(2)*QBB(IUS0)
67914 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
67915 QBM(IUU1)=6D0*QBB(IUU1)
67916 QBM(ISU1)=3D0*QBB(ISU1)
67917 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
67918 QBM(IUD1)=3D0*QBB(IUD1)
67920 C.. Combine T and tau to diquark weight for q-> B+B+..
67922 QBB(I)=QBB(I)*QBM(I)
67925 IF(MSTJ(12).GE.5)THEN
67926 C..New version: tau for rank 0 diquark.
67927 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
67928 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
67929 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
67930 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
67931 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
67932 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
67933 DMB(7+IUD1)=DMB(7+IUU1)/2D0
67935 C..New version: curtain flavour ratios.
67936 C.. s/u for q->B+M+...
67937 C.. s/u for rank 0 diquark: su -> ...M+B+...
67938 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67939 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67940 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67941 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
67942 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
67943 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
67944 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
67946 C..Old version: reset unused rank 0 diquark weights and
67947 C.. unused diquark SU(6) survival weights
67949 IF(MSTJ(12).LT.3) DMB(I)=1D0
67953 C..Old version: Shuffle PARJ(7) into tau
67954 QBM(IUS0)=QBM(IUS0)*PARJ(7)
67955 QBM(ISS1)=QBM(ISS1)*PARJ(7)
67956 QBM(IUS1)=QBM(IUS1)*PARJ(7)
67958 C..Old version: curtain flavour ratios.
67959 C.. s/u for q->B+M+...
67960 C.. s/u for rank 0 diquark: su -> ...M+B+...
67961 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67962 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67963 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67964 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
67965 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
67968 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67969 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67971 DMB(7+I)=DMB(7+I)*DMB(I)
67972 DMB(I)=DMB(I)*QBM(I)
67973 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
67974 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
67977 C.. *** Popcorn factors ***
67979 IF(MSTJ(12).LT.5)THEN
67980 C.. Old version: Resulting popcorn weights.
67982 WS=PARF(135)*PARF(138)
67984 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
67986 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
67987 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
67988 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
67989 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
67990 & (1D0+QBB(IUD1)+QBB(IUU1)+
67991 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
67993 C..New version: Store weights for popcorn mesons,
67994 C..get prel. popcorn weights.
67995 DO 150 IPOS=201,1400
68004 IF(MR.EQ.7) PARF(193)=PARJ(10)
68005 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
68006 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
68007 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
68009 IF(NMES.EQ.1) SQWT=PARJ(2)
68011 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
68012 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
68013 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
68015 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
68016 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
68019 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
68021 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
68022 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
68028 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
68029 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
68030 IF(PJWT.LE.0D0) GOTO 190
68031 IF(PJWT.GT.1D0) PJWT=1D0
68033 IMIX=2*KFQOLD+10*KMUL
68035 IF(KMUL.EQ.2) KFJ=10003
68036 IF(KMUL.EQ.3) KFJ=10001
68037 IF(KMUL.EQ.4) KFJ=20003
68038 IF(KMUL.EQ.5) KFJ=5
68040 KFLA=MAX(KFQOLD,KFQVER)
68041 KFLB=MIN(KFQOLD,KFQVER)
68042 SWT=PARJ(11+KFLA/3+KFLA/4)
68043 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
68045 QWT=SQWT/(2D0+SQWT)
68046 IF(KFQVER.LT.3)THEN
68047 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
68048 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
68050 IF(KFQVER.NE.KFQOLD)THEN
68052 KFM=100*KFLA+10*KFLB+KFJ
68053 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68054 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
68055 WTTOT=WTTOT+PARF(IPOS+IMES)
68058 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
68059 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
68060 IF(ID.EQ.5) DWT=PARF(IMIX)
68062 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68063 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
68064 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
68065 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
68066 PARF(IPOS+5*KMUL+ID)=
68067 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
68069 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
68075 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
68077 IF(MR.EQ.7) PARF(140)=
68078 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
68079 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
68080 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
68086 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
68091 C..Recombine diquark weights to flavour and spin ratios
68092 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
68093 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
68094 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
68095 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
68096 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
68097 PARF(155)=QBB(ISU1)/QBB(ISU0)
68098 PARF(156)=QBB(IUS1)/QBB(IUS0)
68099 PARF(157)=QBB(IUD1)
68101 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
68102 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
68103 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
68104 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
68105 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
68106 PARF(165)=QBM(ISU1)/QBM(ISU0)
68107 PARF(166)=QBM(IUS1)/QBM(IUS0)
68108 PARF(167)=QBM(IUD1)
68110 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
68111 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
68112 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
68113 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
68114 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
68115 PARF(175)=DMB(ISU1)/DMB(ISU0)
68116 PARF(176)=DMB(IUS1)/DMB(IUS0)
68117 PARF(177)=DMB(IUD1)
68119 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
68120 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
68121 PARF(187)=DMB(7+IUD1)
68127 C*********************************************************************
68130 C...Generates transverse momentum according to a Gaussian.
68132 SUBROUTINE PYPTDI(KFL,PX,PY)
68134 C...Double precision and integer declarations.
68135 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68136 IMPLICIT INTEGER(I-N)
68137 INTEGER PYK,PYCHGE,PYCOMP
68139 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68142 C...Generate p_T and azimuthal angle, gives p_x and p_y.
68144 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
68145 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
68146 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
68147 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
68155 C*********************************************************************
68158 C...Generates the longitudinal splitting variable z.
68160 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
68162 C...Double precision and integer declarations.
68163 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68164 IMPLICIT INTEGER(I-N)
68165 INTEGER PYK,PYCHGE,PYCOMP
68167 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68168 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68169 SAVE /PYDAT1/,/PYDAT2/
68171 C...Check if heavy flavour fragmentation.
68175 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
68177 C...Lund symmetric scaling function: determine parameters of shape.
68178 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
68179 &MSTJ(11).GE.4) THEN
68181 IF(MSTJ(91).EQ.1) FA=PARJ(43)
68182 IF(KFLB.GE.10) FA=FA+PARJ(45)
68184 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
68187 IF(KFLA.GE.10) FC=FC-PARJ(45)
68188 IF(KFLB.GE.10) FC=FC+PARJ(45)
68189 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
68191 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
68192 FC=FC+FRED*FBB*PARF(100+KFLH)**2
68195 IF(ABS(FC-1D0).GT.0.01D0) MC=2
68197 C...Determine position of maximum. Special cases for a = 0 or a = c.
68198 IF(FA.LT.0.02D0) THEN
68201 IF(FC.GT.FB) ZMAX=FB/FC
68202 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
68207 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
68208 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
68211 C...Subdivide z range if distribution very peaked near endpoint.
68213 IF(ZMAX.LT.0.1D0) THEN
68219 ZDIVC=ZDIV**(1D0-FC)
68220 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
68222 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
68224 FSCB=SQRT(4D0+(FC/FB)**2)
68225 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
68226 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
68227 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
68228 FINT=1D0+FB*(1D0-ZDIV)
68231 C...Choice of z, preweighted for peaks at low or high z.
68235 IF(FINT*PYR(0).LE.1D0) THEN
68237 ELSEIF(MC.EQ.1) THEN
68241 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
68244 ELSEIF(MMAX.EQ.3) THEN
68245 IF(FINT*PYR(0).LE.1D0) THEN
68247 FPRE=EXP(FB*(Z-ZDIV))
68249 Z=ZDIV+Z*(1D0-ZDIV)
68253 C...Weighting according to correct formula.
68254 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
68255 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
68256 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
68257 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
68258 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
68260 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68262 FC=PARJ(50+MAX(1,KFLH))
68263 IF(MSTJ(91).EQ.1) FC=PARJ(59)
68265 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
68266 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
68267 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
68268 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
68271 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
68272 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
68279 C*********************************************************************
68282 C...Generates timelike parton showers from given partons.
68284 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
68286 C...Double precision and integer declarations.
68287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68288 IMPLICIT INTEGER(I-N)
68289 INTEGER PYK,PYCHGE,PYCOMP
68290 C...Parameter statement to help give large particle numbers.
68291 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68292 &KEXCIT=4000000,KDIMEN=5000000)
68293 PARAMETER (MAXNUR=1000)
68295 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
68296 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68297 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68298 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68299 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68300 COMMON/PYINT1/MINT(400),VINT(400)
68301 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
68303 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
68304 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
68305 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
68306 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
68309 C...Check that QMAX not too low.
68310 IF(MSTJ(41).LE.0) THEN
68312 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
68313 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
68315 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
68319 C...Store positions of shower initiating partons.
68321 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
68324 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
68329 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
68330 & .AND.IP2.GE.-80) THEN
68335 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
68343 & '(PYSHOW:) failed to reconstruct showering system')
68344 IF(MSTU(21).GE.1) RETURN
68347 C...Send off to PYPTFS for pT-ordered evolution if requested,
68348 C...if at least 2 partons, and without predefined shower branchings.
68349 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
68354 PTPART(II)=0.5D0*QMAX
68356 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
68360 C...Initialization of cutoff masses etc.
68368 PMTH(1,21)=PYMASS(21)
68369 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
68370 PMTH(3,21)=2D0*PMTH(2,21)
68371 PMTH(4,21)=PMTH(3,21)
68372 PMTH(5,21)=PMTH(3,21)
68373 PMTH(1,22)=PYMASS(22)
68374 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
68375 PMTH(3,22)=2D0*PMTH(2,22)
68376 PMTH(4,22)=PMTH(3,22)
68377 PMTH(5,22)=PMTH(3,22)
68379 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
68380 PMQT1E=MIN(PMQTH1,PARJ(90))
68382 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
68383 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
68386 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
68388 PMTH(1,IFL)=PYMASS(IFL)
68389 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
68390 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
68391 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68392 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68395 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
68396 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
68397 PMTH(1,IFL)=PYMASS(IFL)
68398 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
68399 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
68400 PMTH(4,IFL)=PMTH(3,IFL)
68401 PMTH(5,IFL)=PMTH(3,IFL)
68403 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
68405 ALFM=LOG(PT2MIN/ALAMS)
68407 C...Check on phase space available for emission.
68415 KFLA(I)=IABS(K(IPA(I),2))
68417 C...Special cutoff masses for initial partons (may be a heavy quark,
68418 C...squark, ..., and need not be on the mass shell).
68420 IF(NPA.LE.1) IREF(I)=IR
68421 IF(NPA.GE.2) IREF(I+1)=IR
68425 IF(KFLA(I).LE.8) THEN
68427 IF(MSTJ(41).GE.2) ISCHG(IR)=1
68428 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
68429 & KFLA(I).EQ.17) THEN
68430 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
68431 ELSEIF(KFLA(I).EQ.21) THEN
68433 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
68434 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
68436 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
68439 C...same for QQ~[3S18]
68440 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
68441 & KFLA(I).EQ.9900553)) THEN
68446 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68447 C...(only intended for studying the effects of switching such rad on/off)
68448 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
68453 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
68455 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
68456 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
68457 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
68458 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68459 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68460 ELSEIF(ISCOL(IR).EQ.1) THEN
68461 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
68462 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
68463 PMTH(4,IR)=PMTH(3,IR)
68464 PMTH(5,IR)=PMTH(3,IR)
68465 ELSEIF(ISCHG(IR).EQ.1) THEN
68466 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
68467 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
68468 PMTH(4,IR)=PMTH(3,IR)
68469 PMTH(5,IR)=PMTH(3,IR)
68471 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
68473 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
68475 PS(J)=PS(J)+P(IPA(I),J)
68478 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
68479 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
68480 IF(NPA.EQ.1) PS(5)=PS(4)
68481 IF(PS(5).LE.PM+PMQT1E) RETURN
68483 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68486 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
68487 KFSRCE=IABS(K(K(IP1,3),2))
68489 IPAR1=MAX(1,K(IP1,3))
68490 IPAR2=MAX(1,K(IP2,3))
68491 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
68492 & KFSRCE=IABS(K(K(IPAR1,3),2))
68495 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
68496 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
68497 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
68498 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
68499 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
68500 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
68501 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
68502 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
68504 C...Identify two primary showerers.
68506 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
68507 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
68508 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
68509 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
68510 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
68511 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
68512 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
68513 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
68515 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
68516 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
68517 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
68518 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
68519 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
68520 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
68521 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
68522 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
68524 C...Order of showerers. Presence of gluino.
68525 ITYPMN=MIN(ITYPE1,ITYPE2)
68526 ITYPMX=MAX(ITYPE1,ITYPE2)
68528 IF(ITYPE1.GT.ITYPE2) IORD=2
68530 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
68532 C...Check if 3-jet matrix elements to be used.
68535 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
68536 IF(MSTJ(38).NE.0) THEN
68540 ELSEIF(MSTJ(47).GE.6) THEN
68546 C...Vector/axial vector -> q + qbar; q -> q + V.
68547 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
68548 & ITYPES.EQ.3)) THEN
68550 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
68552 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
68553 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
68554 C...gamma*/Z0: assume e+e- initial state if unknown.
68556 IF(KFSRCE.EQ.23) THEN
68557 IANNFL=K(K(IP1,3),3)
68558 IF(IANNFL.NE.0) THEN
68559 KANNFL=IABS(K(IANNFL,2))
68560 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
68563 AI=SIGN(1D0,EI+0.1D0)
68564 VI=AI-4D0*EI*PARU(102)
68565 EF=KCHG(KFLA(1),1)/3D0
68566 AF=SIGN(1D0,EF+0.1D0)
68567 VF=AF-4D0*EF*PARU(102)
68568 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
68571 SQWZ=PS(5)*PMAS(23,2)
68572 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
68573 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
68574 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
68575 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
68577 ALPHA=VECT/(VECT+AXIV)
68578 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
68581 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68582 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
68584 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68585 & ITYPES.EQ.1)) THEN
68588 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68589 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
68591 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
68593 ELSEIF(KFSRCE.EQ.36) THEN
68596 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68597 & ITYPES.EQ.1)) THEN
68600 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68601 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68602 & ITYPES.EQ.3)) THEN
68604 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68605 & ITYPES.EQ.2)) THEN
68607 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
68609 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68610 & ITYPES.EQ.2)) THEN
68613 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68614 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68615 & ITYPES.EQ.5)) THEN
68617 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68618 & ITYPES.EQ.2)) THEN
68620 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68621 & ITYPES.EQ.1)) THEN
68624 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68625 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
68627 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68628 & ITYPES.EQ.2)) THEN
68630 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68631 & ITYPES.EQ.1)) THEN
68634 C...g -> ~g + ~g (eikonal approximation).
68635 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
68638 M3JC=5*ICLASS+ICOMBI
68642 C...Find if interference with initial state partons.
68644 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
68645 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
68646 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
68651 KCA=PYCOMP(KFLA(I))
68652 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
68654 IF(KCII(I).NE.0) THEN
68656 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
68657 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
68658 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
68660 IIIS(I,NIIS(I))=ICSI
68665 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
68668 C...Boost interfering initial partons to rest frame
68669 C...and reconstruct their polar and azimuthal angles.
68673 K(N+I,J)=K(IPA(I),J)
68674 P(N+I,J)=P(IPA(I),J)
68678 DO 230 I=3,2+NIIS(1)
68680 K(N+I,J)=K(IIIS(1,I-2),J)
68681 P(N+I,J)=P(IIIS(1,I-2),J)
68685 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68687 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
68688 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
68692 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
68693 & -PS(2)/PS(4),-PS(3)/PS(4))
68694 PHI=PYANGL(P(N+1,1),P(N+1,2))
68695 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
68696 THE=PYANGL(P(N+1,3),P(N+1,1))
68697 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
68698 DO 260 I=3,2+NIIS(1)
68699 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
68700 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
68702 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68703 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
68704 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
68705 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
68709 C...Boost 3 or more partons to their rest frame.
68710 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
68711 &-PS(2)/PS(4),-PS(3)/PS(4))
68713 C...Define imagined single initiator of shower for parton system.
68715 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
68716 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68717 IF(MSTU(21).GE.1) RETURN
68736 C...Loop over partons that may branch.
68739 IF(NPA.EQ.1) IM=NS-1
68742 IF(IM.GT.N) GOTO 600
68745 IF(KSH(IR).EQ.0) GOTO 290
68746 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
68751 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
68752 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68753 IF(MSTU(21).GE.1) RETURN
68756 C...Position of aunt (sister to branching parton).
68757 C...Origin and flavour of daughters.
68760 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
68761 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
68773 K(N+I,2)=K(IPA(I),2)
68775 ELSEIF(KFLM.NE.21) THEN
68778 IREF(N+1-NS)=IREF(IM-NS)
68779 IREF(N+2-NS)=IABS(K(N+2,2))
68780 ELSEIF(K(IM,5).EQ.21) THEN
68788 IREF(N+1-NS)=IABS(K(N+1,2))
68789 IREF(N+2-NS)=IABS(K(N+2,2))
68792 C...Reset flags on daughters and tries made.
68797 KFLD(IP)=IABS(K(N+IP,2))
68798 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
68802 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
68806 C...Maximum virtuality of daughters.
68809 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
68810 P(N+I,5)=MIN(QMAX,PS(5))
68812 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
68813 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
68816 IF(MSTJ(43).LE.2) PEM=V(IM,2)
68817 IF(MSTJ(43).GE.3) PEM=P(IM,4)
68818 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
68819 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
68820 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
68824 IF(ISI(I).EQ.1) THEN
68826 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
68828 V(N+I,5)=P(N+I,5)**2
68831 C...Choose one of the daughters for evolution.
68833 IF(NEP.EQ.1) INUM=1
68835 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
68838 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
68840 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
68846 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
68847 RPM=P(N+I,5)/PMSD(I)
68849 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
68857 C...Cancel choice of predetermined daughter already treated.
68860 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
68861 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
68862 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
68863 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
68864 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
68867 C...Store information on choice of evolving daughter.
68871 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
68874 KFL(I)=IABS(K(IEP(I),2))
68876 ITRY(INUM)=ITRY(INUM)+1
68877 IF(ITRY(INUM).GT.200) THEN
68878 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
68879 IF(MSTU(21).GE.1) RETURN
68883 IF(KSH(IR).EQ.0) GOTO 450
68884 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
68886 C...Check if evolution already predetermined for daughter.
68888 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
68889 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
68890 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
68891 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
68892 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
68894 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
68896 IF(IPSPD.NE.0) ISSET(INUM)=1
68899 C...Select side for interference with initial state partons.
68900 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
68903 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
68905 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
68906 IF(PYR(0).GT.0.5D0) ISII(III)=1
68907 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
68909 IF(PYR(0).GT.0.5D0) ISII(III)=2
68913 C...Calculate allowed z range.
68916 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
68919 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
68920 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
68922 IF(MOD(MSTJ(43),2).EQ.1) THEN
68924 ZCE=PMTH(2,22)/PMED
68925 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
68927 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
68928 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
68930 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
68931 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
68932 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
68935 ZCE=MIN(ZCE,0.49991D0)
68936 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
68937 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
68938 P(IEP(1),5)=PMTH(1,IR)
68939 V(IEP(1),5)=P(IEP(1),5)**2
68943 C...Integral of Altarelli-Parisi z kernel for QCD.
68944 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68945 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
68946 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
68948 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68949 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
68950 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
68951 FBR=6D0*LOG((1D0-ZC)/ZC)
68953 ELSEIF(MSTJ(49).EQ.0) THEN
68954 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
68955 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
68957 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68958 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
68959 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
68960 ELSEIF(MSTJ(49).EQ.1) THEN
68961 FBR=(1D0-2D0*ZC)/3D0
68962 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
68964 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68965 ELSEIF(KFL(1).EQ.21) THEN
68966 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
68968 FBR=2D0*LOG((1D0-ZC)/ZC)
68971 C...Reset QCD probability for colourless.
68972 IF(ISCOL(IR).EQ.0) FBR=0D0
68974 C...Integral of Altarelli-Parisi kernel for photon emission.
68976 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
68977 IF(KFL(1).LE.18) THEN
68978 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
68980 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
68983 C...Inner veto algorithm starts. Find maximum mass for evolution.
68984 410 PMS=V(IEP(1),5)
68989 IRI=IREF(IEP(I)-NS)
68990 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
68993 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
68996 C...Select mass for daughter in QCD evolution.
68998 DO 430 IFF=4,MSTJ(45)
68999 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
69001 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
69002 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
69003 C...Already predetermined choice.
69004 IF(IPSPD.NE.0) THEN
69005 PMSQCD=P(IPSPD,5)**2
69006 ELSEIF(FBR.LT.1D-3) THEN
69008 ELSEIF(MSTJ(44).LE.0) THEN
69009 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
69010 ELSEIF(MSTJ(44).EQ.1) THEN
69011 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
69013 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
69015 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
69016 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
69017 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
69021 C...Select mass for daughter in QED evolution.
69022 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
69023 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
69024 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
69025 IF(FBRE.LT.1D-3) THEN
69028 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
69029 & (PARU(101)*FBRE)))
69031 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
69032 PMSQED=PMSQED+PMTH(1,IR)**2
69033 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
69035 IF(PMSQED.GT.PMSQCD) THEN
69041 C...Check whether daughter mass below cutoff.
69042 P(IEP(1),5)=SQRT(V(IEP(1),5))
69043 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
69044 P(IEP(1),5)=PMTH(1,IR)
69045 V(IEP(1),5)=P(IEP(1),5)**2
69049 C...Already predetermined choice of z, and flavour in g -> qqbar.
69050 IF(IPSPD.NE.0) THEN
69053 PMSGD1=P(IPSGD1,5)**2
69054 PMSGD2=P(IPSGD2,5)**2
69055 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
69056 & 4D0*PMSGD1*PMSGD2))
69057 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
69058 & PMSGD1+PMSGD2)/ALAMPS
69059 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
69060 IF(KFL(1).NE.21) THEN
69063 K(IEP(1),5)=IABS(K(IPSGD1,2))
69066 C...Select z value of branching: q -> qgamma.
69067 ELSEIF(MCE.EQ.2) THEN
69068 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
69069 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69073 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
69074 ELSEIF(MSTJ(49).EQ.0.AND.
69075 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
69076 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69077 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
69078 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
69079 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69083 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
69084 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
69085 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69086 C...Only do z weighting when no ME correction afterwards.
69087 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69089 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
69090 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69091 IF(PYR(0).GT.0.5D0) Z=1D0-Z
69092 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69094 ELSEIF(MSTJ(49).NE.1) THEN
69096 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
69097 KFLB=1+INT(MSTJ(45)*PYR(0))
69098 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69099 IF(PMQ.GE.1D0) GOTO 410
69100 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
69101 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
69102 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
69103 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
69104 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
69106 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
69110 C...Ditto for scalar gluon model.
69111 ELSEIF(KFL(1).NE.21) THEN
69112 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
69114 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
69115 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69118 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69119 KFLB=1+INT(MSTJ(45)*PYR(0))
69120 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69121 IF(PMQ.GE.1D0) GOTO 410
69125 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
69126 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
69127 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69128 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69129 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
69131 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
69132 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
69133 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
69134 IF(PT2APP.LT.PT2MIN) GOTO 410
69135 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
69139 C...Check if z consistent with chosen m.
69140 IF(KFL(1).EQ.21) THEN
69141 IRGD1=IABS(K(IEP(1),5))
69145 IRGD2=IABS(K(IEP(1),5))
69149 ELSEIF(NEP.GE.3) THEN
69151 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69152 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
69154 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
69155 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
69157 IF(MOD(MSTJ(43),2).EQ.1) THEN
69158 PMQTH3=0.5D0*PARJ(82)
69159 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69160 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
69161 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
69162 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
69163 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69167 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
69170 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69171 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69172 ELSEIF(IPSPD.NE.0) THEN
69176 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
69178 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
69180 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69182 C...Width suppression for q -> q + g.
69183 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
69185 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
69189 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
69190 IF(MSTJ(40).EQ.1) THEN
69191 IF(CHI.LT.PYR(0)) GOTO 410
69192 ELSEIF(MSTJ(40).EQ.2) THEN
69193 IF(1D0-CHI.LT.PYR(0)) GOTO 410
69197 C...Three-jet matrix element correction.
69202 C...QED matrix elements: only for massless case so far.
69203 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
69204 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69205 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69206 X3=(1D0-X1)+(1D0-X2)
69208 KI2=K(IPA(3-INUM),2)
69209 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
69210 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
69211 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
69212 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
69213 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
69214 ELSEIF(MCE.EQ.2) THEN
69216 C...QCD matrix elements, including mass effects.
69217 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
69221 IF(IR.GE.31.AND.IGM.EQ.0) THEN
69222 C...QCD ME: original parton, first branching.
69223 PM2ME=PMTH(1,63-IR)
69225 ELSEIF(IR.GE.31) THEN
69226 C...QCD ME: original parton, subsequent branchings.
69227 PM2ME=PMTH(1,63-IR)
69228 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69229 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69230 ELSEIF(K(IM,2).EQ.21) THEN
69231 C...QCD ME: secondary partons, first branching.
69234 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
69235 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
69236 & 4D0*PS1ME*PM2ME**2))
69237 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
69239 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69242 C...QCD ME: secondary partons, subsequent branchings.
69244 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69245 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69248 C...Construct ME variables.
69251 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
69252 X2=1D0+R2ME**2-PS1ME/ECMME**2
69253 C...Call ME, with right order important for two inequivalent showerers.
69254 IF(IR.EQ.IORD+30) THEN
69255 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
69257 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
69259 C...Split up total ME when two radiating partons.
69261 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
69262 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
69263 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
69264 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
69265 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
69266 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
69267 & MAX(1D-10,2D0-X1-X2)
69268 C...Evaluate shower rate to be compared with.
69269 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
69270 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
69271 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
69272 ELSEIF(MSTJ(49).NE.1) THEN
69274 C...Toy model scalar theory matrix elements; no mass effects.
69276 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69277 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69278 X3=(1D0-X1)+(1D0-X2)
69279 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
69281 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
69285 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
69288 C...Impose angular ordering by rejection of nonordered emission.
69289 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
69290 PEMAO=V(IM,1)*P(IM,4)
69291 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
69292 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
69294 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
69295 & .OR.MSTJ(42).EQ.7)) THEN
69297 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
69298 & .OR.MSTJ(42).EQ.6)) THEN
69300 PMDAO=PMTH(2,K(IEP(1),5))
69301 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
69304 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
69305 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
69306 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
69310 440 IF(K(IAOM,5).EQ.22) THEN
69312 IF(K(IAOM,3).LE.NS) MAOM=0
69313 IF(MAOM.EQ.1) GOTO 440
69315 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
69316 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
69317 IF(THE2ID.LT.THE2IM) GOTO 410
69321 C...Impose user-defined maximum angle at first branching.
69322 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
69323 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
69324 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
69325 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69326 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
69327 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69328 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69329 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
69330 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69331 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
69335 C...Impose angular constraint in first branching from interference
69336 C...with initial state partons.
69337 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
69338 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
69339 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
69340 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
69341 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
69342 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
69346 C...End of inner veto algorithm. Check if only one leg evolved so far.
69350 IF(NEP.EQ.1) GOTO 490
69351 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
69354 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
69355 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
69359 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69363 PMSUM=PMSUM+P(N+I,5)
69365 IF(PMSUM.GE.PS(5)) GOTO 350
69366 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
69369 IF(KSH(IRDA).EQ.0) GOTO 480
69370 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
69371 IF(IRDA.EQ.21) THEN
69372 IRGD1=IABS(K(I1,5))
69376 IRGD2=IABS(K(I1,5))
69379 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69380 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
69382 IF(I1.EQ.N+1) ZM=V(IM,1)
69383 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
69384 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
69385 & 4D0*V(N+1,5)*V(N+2,5))
69386 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
69389 IF(MOD(MSTJ(43),2).EQ.1) THEN
69390 PMQTH3=0.5D0*PARJ(82)
69391 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69392 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
69393 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
69394 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
69395 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69399 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
69402 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
69403 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69407 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69408 & ISSET(1).EQ.0) THEN
69410 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69411 & ISSET(2).EQ.0) THEN
69415 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
69417 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69419 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
69422 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
69423 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
69424 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
69425 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
69426 IF(ISL(1).EQ.1) ISL(2)=0
69427 IF(ISL(1).EQ.0) ISLM=1
69428 IF(ISL(2).EQ.0) ISLM=2
69430 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
69435 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
69436 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
69437 PMQ1=V(N+1,5)/V(IM,5)
69438 PMQ2=V(N+2,5)/V(IM,5)
69439 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
69444 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
69448 C...Accepted branch. Construct four-momentum for initial partons.
69454 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
69456 P(N+1,4)=P(IPA(1),4)
69458 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
69459 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
69462 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
69467 P(N+2,4)=P(IM,5)-PED1
69470 ELSEIF(NEP.GE.3) THEN
69471 C...Rescale all momenta for energy conservation.
69477 P(N+I,J)=P(IPA(I),J)
69480 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69483 FAC=(PS(5)-PQS)/(PES-PQS)
69488 P(N+I,J)=FAC*P(N+I,J)
69490 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)
69493 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69495 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
69497 C...Construct transverse momentum for ordinary branching in shower.
69501 550 LOOPPT=LOOPPT+1
69502 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
69503 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
69504 IF(PZM.LE.0D0) THEN
69506 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69507 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69508 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
69509 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69510 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
69511 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
69513 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
69515 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
69518 ELSEIF(PTS.LT.0D0) THEN
69521 PT=SQRT(MAX(0D0,PTS))
69523 C...Global statistics.
69524 MINT(353)=MINT(353)+1
69525 VINT(353)=VINT(353)+PT
69526 IF (MINT(353).EQ.1) VINT(358)=PT
69528 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69530 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
69531 & .AND.IAU.NE.0) THEN
69532 IF(K(IGM,3).NE.0) MAZIP=1
69534 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
69535 IF(MAZIP.EQ.0) ZAU=0D0
69536 IF(K(IGM,2).NE.21) THEN
69537 HAZIP=2D0*ZAU/(1D0+ZAU**2)
69539 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
69541 IF(K(N+1,2).NE.21) THEN
69542 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
69544 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
69548 C...Find coefficient of azimuthal asymmetry due to soft gluon
69551 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
69552 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
69553 IF(K(IGM,3).NE.0) MAZIC=N+1
69554 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
69555 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69556 & ZM.GT.0.5D0) MAZIC=N+2
69557 IF(K(IAU,2).EQ.22) MAZIC=0
69559 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
69561 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
69562 IF(MAZIC.EQ.0) ZGM=1D0
69563 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
69564 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
69565 HAZIC=MIN(0.95D0,HAZIC)
69569 C...Construct energies for ordinary branching in shower.
69570 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
69571 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69572 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69573 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69574 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69575 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69576 P(N+1,4)=PEM*V(IM,1)
69578 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
69579 & SQRT(PMLS)*ZM)/V(IM,5)
69582 C...Already predetermined choice of phi angle or not
69584 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
69586 IF(K(IPSPD,4).GT.0) THEN
69588 IF(IM.EQ.NS+2) THEN
69589 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69591 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
69594 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
69596 IF(K(IPSPD,4).GT.0) THEN
69598 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
69599 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
69600 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
69601 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
69602 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69603 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
69607 C...Construct momenta for ordinary branching in shower.
69608 P(N+1,1)=PT*COS(PHI)
69609 P(N+1,2)=PT*SIN(PHI)
69610 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69611 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69612 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69613 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69614 ELSEIF(PZM.GT.0D0) THEN
69615 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
69616 & 2D0*PEM*P(N+1,4))/PZM
69622 P(N+2,3)=PZM-P(N+1,3)
69623 P(N+2,4)=PEM-P(N+1,4)
69624 IF(MSTJ(43).LE.2) THEN
69625 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
69626 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
69630 C...Rotate and boost daughters.
69632 IF(MSTJ(43).LE.2) THEN
69633 BEX=P(IGM,1)/P(IGM,4)
69634 BEY=P(IGM,2)/P(IGM,4)
69635 BEZ=P(IGM,3)/P(IGM,4)
69636 GA=P(IGM,4)/P(IGM,5)
69637 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
69646 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
69647 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
69648 IF(PTIMB.GT.1D-4) THEN
69649 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
69654 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
69655 & SIN(THE)*COS(PHI)*P(I,3)
69656 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
69657 & SIN(THE)*SIN(PHI)*P(I,3)
69658 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
69660 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
69661 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
69662 P(I,1)=DP(1)+DGABP*BEX
69663 P(I,2)=DP(2)+DGABP*BEY
69664 P(I,3)=DP(3)+DGABP*BEZ
69665 P(I,4)=GA*(DP(4)+DBP)
69669 C...Weight with azimuthal distribution, if required.
69670 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
69676 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
69677 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
69678 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
69680 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
69681 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
69683 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
69684 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
69685 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
69686 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
69687 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
69688 IF(MAZIP.NE.0) THEN
69689 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
69692 IF(MAZIC.NE.0) THEN
69693 IF(MAZIC.EQ.N+2) CAD=-CAD
69694 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
69695 & .LT.PYR(0)) GOTO 560
69700 C...Azimuthal anisotropy due to interference with initial state partons.
69701 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
69702 &K(N+2,2).EQ.21)) THEN
69704 IF(ISII(III).GE.1) THEN
69706 IF(K(N+1,2).NE.21) IAZIID=N+2
69707 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69708 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
69709 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
69710 IF(III.EQ.2) THEIID=PARU(1)-THEIID
69711 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
69712 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
69713 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
69714 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
69715 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
69716 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
69717 & .LT.PYR(0)) GOTO 560
69721 C...Continue loop over partons that may branch, until none left.
69722 IF(IGM.GE.0) K(IM,1)=14
69725 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
69726 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
69727 IF(MSTU(21).GE.1) N=NS
69728 IF(MSTU(21).GE.1) RETURN
69732 C...Set information on imagined shower initiator.
69733 600 IF(NPA.GE.2) THEN
69737 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
69745 C...Reconstruct string drawing information.
69746 DO 610 I=NS+1+IIM,N
69747 KQ=KCHG(PYCOMP(K(I,2)),2)
69748 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
69750 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
69751 & IABS(K(I,2)).LE.18) THEN
69753 ELSEIF(K(I,1).LE.10) THEN
69754 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
69755 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
69756 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
69757 ID1=MOD(K(I,4),MSTU(5))
69758 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
69759 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
69760 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
69761 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
69762 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69763 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
69764 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69765 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
69766 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
69767 K(ID2,5)=K(ID2,5)+MSTU(5)*I
69769 ID1=MOD(K(I,4),MSTU(5))
69771 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69772 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
69773 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
69774 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69775 K(ID1,5)=K(ID1,5)+MSTU(5)*I
69785 C...Transformation from CM frame.
69787 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
69788 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
69790 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
69791 ELSEIF(NPA.EQ.2) THEN
69796 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
69797 & /(1D0+GA)-P(IPA(1),4))
69798 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
69799 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
69800 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
69802 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
69804 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
69807 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
69810 C...Decay vertex of shower.
69817 C...Delete trivial shower, else connect initiators.
69818 IF(N.LE.NS+NPA+IIM) THEN
69823 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
69824 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
69825 K(NS+IIM+IP,3)=IPA(IP)
69826 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
69827 IF(K(NS+IIM+IP,1).NE.1) THEN
69828 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
69829 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
69837 C*********************************************************************
69840 C...Generates pT-ordered timelike final-state parton showers.
69842 C...MODE defines how to find radiators and recoilers.
69843 C... = 0 : based on colour flow between undecayed partons.
69844 C... = 1 : for IPART <= NPARTD only consider primary partons,
69845 C... whether decayed or not; else as above.
69846 C... = 2 : based on common history, whether decayed or not.
69847 C... = 3 : use (or create) MCT color information to shower partons
69849 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
69851 C...Double precision and integer declarations.
69852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69853 IMPLICIT INTEGER(I-N)
69854 INTEGER PYK,PYCHGE,PYCOMP
69855 C...Parameter statement to help give large particle numbers.
69856 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69857 &KEXCIT=4000000,KDIMEN=5000000)
69858 C...Parameter statement for maximum size of showers.
69859 PARAMETER (MAXNUR=1000)
69861 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69862 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69863 COMMON/PYCTAG/NCT,MCT(4000,2)
69864 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69865 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69866 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69867 COMMON/PYINT1/MINT(400),VINT(400)
69868 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
69871 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
69872 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
69873 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
69874 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
69875 C...Statement functions.
69876 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
69877 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
69879 C...Initial values. Check that valid system.
69881 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
69882 &MSTJ(41).NE.12) RETURN
69883 IF(NPART.LE.0) THEN
69884 CALL PYERRM(2,'(PYPTFS:) showering system too small')
69890 C...Mass thresholds and Lambda for QCD evolution.
69894 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
69895 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
69902 C...Cutoff scale for QCD evolution. Starting pT2.
69903 NFLAV=MAX(0,MIN(5,MSTJ(45)))
69904 PT0C=0.5D0*PARJ(82)
69905 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
69907 C...Parameters for QED evolution.
69908 AEM2PI=PARU(101)/PARU(2)
69909 PT0EQ=0.5D0*PARJ(83)
69910 PT0EL=0.5D0*PARJ(90)
69912 C...Reset. Remove irrelevant colour tags.
69917 DO 110 I=MINT(84)+1,N
69918 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
69922 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
69929 C...Begin loop to set up showering partons. Sum four-momenta.
69932 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
69933 IF(K(I,1).GT.10) GOTO 230
69934 ELSEIF(K(I,3).GT.MINT(84)) THEN
69935 IF(K(I,3).GT.MINT(84)+2) GOTO 230
69937 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
69940 PSUM(J)=PSUM(J)+P(I,J)
69943 C...Find colour and charge, but skip diquarks.
69944 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
69945 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
69946 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
69949 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
69950 IF (MSTP(148).GE.1) THEN
69951 C...Temporary: force no radiation from quarkonia since not yet treated
69952 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
69953 & //' PYPTFS, switched off')
69954 CALL PYGIVE('MSTP(148)=0')
69956 IF (MSTP(148).EQ.0) THEN
69957 C...Skip quarkonia if radiation switched off
69963 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69964 C...(only intended for studying the effects of switching such rad on/off)
69965 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
69969 C...Either colour or anticolour charge radiates; for gluon both.
69970 DO 180 JSGCOL=1,-1,-2
69971 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
69972 JCOL=4+(1-JSGCOL)/2
69975 C...Basic info about radiating parton.
69979 ISCOL(NEVOL)=JSGCOL
69981 PTSCA(NEVOL)=PTPART(IP)
69983 C...Begin search for colour recoiler when MODE = 0 or 1.
69985 C...Find sister with matching anticolour to the radiating parton.
69987 IRNEW=K(IROLD,JCOL)/MSTU(5)
69990 C...Skip radiation off loose colour ends.
69991 130 IF(IRNEW.EQ.0) THEN
69995 C...Optionally skip radiation on dipole to beam remnant.
69996 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
70000 C...For now always skip radiation on dipole to junction.
70001 ELSEIF(K(IRNEW,2).EQ.88) THEN
70005 C...For MODE=1: if reached primary then done.
70006 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
70007 & IRNEW.LE.NPARTD) THEN
70009 C...If sister stable and points back then done.
70010 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
70012 IF(K(IRNEW,1).LT.10) THEN
70014 C...If sister unstable then go to her daughter.
70017 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
70022 C...If found mother then look for aunt.
70023 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
70026 IRNEW=K(IROLD,JCOL)/MSTU(5)
70029 C...If daughter stable then done.
70030 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
70032 IF(K(IRNEW,1).LT.10) THEN
70034 C...If daughter unstable then go to granddaughter.
70037 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
70042 C...If daughter points to another daughter then done or move up.
70043 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
70045 IF(K(IRNEW,1).LT.10) THEN
70048 IRNEW=K(IRNEW,JCOL)/MSTU(5)
70054 C...Begin search for colour recoiler when MODE = 2.
70055 ELSEIF (MODE.EQ.2) THEN
70057 IRNEW=K(IROLD,JCOL)/MSTU(5)
70058 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
70059 C...If no color partner found, pick at random among other primaries
70060 C...(e.g., when the color line is traced all the way to the beam)
70061 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70062 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70063 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
70064 C...Step up to mother if radiating parton already branched.
70065 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
70067 IRNEW=K(IROLD,JCOL)/MSTU(5)
70069 C...Pick sister by history if no anticolour available.
70071 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70073 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
70076 C...Last resort: pick at random among other primaries.
70078 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70079 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70083 C...Trace down if sister branched.
70084 150 IF(K(IRNEW,1).GT.10) THEN
70085 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70086 C...If no correct color-daughter found, swap.
70087 IF (IRTMP.EQ.0) THEN
70090 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70095 ELSEIF (MODE.EQ.3) THEN
70096 C...The following will add MCT colour tracing for unprepped events
70097 C...If not done, trace Les Houches colour tags for this dipole
70099 IF (MCT(I,JCOL-3).EQ.0) THEN
70100 C...Special end code -1 : trace to color partner or 0, return in IEND
70102 CALL PYCTTR(I,JCOL,IEND)
70103 C...Clean up mother/daughter 'read' tags set by PYCTTR
70106 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
70107 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
70114 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
70118 C...If no color partner, then we hit beam
70119 IF (IEND.LE.0) THEN
70120 C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
70121 IF (MSTP(72).LE.1) THEN
70125 C...Else try a random partner
70126 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70127 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70130 C...Else save recoiling colour partner
70136 C...Now found other end of colour dipole.
70141 C...Also electrical charge may radiate; so far only quarks and leptons.
70142 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
70143 & IABS(K(I,2)).LE.18) THEN
70145 C...Basic info about radiating parton.
70151 PTSCA(NEVOL)=PTPART(IP)
70153 C...Pick nearest (= smallest invariant mass) charged particle
70154 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
70158 DO 190 IP2=1,NPART+N-MINT(53)
70159 IF(IP2.EQ.IP) GOTO 190
70160 IF(IP2.LE.NPART) THEN
70162 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
70163 IF(K(I2,1).GT.10) GOTO 190
70164 ELSEIF(K(I2,3).GT.MINT(84)) THEN
70165 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
70167 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
70170 I2=MINT(53)+IP2-NPART
70172 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
70173 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
70174 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
70175 IF(PM2INV.LT.PM2MIN) THEN
70180 IF(IRNEW.EQ.0) THEN
70185 C...Begin search for charge recoiler when MODE = 2.
70188 C...Pick sister by history; step up if parton already branched.
70189 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
70193 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70195 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
70197 C...Last resort: pick at random among other primaries.
70199 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70200 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70202 C...Trace down if sister branched.
70203 210 IF(K(IRNEW,1).GT.10) THEN
70204 DO 220 IR=IRNEW+1,N
70205 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
70215 C...End loop to set up showering partons. System invariant mass.
70217 IF(NEVOL.LE.0) RETURN
70218 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
70219 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70221 C...Check if 3-jet matrix elements to be used.
70225 IF(MSTJ(47).GE.1) THEN
70227 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70229 IPART1=K(IPART(1),3)
70230 IPART2=K(IPART(2),3)
70231 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
70232 KFSRCE=IABS(K(IPART1,2))
70233 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
70236 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
70241 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70242 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70243 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70244 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70245 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70246 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70247 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70248 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70250 C...Identify two primary showerers.
70251 KFLA1=IABS(K(IPART(1),2))
70253 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
70254 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
70255 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
70256 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
70257 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
70258 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
70259 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
70260 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
70261 KFLA2=IABS(K(IPART(2),2))
70263 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
70264 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
70265 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
70266 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
70267 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
70268 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
70269 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
70270 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
70272 C...Order of showerers. Presence of gluino.
70273 ITYPMN=MIN(ITYPE1,ITYPE2)
70274 ITYPMX=MAX(ITYPE1,ITYPE2)
70276 IF(ITYPE1.GT.ITYPE2) IORD=2
70278 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70280 C...Require exactly two primary showerers for ME corrections.
70282 IF(IPART1.GT.0) THEN
70284 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
70287 IF(NPRIM.NE.2) THEN
70289 C...Predetermined and default matrix element kinds.
70290 ELSEIF(MSTJ(38).NE.0) THEN
70294 ELSEIF(MSTJ(47).GE.6) THEN
70300 C...Vector/axial vector -> q + qbar; q -> q + V.
70301 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70302 & ITYPES.EQ.3)) THEN
70304 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70306 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70307 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
70308 C...gamma*/Z0: assume e+e- initial state if unknown.
70310 IF(KFSRCE.EQ.23) THEN
70312 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70313 IF(IANNFL.GT.0) THEN
70314 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70316 IF(IANNFL.NE.0) THEN
70317 KANNFL=IABS(K(IANNFL,2))
70318 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70321 AI=SIGN(1D0,EI+0.1D0)
70322 VI=AI-4D0*EI*PARU(102)
70323 EF=KCHG(KFLA1,1)/3D0
70324 AF=SIGN(1D0,EF+0.1D0)
70325 VF=AF-4D0*EF*PARU(102)
70326 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70329 SQWZ=PSUM(5)*PMAS(23,2)
70330 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70331 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70332 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70333 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70335 ALPHA=VECT/(VECT+AXIV)
70336 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70339 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70340 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70342 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70343 & ITYPES.EQ.1)) THEN
70346 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70347 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70349 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70351 ELSEIF(KFSRCE.EQ.36) THEN
70354 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70355 & ITYPES.EQ.1)) THEN
70358 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70359 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70360 & ITYPES.EQ.3)) THEN
70362 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70363 & ITYPES.EQ.2)) THEN
70365 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70367 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70368 & ITYPES.EQ.2)) THEN
70371 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70372 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70373 & ITYPES.EQ.5)) THEN
70375 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70376 & ITYPES.EQ.2)) THEN
70378 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70379 & ITYPES.EQ.1)) THEN
70382 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70383 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70385 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70386 & ITYPES.EQ.2)) THEN
70388 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70389 & ITYPES.EQ.1)) THEN
70392 C...g -> ~g + ~g (eikonal approximation).
70393 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70396 M3JC=5*ICLASS+ICOMBI
70399 C...Store pair that together define matrix element treatment.
70402 MESYS(NMESYS,0)=M3JC
70403 MESYS(NMESYS,1)=IPART(1)
70404 MESYS(NMESYS,2)=IPART(2)
70407 C...Store qqbar or l+l- pairs for QED radiation.
70408 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
70410 MESYS(NMESYS,0)=101
70411 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
70412 MESYS(NMESYS,1)=IPART(1)
70413 MESYS(NMESYS,2)=IPART(2)
70416 C...Store other qqbar/l+l- pairs from g/gamma branchings.
70418 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
70420 260 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
70424 C...Move up this check to avoid out-of-bounds.
70425 IF(I1M.EQ.0) GOTO 290
70426 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
70428 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
70430 270 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
70434 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
70440 MESYS(NMESYS,0)=102
70448 C..Loopback point for counting number of emissions.
70452 C...Begin loop to evolve all existing partons, if required.
70455 DO 380 IEVOL=1,NEVOL
70456 IF(IFLG(IEVOL).EQ.0) THEN
70458 C...Basic info on radiator and recoil.
70465 C...Invariant mass of "dipole".Starting value for pT evolution.
70466 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
70467 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
70469 C...Case of evolution by QCD branching.
70470 IF(ISCOL(IEVOL).NE.0) THEN
70472 C...Parton-by-parton maximum scale from initial conditions.
70473 IF(MSTP(72).EQ.0) THEN
70474 DO 320 IPRT=1,NPARTS
70475 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
70479 C...If kinematically impossible then do not evolve.
70480 IF(PT2.LT.PT2CMN) THEN
70485 C...Check if part of system for which ME corrections should be applied.
70487 DO 330 IME=1,NMESYS
70488 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70489 & MESYS(IME,0).LT.100) IMESYS=IME
70492 C...Special flag for colour octet states.
70493 C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70495 IF(K(I,2).EQ.21) MOCT=1
70497 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70499 IF(K(I,2).EQ.5100021) MOCT=2
70501 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
70502 & IABS(K(I,2)).LE.9910555) MOCT=2
70506 C...Upper estimate for matrix element weighting and colour factor.
70507 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70510 IF(MOCT.GE.1) COLFAC=3D0/2D0
70511 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
70512 WTPSQQ=0.5D0*0.5D0*NFLAV
70514 C...Determine overestimated z range: switch at c and b masses.
70519 IF(PT2.GT.1.01D0*PMCS) THEN
70525 IF(PT2.GT.1.01D0*PMBS) THEN
70531 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
70532 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
70534 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70535 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
70538 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
70539 EVCOEF=EVCOEF+EVEMQQ
70542 C...Pick pT2 (in overestimated z range).
70543 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
70545 C...Loopback if crossed c/b mass thresholds.
70546 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
70550 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
70555 C...Finish if below lower cutoff.
70556 IF(PT2.LT.PT2CMN) THEN
70561 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70562 C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70564 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
70566 C...Pick z: dz/(1-z) or dz.
70567 IF(IFLAG.EQ.1) THEN
70568 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70570 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
70573 C...Loopback if outside allowed range for given pT2.
70574 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70575 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70576 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
70577 PM2=PM2I+PT2/(Z*(1D0-Z))
70578 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
70580 C...No weighting for primary partons; to be done later on.
70581 IF(IMESYS.GT.0) THEN
70583 C...Weighting of q->qg/X->Xg branching.
70584 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
70585 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
70587 C...Weighting of g->gg branching.
70588 ELSEIF(IFLAG.EQ.1) THEN
70589 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
70591 C...Flavour choice and weighting of g->qqbar branching.
70593 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
70595 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70596 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
70597 IF(WTME.LT.PYR(0)) GOTO 350
70601 C...Case of evolution by QED branching.
70602 ELSEIF(ISCHG(IEVOL).NE.0) THEN
70604 C...If kinematically impossible then do not evolve.
70606 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
70607 IF(PT2.LT.PT2EMN) THEN
70612 C...Check if part of system for which ME corrections should be applied.
70614 DO 360 IME=1,NMESYS
70615 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70616 & MESYS(IME,0).GT.100) IMESYS=IME
70619 C...Charge. Matrix element weighting factor.
70620 CHG=ISCHG(IEVOL)/3D0
70623 C...Determine overestimated z range. Find evolution coefficient.
70624 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
70625 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
70626 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
70628 C...Pick pT2 (in overestimated z range).
70629 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
70631 C...Finish if below lower cutoff.
70632 IF(PT2.LT.PT2EMN) THEN
70637 C...Pick z: dz/(1-z).
70638 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70640 C...Loopback if outside allowed range for given pT2.
70641 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70642 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70643 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
70644 PM2=PM2I+PT2/(Z*(1D0-Z))
70645 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
70647 C...Weighting by branching kernel, except if ME weighting later.
70648 IF(IMESYS.EQ.0) THEN
70649 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
70654 C...Save acceptable branching.
70656 IMESAV(IEVOL)=IMESYS
70662 C...Check if branching has highest pT.
70663 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
70665 PT2MX=PT2SAV(IEVOL)
70669 C...Finished if no more branchings to be done.
70670 IF(IMX.EQ.0) GOTO 500
70672 C...Restore info on hardest branching to be processed.
70683 PM2=PM2I+PT2/(Z*(1D0-Z))
70685 C...Special flag for colour octet states.
70687 IF(K(I,2).EQ.21) MOCT=1
70688 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70689 IF(K(I,2).EQ.5100021) MOCT=2
70691 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
70692 & IABS(K(I,2)).LE.9910555) MOCT=2
70695 C...Restore further info for g->qqbar branching.
70697 IF(IFLG(IMX).GT.10) THEN
70700 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70703 C...For branching g include azimuthal asymmetries from polarization.
70705 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
70706 C...Trace grandmother via intermediate recoil copies.
70709 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
70710 & K(IM,3).GT.0) THEN
70712 IF(IM.GT.MINT(84)) GOTO 390
70715 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
70716 & KFGM=IABS(K(IGM,2))
70717 C...Define approximate energy sharing by identifying aunt.
70719 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
70720 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
70721 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
70722 C...Coefficient from gluon production.
70724 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
70726 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
70728 C...Coefficient from gluon decay.
70730 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
70732 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
70737 C...Create new slots for branching products and recoil.
70743 C...Set status, flavour and mother of new ones.
70746 IF(KCHA.NE.0) K(IGNEW,1)=1
70751 IF(KCHA.NE.0) K(IGNEW,2)=22
70753 K(INEW,2)=-ISIGN(KFQ,KCOL)
70754 K(IGNEW,2)=-K(INEW,2)
70761 C...Find rest frame and angles of branching+recoil.
70767 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
70768 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
70769 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
70770 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
70771 PHI=PYANGL(P(INEW,1),P(INEW,2))
70772 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
70774 C...Derive kinematics of branching: generics (like g->gg).
70779 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
70780 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
70781 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
70782 PTCOR=SQRT(MAX(0D0,PT2COR))
70783 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
70784 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
70785 C...Specific kinematics reduction for q->qg with m_q > 0.
70787 PTCOR=(1D0-PM2I/PM2)*PTCOR
70788 PZN=PZN+PM2I*PZG/PM2
70789 PZG=(1D0-PM2I/PM2)*PZG
70790 C...Specific kinematics reduction for g->qqbar with m_q > 0.
70791 ELSEIF(KFQ.NE.0) THEN
70795 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
70799 C...Pick phi and construct kinematics of branching.
70800 420 PHIROT=PARU(2)*PYR(0)
70801 P(INEW,1)=PTCOR*COS(PHIROT)
70802 P(INEW,2)=PTCOR*SIN(PHIROT)
70804 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
70805 P(IGNEW,1)=-P(INEW,1)
70806 P(IGNEW,2)=-P(INEW,2)
70808 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
70812 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
70814 C...Boost branching system to lab frame.
70815 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
70817 C...Renew choice of phi angle according to polarization asymmetry.
70818 IF(ABS(ASYPOL).GT.1D-3) THEN
70824 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
70825 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
70826 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
70828 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
70829 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
70831 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
70832 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
70833 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
70834 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
70835 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
70836 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
70841 C...Matrix element corrections for primary partons when requested.
70842 IF(IMESYS.GT.0) THEN
70843 M3JC=MESYS(IMESYS,0)
70845 C...Identify recoiling partner and set up three-body kinematics.
70846 IRP=MESYS(IMESYS,1)
70847 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
70848 IF(IRP.EQ.IR) IRP=IRNEW
70850 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
70852 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
70854 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
70855 & PSUM(3)*P(INEW,3))/PSUM(5)**2
70856 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
70857 & PSUM(3)*P(IRP,3))/PSUM(5)**2
70859 R1ME=P(INEW,5)/PSUM(5)
70860 R2ME=P(IRP,5)/PSUM(5)
70862 C...Matrix elements for gluon emission.
70863 IF(M3JC.LT.100) THEN
70865 C...Call ME, with right order important for two inequivalent showerers.
70866 IF(MESYS(IMESYS,IORD).EQ.I) THEN
70867 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
70869 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
70872 C...Split up total ME when two radiating partons.
70874 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
70875 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
70876 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
70877 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70878 & MAX(1D-10,2D0-X1-X2)
70880 C...Evaluate shower rate.
70881 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70882 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70883 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
70885 C...Matrix elements for photon emission: still rather primitive.
70888 C...For generic charge combination currently only massless expression.
70889 IF(M3JC.EQ.101) THEN
70890 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
70891 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
70892 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70893 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
70895 C...For flavour neutral system assume vector source and include masses.
70897 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
70898 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
70899 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70900 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70904 C...Perform weighting with W_ME/W_PS.
70905 IF(WME.LT.PYR(0)*WPS) THEN
70913 C...Now for sure accepted branching. Save highest pT.
70914 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
70916 C...Update status for obsolete ones. Bookkkep the moved original parton
70917 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70918 C...Do not bookkeep radiated photon, since it cannot radiate further.
70922 IF(IPART(IP).EQ.I) IPART(IP)=INEW
70923 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
70930 C...Initialize colour flow of branching.
70931 C...Use both old and new style colour tags for flexibility.
70945 C...Trivial colour flow for l->lgamma and q->qgamma.
70946 IF(IABS(KCHA).EQ.3) THEN
70949 ELSEIF(KCHA.NE.0) THEN
70950 IF(K(I,4).NE.0) THEN
70952 K(INEW,4)=MSTU(5)*I
70953 MCT(INEW,1)=MCT(I,1)
70955 IF(K(I,5).NE.0) THEN
70957 K(INEW,5)=MSTU(5)*I
70958 MCT(INEW,2)=MCT(I,2)
70961 C...Set colour flow for q->qg and g->gg.
70962 ELSEIF(KFQ.EQ.0) THEN
70963 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70964 K(IGNEW,JCOLP)=MSTU(5)*I
70965 K(INEW,JCOLP)=MSTU(5)*IGNEW
70966 K(IGNEW,JCOLN)=MSTU(5)*INEW
70967 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70969 MCT(INEW,JCOLP-3)=NCT
70970 MCT(IGNEW,JCOLN-3)=NCT
70972 K(I,JCOLN)=K(I,JCOLN)+INEW
70973 K(INEW,JCOLN)=MSTU(5)*I
70974 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70977 C...Set colour flow for g->qqbar.
70979 K(I,JCOLN)=K(I,JCOLN)+INEW
70980 K(INEW,JCOLN)=MSTU(5)*I
70981 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70982 K(IGNEW,JCOLP)=MSTU(5)*I
70983 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70984 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70987 C...Daughter info for colourless recoiling parton.
70988 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
70994 C...Colour of recoiling parton sails through unchanged.
70996 IF(K(IR,4).NE.0) THEN
70997 K(IR,4)=K(IR,4)+IRNEW
70998 K(IRNEW,4)=MSTU(5)*IR
70999 MCT(IRNEW,1)=MCT(IR,1)
71001 IF(K(IR,5).NE.0) THEN
71002 K(IR,5)=K(IR,5)+IRNEW
71003 K(IRNEW,5)=MSTU(5)*IR
71004 MCT(IRNEW,2)=MCT(IR,2)
71008 C...Vertex information trivial.
71015 C...Update list of old radiators.
71016 DO 480 IEVOL=1,NEVOL
71017 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
71019 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
71022 ELSEIF(IPOS(IEVOL).EQ.I) THEN
71025 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
71028 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
71030 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
71034 C...Update links of old connected partons.
71035 IF(IREC(IEVOL).EQ.I) THEN
71038 ELSEIF(IREC(IEVOL).EQ.IR) THEN
71044 C...q->qg or g->gg: create new gluon radiators.
71045 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
71052 PTSCA(NEVOL)=SQRT(PT2)
71059 PTSCA(NEVOL)=PTSCA(NEVOL-1)
71062 C...Update matrix elements parton list and add new for g/gamma->qqbar.
71063 DO 490 IME=1,NMESYS
71064 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
71065 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
71066 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
71067 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
71072 MESYS(NMESYS,1)=INEW
71073 MESYS(NMESYS,2)=IGNEW
71075 MESYS(NMESYS,0)=102
71076 MESYS(NMESYS,1)=INEW
71077 MESYS(NMESYS,2)=IGNEW
71080 C...Global statistics.
71081 MINT(353)=MINT(353)+1
71082 VINT(353)=VINT(353)+PTCOR
71083 IF (MINT(353).EQ.1) VINT(358)=PTCOR
71085 C...Loopback for more emissions if enough space.
71087 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
71088 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
71091 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
71100 C*********************************************************************
71103 C...Auxiliary to PYSHOW and PYPTFS.
71104 C...Matrix elements for gluon (or photon) emission from
71105 C...a two-body state; to be used by the parton shower routine.
71106 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
71107 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
71108 C... = (alpha-strong/2 pi) * CF * PYMAEL,
71109 C...i.e. normalization is such that one recovers the familiar
71110 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
71111 C...Coupling structure:
71112 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
71113 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
71114 C... = 16-19 : q -> q V
71115 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
71116 C... = 26-29 : q -> q S
71117 C... = 31-34 : V -> ~q ~qbar (~q = squark)
71118 C... = 36-39 : ~q -> ~q V
71119 C... = 41-44 : S -> ~q ~qbar
71120 C... = 46-49 : ~q -> ~q S
71121 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
71122 C... = 56-59 : ~q -> q chi
71123 C... = 61-64 : q -> ~q chi
71124 C... = 66-69 : ~g -> q ~qbar
71125 C... = 71-74 : ~q -> q ~g
71126 C... = 76-79 : q -> ~q ~g
71127 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
71128 C...Note that the order of the decay products is important.
71129 C...In each set of four, the variants are ordered as:
71130 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
71131 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
71132 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
71133 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
71135 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
71137 C...Double precision and integer declarations.
71138 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71139 IMPLICIT INTEGER(I-N)
71141 C...Check input values. Return zero outside allowed phase space.
71143 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
71144 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
71145 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
71146 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
71147 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
71148 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
71150 C...Initial values and flags.
71158 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
71160 C...Eikonal expression; also acts as default.
71161 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
71163 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71165 ELSEIF(ICOMBI.EQ.2) THEN
71166 ANUM=(2D0-X1-X2)**2
71167 ELSEIF(ICOMBI.EQ.3) THEN
71168 ANUM=ALPCOR*(2D0-X1-X2)**2
71170 ANUM=0.5D0*(2D0-X1-X2)**2
71172 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71173 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71174 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71175 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71178 C...V -> q qbar (V = gamma*/Z0/W+-/...).
71179 ELSEIF(ICLASS.EQ.2) THEN
71180 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71181 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71182 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
71183 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
71184 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
71185 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
71186 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71187 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
71188 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
71189 & (-1+R1**2-R2**2+X2)**2
71190 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71191 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71192 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
71193 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71194 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
71195 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71196 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71197 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
71198 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
71199 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
71200 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
71201 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
71205 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71206 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71207 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
71208 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
71209 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
71210 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
71211 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
71212 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
71213 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
71214 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71215 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71216 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
71217 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71218 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
71219 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71220 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71221 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
71222 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
71223 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
71224 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71225 & +X2)/(-1-R1**2+R2**2+X1)**2
71229 IF(ICOMBI.EQ.4) THEN
71230 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
71231 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
71232 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
71233 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
71234 & (-1-R1**2+R2**2+X1)**2
71236 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
71237 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
71238 & -R1**2*X2**2+X1*X2**2)/
71239 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71240 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
71241 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
71242 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
71243 & (-1+R1**2-R2**2+X2)**2
71249 ELSEIF(ICLASS.EQ.3) THEN
71250 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71251 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
71252 & +R1**2*R2**2-2D0*R2**4)
71253 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
71254 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
71255 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
71256 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
71257 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
71258 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
71259 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71260 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
71261 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71262 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
71263 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71264 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71265 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
71266 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
71267 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71268 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
71269 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71270 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
71271 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
71274 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71275 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
71276 & +R1**2*R2**2-2D0*R2**4)
71277 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
71278 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
71279 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
71280 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
71281 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
71282 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
71283 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71284 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
71285 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71286 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
71287 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71288 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71289 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71290 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
71291 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71292 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
71293 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71294 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71295 & +X1*X2**2)/(-2+X1+X2)**2
71298 IF(ICOMBI.EQ.4) THEN
71299 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
71300 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
71301 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
71302 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
71303 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
71304 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71305 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
71306 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
71307 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71308 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71309 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71310 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
71311 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
71312 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71313 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71314 & +X1*X2**2)/(2-X1-X2)**2
71318 C...S -> q qbar (S = h0/H0/A0/H+-/...).
71319 ELSEIF(ICLASS.EQ.4) THEN
71320 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71321 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
71322 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71323 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71324 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71325 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
71326 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
71327 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71328 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71329 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71330 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71333 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71334 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
71335 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71336 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71337 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71338 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71339 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71340 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71341 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
71342 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
71343 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71344 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71347 IF(ICOMBI.EQ.4) THEN
71348 RLO4=PS*(1D0-R1**2-R2**2)
71349 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71350 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71351 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71352 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71353 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71354 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
71355 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71360 ELSEIF(ICLASS.EQ.5) THEN
71361 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71362 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71363 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71364 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71365 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
71366 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71367 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71368 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71369 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71370 & (-1+R1**2-R2**2+X2)**2
71373 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71374 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71375 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71376 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71377 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
71378 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71379 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71380 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71381 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71382 & (-1+R1**2-R2**2+X2)**2
71385 IF(ICOMBI.EQ.4) THEN
71386 RLO4=PS*(1D0+R1**2-R2**2)
71387 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
71388 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71389 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
71390 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71391 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71392 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71396 C...V -> ~q ~qbar (~q = squark).
71397 ELSEIF(ICLASS.EQ.6) THEN
71398 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71399 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
71400 & (-1-R1**2+R2**2+X1)**2
71401 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
71402 & (-1-R1**2+R2**2+X1)
71403 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
71404 & /(-1+R1**2-R2**2+X2)**2
71405 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
71406 & (-1+R1**2-R2**2+X2)
71407 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
71408 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
71409 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
71410 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71414 ELSEIF(ICLASS.EQ.7) THEN
71415 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71416 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
71417 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
71418 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
71419 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71420 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
71421 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
71422 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
71423 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
71424 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
71425 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
71431 ELSEIF(ICLASS.EQ.8) THEN
71433 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71434 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
71435 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
71436 & -R1**2*X2**2+X1*X2**2)/
71437 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
71442 ELSEIF(ICLASS.EQ.9) THEN
71444 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71445 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71446 & -(X1+X2)/(-2+X1+X2)**2
71449 C...chi -> q ~qbar (chi = neutralino/chargino).
71450 ELSEIF(ICLASS.EQ.10) THEN
71451 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71452 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71453 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71454 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
71455 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71456 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71457 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71458 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71459 & (-1+R1**2-R2**2+X2)**2
71462 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71463 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
71464 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
71465 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
71466 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
71467 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71468 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71469 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71470 & (-1+R1**2-R2**2+X2)**2
71473 IF(ICOMBI.EQ.4) THEN
71474 RLO4=PS*(1+R1**2-R2**2)
71475 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71476 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
71477 & +X2+R1**2*X2-X1*X2/2)/
71478 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71479 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71480 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71485 ELSEIF(ICLASS.EQ.11) THEN
71486 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71487 RLO1=PS*(1D0-(R1+R2)**2)
71488 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71489 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71490 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71491 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71492 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71493 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71494 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71497 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71498 RLO2=PS*(1D0-(R1-R2)**2)
71499 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
71501 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71502 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71503 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71504 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
71505 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71506 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71509 IF(ICOMBI.EQ.4) THEN
71510 RLO4=PS*(1D0-R1**2-R2**2)
71511 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71512 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
71513 & +3*R1**2*X2-R2**2*X2-X1*X2)/
71514 & (-1+R1**2-R2**2+X2)**2
71515 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71516 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71517 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71522 ELSEIF(ICLASS.EQ.12) THEN
71523 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71524 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71525 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71526 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
71527 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
71528 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
71529 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71530 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71533 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71534 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71535 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
71536 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
71537 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71538 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71539 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71540 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71543 IF(ICOMBI.EQ.4) THEN
71544 RLO4=PS*(1D0-R1**2+R2**2)
71545 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71546 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
71547 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
71548 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
71549 & +R1**2*X2-X1*X2/2-X2**2/2)/
71550 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71555 ELSEIF(ICLASS.EQ.13) THEN
71556 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71557 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71558 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
71559 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
71560 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
71561 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
71562 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71563 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
71564 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
71565 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
71566 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
71567 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
71568 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
71569 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71570 & (3*(-1+R1**2-R2**2+X2)**2)
71574 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71575 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71576 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
71577 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
71578 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71579 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
71580 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
71581 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
71582 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
71583 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
71584 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
71585 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71586 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
71587 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
71588 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71589 & (3*(-1+R1**2-R2**2+X2)**2)
71593 IF(ICOMBI.EQ.4) THEN
71594 RLO4=PS*(1D0+R1**2-R2**2)
71595 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
71596 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
71597 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
71598 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
71599 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
71600 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71601 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
71602 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71603 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
71604 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71605 & (3*(-1+R1**2-R2**2+X2)**2)
71611 ELSEIF(ICLASS.EQ.14) THEN
71612 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71613 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
71614 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71615 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71616 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71617 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
71618 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
71619 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
71620 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71621 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71622 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71623 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71624 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
71625 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
71626 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71628 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71629 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71630 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71634 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71635 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
71636 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71637 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71638 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71639 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
71640 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
71641 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
71642 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
71643 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
71644 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71645 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71647 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
71648 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
71649 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71650 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
71651 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
71652 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71656 IF(ICOMBI.EQ.4) THEN
71657 RLO4=PS*(1-R1**2-R2**2)
71658 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
71659 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71660 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71661 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71662 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71663 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
71664 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
71665 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71666 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
71667 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
71668 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
71669 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71670 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71671 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
71672 RFO4=9D0*RFO4/128D0
71677 ELSEIF(ICLASS.EQ.15) THEN
71678 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71679 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71680 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71681 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
71682 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
71683 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
71684 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
71685 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71686 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
71687 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
71688 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71689 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
71690 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
71691 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
71692 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71693 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71697 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71698 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71699 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
71700 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
71701 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
71702 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
71703 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
71704 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71705 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
71706 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
71707 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71708 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
71709 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71710 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71711 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71712 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71716 IF(ICOMBI.EQ.4) THEN
71717 RLO4=PS*(1D0-R1**2+R2**2)
71718 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71719 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
71720 & -R2**2*X2/2-X1*X2/2)/
71721 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
71722 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
71723 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71724 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
71725 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71726 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
71727 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
71728 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71729 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71734 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71735 ELSEIF(ICLASS.EQ.16) THEN
71737 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71739 ELSEIF(ICOMBI.EQ.2) THEN
71740 ANUM=(2D0-X1-X2)**2
71741 ELSEIF(ICOMBI.EQ.3) THEN
71742 ANUM=ALPCOR*(2D0-X1-X2)**2
71744 ANUM=0.5D0*(2D0-X1-X2)**2
71746 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71747 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71748 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71749 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71754 C...Find relevant LO and FO expression.
71755 IF(ICOMBI.EQ.0) THEN
71756 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
71759 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
71762 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71763 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
71764 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
71765 ELSEIF(ISSET4.EQ.1) THEN
71768 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71769 RLO=0.5D0*(RLO1+RLO2)
71770 RFO=0.5D0*(RFO1+RFO2)
71771 ELSEIF(ISSET1.EQ.1) THEN
71775 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
71786 C*********************************************************************
71789 C...Modifies an event so as to approximately take into account
71790 C...Bose-Einstein effects according to a simple phenomenological
71791 C...parametrization.
71793 SUBROUTINE PYBOEI(NSAV)
71795 C...Double precision and integer declarations.
71796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71797 IMPLICIT INTEGER(I-N)
71798 INTEGER PYK,PYCHGE,PYCOMP
71799 C...Parameter statement to help give large particle numbers.
71800 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71801 &KEXCIT=4000000,KDIMEN=5000000)
71803 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71806 COMMON/PYINT1/MINT(400),VINT(400)
71807 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
71808 C...Local arrays and data.
71809 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
71810 &BEIW(100),BEI3W(100)
71811 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
71812 C...Statement function: squared invariant mass.
71813 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
71814 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
71816 C...Boost event to overall CM frame. Calculate CM energy.
71817 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
71823 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
71824 & .AND.K(I,3).GT.0) THEN
71825 KFMA=IABS(K(K(I,3),2))
71826 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
71828 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
71830 DPS(J)=DPS(J)+P(I,J)
71833 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
71837 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
71840 C...Check if we have separated strings
71842 C...Reserve copy of particles by species at end of record.
71848 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
71849 NBE(IBE)=NBE(IBE-1)
71851 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
71852 DO 140 IIBE=1,IBE-1
71853 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
71856 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
71858 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
71859 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
71860 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
71863 NBE(IBE)=NBE(IBE)+1
71870 P(NBE(IBE),1)=0.0D0
71871 P(NBE(IBE),2)=0.0D0
71872 P(NBE(IBE),3)=0.0D0
71873 P(NBE(IBE),4)=0.0D0
71874 P(NBE(IBE),5)=0.0D0
71875 SMMIN=MIN(SMMIN,P(I,5))
71876 C...Check if particles comes from different W's or Z's
71877 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
71879 150 IF(K(IM,3).GT.0) THEN
71881 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
71883 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
71884 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
71885 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
71886 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
71889 C...Check if particles comes from different strings.
71890 IF(PARJ(94).GT.0.0D0) THEN
71892 160 IF(K(IM,3).GT.0) THEN
71894 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
71902 P(NBE(IBE),5)=-1.0D0
71905 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
71907 C...Calculate separation between W+ and W- or between two Z0's.
71908 C...No separation if there has been re-connections.
71910 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
71911 IF(K(IWP,2).EQ.23) THEN
71920 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
71921 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
71922 TAUP=-TAUPD*LOG(PYR(IDUM))
71923 TAUN=-TAUND*LOG(PYR(IDUM))
71924 DXP=TAUP*PYP(IWP,8)/DMP
71925 DXN=TAUN*PYP(IWN,8)/DMN
71927 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
71928 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
71931 C...Add separation between strings.
71932 IF(PARJ(94).GT.0.0D0) THEN
71933 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
71938 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
71939 DO 220 IBE=1,MIN(9,MSTJ(52))
71940 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
71943 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
71944 IF(I2M.EQ.I1M) GOTO 200
71946 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
71947 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
71948 & (P(I1,5)+P(I2,5))**2
71949 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
71958 C...Tabulate integral for subsequent momentum shift.
71959 DO 400 IBE=1,MIN(9,MSTJ(52))
71960 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
71961 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
71963 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
71964 & NBE(7)-NBE(6)).LE.1) GOTO 270
71965 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
71966 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
71967 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
71968 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
71969 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
71970 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
71971 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
71972 QDELW=0.1D0*MIN(PMHQ,SIGW)
71973 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
71974 IF(MSTJ(51).EQ.1) THEN
71975 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
71976 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
71977 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
71978 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
71979 BEEX=EXP(0.5D0*QDEL/PARJ(93))
71980 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
71981 BEEXW=EXP(0.5D0*QDELW/SIGW)
71982 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
71983 BERT=EXP(-QDEL/PARJ(93))
71984 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
71985 BERTW=EXP(-QDELW/SIGW)
71986 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
71988 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
71989 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
71990 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
71991 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
71994 QBIN=QDEL*(IBIN-0.5D0)
71995 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71996 IF(MSTJ(51).EQ.1) THEN
71998 BEI(IBIN)=BEI(IBIN)*BEEX
72000 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
72002 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
72004 DO 240 IBIN=1,NBIN3
72005 QBIN=QDEL3*(IBIN-0.5D0)
72006 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
72007 IF(MSTJ(51).EQ.1) THEN
72009 BEI3(IBIN)=BEI3(IBIN)*BEEX3
72011 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
72013 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
72015 DO 250 IBIN=1,NBINW
72016 QBIN=QDELW*(IBIN-0.5D0)
72017 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
72018 IF(MSTJ(51).EQ.1) THEN
72020 BEIW(IBIN)=BEIW(IBIN)*BEEXW
72022 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
72024 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
72026 DO 260 IBIN=1,NBIN3W
72027 QBIN=QDEL3W*(IBIN-0.5D0)
72028 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
72029 & SQRT(QBIN**2+PMHQ**2)
72030 IF(MSTJ(51).EQ.1) THEN
72031 BEEX3W=BEEX3W*BERT3W
72032 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
72034 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
72036 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
72039 C...Loop through particle pairs and find old relative momentum.
72040 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
72042 DO 380 I2M=I1M+1,NBE(IBE)
72043 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
72044 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
72046 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
72047 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
72048 IF(Q2OLD.LE.0.0D0) GOTO 380
72051 C...Calculate new relative momentum.
72056 IF(QOLD.LT.1D-3*QDEL) THEN
72058 ELSEIF(QOLD.LE.QDEL) THEN
72060 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
72063 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
72064 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
72065 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72067 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72069 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
72070 IF(QOLD.LT.1D-3*QDEL3) THEN
72072 ELSEIF(QOLD.LE.QDEL3) THEN
72074 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
72077 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
72078 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
72079 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72081 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72083 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
72086 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
72087 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
72088 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
72090 IF(QOLD.LT.1D-3*QDELW) THEN
72092 ELSEIF(QOLD.LE.QDELW) THEN
72094 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
72097 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
72098 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
72099 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72101 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72103 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
72104 IF(QOLD.LT.1D-3*QDEL3W) THEN
72106 ELSEIF(QOLD.LE.QDEL3W) THEN
72108 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
72111 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
72112 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
72113 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72115 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72117 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
72119 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
72121 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
72123 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
72124 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
72126 IF(MSTJ(54).GE.1) THEN
72127 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
72129 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
72130 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
72132 ELSEIF(MSTJ(54).LE.-1) THEN
72133 EDEL=P(I1,4)+P(I2,4)-
72134 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
72135 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72136 & (P(I1,3)-P(I2,3))**2
72141 SM1=(P(I1,5)+SMMIN)**2
72142 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72143 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
72144 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
72145 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72146 & K(I3M,5).NE.K(I1M,5)) GOTO 360
72148 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
72151 SM3=(P(I3,5)+SMMIN)**2
72152 IF(MSTJ(54).EQ.-2) THEN
72153 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
72154 & S23*MIN(SM1,SM3))*SM1)
72156 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
72157 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
72158 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
72159 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
72161 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
72162 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
72165 IF(WMAX*WI.GE.1.0) GOTO 360
72167 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
72168 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
72169 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
72170 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72171 & K(I4M,5).NE.K(I1M,5)) GOTO 350
72173 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
72175 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
72176 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72177 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
72179 IF(MSTJ(54).EQ.-2) THEN
72183 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
72184 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
72185 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
72186 W=MIN(W,MIN(S23,S24)*S13*S14)
72189 C...weight=1-cos(theta)/mtot2
72190 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
72191 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
72192 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
72193 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
72195 IF(W.LE.WMAX) GOTO 350
72197 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
72198 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
72199 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
72200 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
72201 IF(W.LE.WMAX) GOTO 350
72207 IF(MI4.EQ.0) GOTO 380
72210 EOLD=P(I3,4)+P(I4,4)
72212 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72213 & (P(I3,3)+P(I4,3))**2
72214 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
72215 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
72216 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
72218 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
72219 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
72226 C...Shift momenta and recalculate energies.
72230 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72234 P(I,J)=P(I,J)+P(IM,J)
72236 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72239 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72244 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
72245 440 ALPHA=(ESUMP-ESUM)/PROD
72246 PARJ(96)=PARJ(96)+ALPHA
72249 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72252 P(I,J)=P(I,J)+ALPHA*V(IM,J)
72254 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72257 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72260 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
72264 C...Rescale all momenta for energy conservation.
72268 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
72270 PQS=PQS+P(I,5)**2/P(I,4)
72273 FAC=(PECM-PQS)/(PES-PQS)
72275 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
72279 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72282 C...Boost back to correct reference frame.
72283 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
72285 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
72291 C*********************************************************************
72294 C...Calculates the momentum shift in a system of two particles assuming
72295 C...the relative momentum squared should be shifted to Q2NEW. NI is the
72296 C...last position occupied in /PYJETS/.
72298 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
72300 C...Double precision and integer declarations.
72301 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72302 IMPLICIT INTEGER(I-N)
72303 INTEGER PYK,PYCHGE,PYCOMP
72304 C...Parameter statement to help give large particle numbers.
72305 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72306 &KEXCIT=4000000,KDIMEN=5000000)
72308 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72309 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72310 SAVE /PYJETS/,/PYDAT1/
72311 C...Local arrays and data.
72315 IF(MSTJ(55).EQ.0) THEN
72317 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72318 & (P(I1,3)-P(I2,3))**2
72319 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
72320 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
72324 DA=SE*DE*DP12-DP2*DQ2SE
72325 DB=DP2*DQ2SE-DP12**2
72326 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
72328 PD=HA*(P(I1,J)-P(I2,J))
72340 DP(J)=P(I1,J)+P(I2,J)
72343 C...Boost to cms and rotate first particle to z-axis
72344 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
72345 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
72346 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
72347 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
72348 S=Q2NEW+(P(I1,5)+P(I2,5))**2
72349 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
72353 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
72357 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
72358 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
72359 CALL PYROBO(NI+1,NI+2,THE,PHI,
72360 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
72363 P(NI+1,J)=P(NI+1,J)-P(I1,J)
72364 P(NI+2,J)=P(NI+2,J)-P(I2,J)
72370 C*********************************************************************
72373 C...Gives the mass of a particle/parton.
72375 FUNCTION PYMASS(KF)
72377 C...Double precision and integer declarations.
72378 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72379 IMPLICIT INTEGER(I-N)
72380 INTEGER PYK,PYCHGE,PYCOMP
72382 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72383 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72384 SAVE /PYDAT1/,/PYDAT2/
72386 C...Reset variables. Compressed code. Special case for popcorn diquarks.
72395 C...Guarantee use of constituent masses for internal checks.
72396 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
72397 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
72399 PYMASS=PARF(100+KFA)
72400 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
72401 ELSEIF(KFA.LE.10) THEN
72403 ELSEIF(MSTJ(93).EQ.1) THEN
72404 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
72406 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
72409 C...Other masses can be read directly off table.
72414 C...Optional mass broadening according to truncated Breit-Wigner
72415 C...(either in m or in m^2).
72416 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
72417 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
72418 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
72419 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
72422 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
72423 & (PM0*PMAS(KC,2)))
72424 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
72425 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
72426 & (PMUPP-PMLOW)*PYR(0))))
72434 C*********************************************************************
72437 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72438 C...for Higgs couplings. Everything else sent on to PYMASS.
72440 FUNCTION PYMRUN(KF,Q2)
72442 C...Double precision and integer declarations.
72443 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72444 IMPLICIT INTEGER(I-N)
72445 INTEGER PYK,PYCHGE,PYCOMP
72447 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72448 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72449 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
72450 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
72452 C...Most masses not handled here.
72454 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
72457 C...Current-algebra masses, but no Q2 dependence.
72458 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
72459 PYMRUN=PARF(90+KFA)
72461 C...Running current-algebra masses.
72464 PYMRUN=PARF(90+KFA)*
72465 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
72466 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
72472 C*********************************************************************
72475 C...Gives the particle/parton name as a character string.
72477 SUBROUTINE PYNAME(KF,CHAU)
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 COMMON/PYDAT4/CHAF(500,2)
72488 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
72489 C...Local character variable.
72492 C...Read out code with distinction particle/antiparticle.
72495 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
72501 C*********************************************************************
72504 C...Gives three times the charge for a particle/parton.
72506 FUNCTION PYCHGE(KF)
72508 C...Double precision and integer declarations.
72509 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72510 IMPLICIT INTEGER(I-N)
72511 INTEGER PYK,PYCHGE,PYCOMP
72513 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72516 C...Read out charge and change sign for antiparticle.
72519 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
72524 C*********************************************************************
72527 C...Compress the standard KF codes for use in mass and decay arrays;
72528 C...also checks whether a given code actually is defined.
72530 FUNCTION PYCOMP(KF)
72532 C...Double precision and integer declarations.
72533 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72534 IMPLICIT INTEGER(I-N)
72535 INTEGER PYK,PYCHGE,PYCOMP
72537 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72538 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72539 SAVE /PYDAT1/,/PYDAT2/
72540 C...Local arrays and saved data.
72541 DIMENSION KFORD(100:500),KCORD(101:500)
72542 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
72544 C...Whenever necessary reorder codes for faster search.
72545 IF(MSTU(20).EQ.0) THEN
72550 IF(KFA.LE.100) GOTO 120
72552 DO 100 I1=NFORD-1,0,-1
72553 IF(KFA.GE.KFORD(I1)) GOTO 110
72554 KFORD(I1+1)=KFORD(I1)
72555 KCORD(I1+1)=KCORD(I1)
72557 110 KFORD(I1+1)=KFA
72565 C...Fast action if same code as in latest call.
72566 IF(KF.EQ.KFLAST) THEN
72571 C...Starting values. Remove internal diquark flags.
72574 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
72575 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
72577 C...Simple cases: direct translation.
72578 IF(KFA.GT.KFORD(NFORD)) THEN
72579 ELSEIF(KFA.LE.100) THEN
72582 C...Else binary search.
72586 130 IAVG=(IMIN+IMAX)/2
72587 IF(KFORD(IAVG).GT.KFA) THEN
72589 IF(IMAX.GT.IMIN+1) GOTO 130
72590 ELSEIF(KFORD(IAVG).LT.KFA) THEN
72592 IF(IMAX.GT.IMIN+1) GOTO 130
72598 C...Check if antiparticle allowed.
72599 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
72600 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
72603 C...Save codes for possible future fast action.
72610 C*********************************************************************
72613 C...Informs user of errors in program execution.
72615 SUBROUTINE PYERRM(MERR,CHMESS)
72617 C...Double precision and integer declarations.
72618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72619 IMPLICIT INTEGER(I-N)
72620 INTEGER PYK,PYCHGE,PYCOMP
72622 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72623 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72624 SAVE /PYJETS/,/PYDAT1/
72625 C...Local character variable.
72626 CHARACTER CHMESS*(*)
72628 C...Write first few warnings, then be silent.
72629 IF(MERR.LE.10) THEN
72630 MSTU(27)=MSTU(27)+1
72632 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
72633 & MERR,MSTU(31),CHMESS
72635 C...Write first few errors, then be silent or stop program.
72636 ELSEIF(MERR.LE.20) THEN
72637 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
72638 MSTU(30)=MSTU(30)+1
72640 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
72641 & MERR-10,MSTU(31),CHMESS
72642 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
72643 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
72644 WRITE(MSTU(11),5200)
72645 IF(MERR.NE.17) CALL PYLIST(2)
72649 C...Stop program in case of irreparable error.
72651 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
72655 C...Formats for output.
72656 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
72657 &' PYEXEC calls:'/5X,A)
72658 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
72659 &' PYEXEC calls:'/5X,A)
72660 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
72662 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
72663 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
72668 C*********************************************************************
72671 C...Calculates the running alpha_electromagnetic.
72673 FUNCTION PYALEM(Q2)
72675 C...Double precision and integer declarations.
72676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72677 IMPLICIT INTEGER(I-N)
72678 INTEGER PYK,PYCHGE,PYCOMP
72680 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72683 C...Calculate real part of photon vacuum polarization.
72684 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72685 C...For hadrons use parametrization of H. Burkhardt et al.
72686 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72687 AEMPI=PARU(101)/(3D0*PARU(1))
72688 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
72690 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
72692 ELSEIF(MSTU(101).EQ.2) THEN
72693 RPIGG=1D0-PARU(101)/PARU(103)
72694 ELSEIF(Q2.LT.0.09D0) THEN
72695 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
72696 ELSEIF(Q2.LT.9D0) THEN
72697 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
72698 & 0.00238D0*LOG(1D0+3.927D0*Q2)
72699 ELSEIF(Q2.LT.1D4) THEN
72700 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
72701 & 0.00299D0*LOG(1D0+Q2)
72703 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
72704 & 0.00293D0*LOG(1D0+Q2)
72707 C...Calculate running alpha_em.
72708 PYALEM=PARU(101)/(1D0-RPIGG)
72714 C*********************************************************************
72717 C...Gives the value of alpha_strong.
72719 FUNCTION PYALPS(Q2)
72721 C...Double precision and integer declarations.
72722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72723 IMPLICIT INTEGER(I-N)
72724 INTEGER PYK,PYCHGE,PYCOMP
72726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72728 SAVE /PYDAT1/,/PYDAT2/
72729 C...Coefficients for second-order threshold matching.
72730 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72731 DIMENSION STEPDN(6),STEPUP(6)
72732 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72733 c &(2D0*321D0/3703D0),0D0/
72734 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72735 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72736 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
72737 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
72739 C...Constant alpha_strong trivial. Pick artificial Lambda.
72740 IF(MSTU(111).LE.0) THEN
72742 MSTU(118)=MSTU(112)
72744 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
72745 & ((33D0-2D0*MSTU(112))*PARU(111)))
72746 PARU(118)=PARU(111)
72750 C...Find effective Q2, number of flavours and Lambda.
72752 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
72755 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
72756 Q2THR=PARU(113)*PMAS(NF,1)**2
72757 IF(Q2EFF.LT.Q2THR) THEN
72760 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
72761 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
72765 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
72766 Q2THR=PARU(113)*PMAS(NF+1,1)**2
72767 IF(Q2EFF.GT.Q2THR) THEN
72770 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
72771 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
72775 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
72776 PARU(117)=SQRT(ALAM2)
72778 C...Evaluate first or second order alpha_strong.
72779 B0=(33D0-2D0*NF)/6D0
72780 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
72781 IF(MSTU(111).EQ.1) THEN
72782 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
72784 B1=(153D0-19D0*NF)/6D0
72785 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
72794 C*********************************************************************
72797 C...Reconstructs an angle from given x and y coordinates.
72799 FUNCTION PYANGL(X,Y)
72801 C...Double precision and integer declarations.
72802 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72803 IMPLICIT INTEGER(I-N)
72804 INTEGER PYK,PYCHGE,PYCOMP
72806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72811 IF(R.LT.1D-20) RETURN
72812 IF(ABS(X)/R.LT.0.8D0) THEN
72813 PYANGL=SIGN(ACOS(X/R),Y)
72816 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
72817 PYANGL=PARU(1)-PYANGL
72818 ELSEIF(X.LT.0D0) THEN
72819 PYANGL=-PARU(1)-PYANGL
72826 C*********************************************************************
72829 C...Performs rotations and boosts.
72831 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72833 C...Double precision and integer declarations.
72834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72835 IMPLICIT INTEGER(I-N)
72836 INTEGER PYK,PYCHGE,PYCOMP
72838 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72839 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72840 SAVE /PYJETS/,/PYDAT1/
72842 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
72844 C...Find and check range of rotation/boost.
72846 IF(IMIN.LE.0) IMIN=1
72847 IF(MSTU(1).GT.0) IMIN=MSTU(1)
72849 IF(IMAX.LE.0) IMAX=N
72850 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72851 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
72852 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
72856 C...Optional resetting of V (when not set before.)
72857 IF(MSTU(33).NE.0) THEN
72858 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
72866 C...Rotate, typically from z axis to direction (theta,phi).
72867 IF(THE**2+PHI**2.GT.1D-20) THEN
72868 ROT(1,1)=COS(THE)*COS(PHI)
72870 ROT(1,3)=SIN(THE)*COS(PHI)
72871 ROT(2,1)=COS(THE)*SIN(PHI)
72873 ROT(2,3)=SIN(THE)*SIN(PHI)
72878 IF(K(I,1).LE.0) GOTO 140
72884 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
72885 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
72890 C...Boost, typically from rest to momentum/energy=beta.
72891 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
72895 DB=SQRT(DBX**2+DBY**2+DBZ**2)
72897 IF(DB.GT.EPS1) THEN
72898 C...Rescale boost vector if too close to unity.
72899 CALL PYERRM(3,'(PYROBO:) boost vector too large')
72905 DGA=1D0/SQRT(1D0-DB**2)
72907 IF(K(I,1).LE.0) GOTO 160
72912 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
72913 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
72914 P(I,1)=DP(1)+DGABP*DBX
72915 P(I,2)=DP(2)+DGABP*DBY
72916 P(I,3)=DP(3)+DGABP*DBZ
72917 P(I,4)=DGA*(DP(4)+DBP)
72918 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
72919 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
72920 V(I,1)=DV(1)+DGABV*DBX
72921 V(I,2)=DV(2)+DGABV*DBY
72922 V(I,3)=DV(3)+DGABV*DBZ
72923 V(I,4)=DGA*(DV(4)+DBV)
72930 C*********************************************************************
72933 C...Performs global manipulations on the event record, in particular
72934 C...to exclude unstable or undetectable partons/particles.
72936 SUBROUTINE PYEDIT(MEDIT)
72938 C...Double precision and integer declarations.
72939 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72940 IMPLICIT INTEGER(I-N)
72941 INTEGER PYK,PYCHGE,PYCOMP
72942 C...Parameter statement to help give large particle numbers.
72943 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72944 &KEXCIT=4000000,KDIMEN=5000000)
72946 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72947 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72948 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72949 COMMON/PYCTAG/NCT,MCT(4000,2)
72950 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
72952 DIMENSION NS(2),PTS(2),PLS(2)
72954 C...Remove unwanted partons/particles.
72955 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
72957 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72958 I1=MAX(1,MSTU(1))-1
72959 DO 110 I=MAX(1,MSTU(1)),IMAX
72960 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
72961 IF(MEDIT.EQ.1) THEN
72962 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72963 ELSEIF(MEDIT.EQ.2) THEN
72964 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72966 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72967 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72968 & K(I,2).EQ.KSUSY1+39) GOTO 110
72969 ELSEIF(MEDIT.EQ.3) THEN
72970 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72972 IF(KC.EQ.0) GOTO 110
72973 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
72974 ELSEIF(MEDIT.EQ.5) THEN
72975 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
72977 IF(KC.EQ.0) GOTO 110
72978 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
72979 & KCHG(KC,2).EQ.0) GOTO 110
72982 C...Pack remaining partons/particles. Origin no longer known.
72991 IF(I1.LT.N) MSTU(3)=0
72992 IF(I1.LT.N) MSTU(70)=0
72995 C...Selective removal of class of entries. New position of retained.
72996 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
72999 K(I,3)=MOD(K(I,3),MSTU(5))
73000 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
73001 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
73002 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
73003 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
73004 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
73005 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
73006 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
73008 K(I,3)=K(I,3)+MSTU(5)*I1
73011 C...Find new event history information and replace old.
73013 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
73014 & K(I,3)/MSTU(5).EQ.0) GOTO 140
73016 130 IM=MOD(K(ID,3),MSTU(5))
73017 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
73018 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
73019 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
73023 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
73024 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
73025 & K(IM,2).EQ.94) THEN
73030 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
73031 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
73032 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
73033 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
73034 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
73035 & K(K(I,4),3)/MSTU(5)
73036 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
73037 & K(K(I,5),3)/MSTU(5)
73039 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
73040 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
73041 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
73042 KCD=MOD(K(I,4),MSTU(5))
73043 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
73044 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
73045 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
73046 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
73047 KCD=MOD(K(I,5),MSTU(5))
73048 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
73049 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
73053 C...Pack remaining entries.
73058 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
73065 C...Also update LHA1 colour tags
73068 K(I1,3)=MOD(K(I1,3),MSTU(5))
73070 IF(I.EQ.MSTU(90+IZ)) THEN
73071 MSTU(90)=MSTU(90)+1
73072 MSTU(90+MSTU(90))=I1
73073 PARU(90+MSTU(90))=PARU(90+IZ)
73077 IF(I1.LT.N) MSTU(3)=0
73078 IF(I1.LT.N) MSTU(70)=0
73081 C...Fill in some missing daughter pointers (lost in colour flow).
73082 ELSEIF(MEDIT.EQ.16) THEN
73084 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
73085 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
73086 C...Find daughters who point to mother.
73088 IF(K(I1,3).NE.I) THEN
73089 ELSEIF(K(I,4).EQ.0) THEN
73095 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73096 IF(K(I,4).NE.0) GOTO 220
73097 C...Find daughters who point to documentation version of mother.
73099 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
73100 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
73101 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
73103 IF(K(I1,3).NE.IM) THEN
73104 ELSEIF(K(I,4).EQ.0) THEN
73110 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73111 IF(K(I,4).NE.0) GOTO 220
73112 C...Find daughters who point to documentation daughters who,
73113 C...in their turn, point to documentation mother.
73117 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
73119 IF(ID1.EQ.IM) ID1=I1
73123 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
73124 ELSEIF(K(I,4).EQ.0) THEN
73130 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73133 C...Save top entries at bottom of PYJETS commonblock.
73134 ELSEIF(MEDIT.EQ.21) THEN
73135 IF(2*N.GE.MSTU(4)) THEN
73136 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
73141 K(MSTU(4)-I,J)=K(I,J)
73142 P(MSTU(4)-I,J)=P(I,J)
73143 V(MSTU(4)-I,J)=V(I,J)
73148 C...Restore bottom entries of commonblock PYJETS to top.
73149 ELSEIF(MEDIT.EQ.22) THEN
73150 DO 260 I=1,MSTU(32)
73152 K(I,J)=K(MSTU(4)-I,J)
73153 P(I,J)=P(MSTU(4)-I,J)
73154 V(I,J)=V(MSTU(4)-I,J)
73159 C...Mark primary entries at top of commonblock PYJETS as untreated.
73160 ELSEIF(MEDIT.EQ.23) THEN
73165 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
73167 IF(KH.NE.0) GOTO 280
73169 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
73170 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
73174 C...Place largest axis along z axis and second largest in xy plane.
73175 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
73176 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
73177 & P(MSTU(61),2)),0D0,0D0,0D0)
73178 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
73179 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
73180 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
73181 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
73182 IF(MEDIT.EQ.31) RETURN
73184 C...Rotate to put slim jet along +z axis.
73191 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
73192 IF(MSTU(41).GE.2) THEN
73194 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73195 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73196 & K(I,2).EQ.KSUSY1+39) GOTO 300
73197 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73200 IS=2D0-SIGN(0.5D0,P(I,3))
73202 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
73204 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
73205 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
73207 C...Rotate to put second largest jet into -z,+x quadrant.
73209 IF(P(I,3).GE.0D0) GOTO 310
73210 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
73211 IF(MSTU(41).GE.2) THEN
73213 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73214 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73215 & K(I,2).EQ.KSUSY1+39) GOTO 310
73216 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73219 IS=2D0-SIGN(0.5D0,P(I,1))
73220 PLS(IS)=PLS(IS)-P(I,3)
73222 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
73229 C*********************************************************************
73232 C...Gives program heading, or lists an event, or particle
73233 C...data, or current parameter values.
73235 SUBROUTINE PYLIST(MLIST)
73237 C...Double precision and integer declarations.
73238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73239 IMPLICIT INTEGER(I-N)
73240 INTEGER PYK,PYCHGE,PYCOMP
73241 C...Parameter statement to help give large particle numbers.
73242 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73243 &KEXCIT=4000000,KDIMEN=5000000)
73245 C...HEPEVT commonblock.
73246 PARAMETER (NMXHEP=4000)
73247 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
73248 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
73249 DOUBLE PRECISION PHEP,VHEP
73252 C...User process event common block.
73254 PARAMETER (MAXNUP=500)
73255 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73256 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73257 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
73258 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
73259 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
73263 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73264 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73265 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73266 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73267 COMMON/PYCTAG/NCT,MCT(4000,2)
73268 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
73269 C...Local arrays, character variables and data.
73270 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73272 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
73274 C...Initialization printout: version number and date of last change.
73275 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
73278 IF(MLIST.EQ.0) RETURN
73281 C...List event data, including additional lines after N.
73282 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
73283 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
73284 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
73285 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
73286 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
73288 IF(MLIST.GE.2) LMX=16
73291 IF(MSTU(2).GT.0) IMAX=MSTU(2)
73292 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
73293 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
73294 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
73295 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
73297 C...Get particle name, pad it and check it is not too long.
73298 CALL PYNAME(K(I,2),CHAP)
73301 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
73305 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
73307 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
73310 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
73312 CHAC=CHDL(MDL)(1:2*LDL)//' '
73314 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
73315 & CHDL(MDL)(LDL+1:2*LDL)//' '
73316 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
73320 C...Add information on string connection.
73321 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
73325 IF(KC.NE.0) KCC=KCHG(KC,2)
73326 IF(IABS(K(I,2)).EQ.39) THEN
73327 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
73328 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
73330 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
73331 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
73332 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
73333 ELSEIF(KCC.NE.0) THEN
73335 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
73338 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
73339 & CHAC(LMX-1:LMX-1)='I'
73341 C...Write data for particle/jet.
73342 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
73343 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
73345 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
73346 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
73348 ELSEIF(MLIST.EQ.1) THEN
73349 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
73351 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
73352 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
73353 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
73354 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73355 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
73357 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
73358 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73359 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
73360 & ,10000),MCT(I,1),MCT(I,2)
73362 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
73364 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
73365 & ,MCT(I,1),MCT(I,2)
73367 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
73369 C...Insert extra separator lines specified by user.
73370 IF(MSTU(70).GE.1) THEN
73372 DO 110 J=1,MIN(10,MSTU(70))
73373 IF(I.EQ.MSTU(70+J)) ISEP=1
73376 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
73377 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
73378 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
73383 C...Sum of charges and momenta.
73387 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
73388 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
73389 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
73390 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
73391 ELSEIF(MLIST.EQ.1) THEN
73392 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
73393 ELSEIF(MLIST.LE.3) THEN
73394 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
73396 WRITE(MSTU(11),7000) PS(6)
73399 C...Simple listing of HEPEVT entries (mainly for test purposes).
73400 ELSEIF(MLIST.EQ.5) THEN
73401 WRITE(MSTU(11),7100)
73403 IF(ISTHEP(I).EQ.0) GOTO 140
73404 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
73405 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
73409 C...Simple listing of user-process entries (mainly for test purposes).
73410 ELSEIF(MLIST.EQ.7) THEN
73411 WRITE(MSTU(11),7300)
73413 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
73414 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
73417 C...Give simple list of KF codes defined in program.
73418 ELSEIF(MLIST.EQ.11) THEN
73419 WRITE(MSTU(11),7500)
73421 CALL PYNAME(KF,CHAP)
73422 CALL PYNAME(-KF,CHAN)
73423 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73424 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73428 DO 170 KFLB=1,KFLA-(3-KFLS)/2
73429 KF=1000*KFLA+100*KFLB+KFLS
73430 CALL PYNAME(KF,CHAP)
73431 CALL PYNAME(-KF,CHAN)
73432 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73438 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
73439 IF(KMUL.EQ.5) KFLS=5
73441 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
73442 IF(KMUL.EQ.4) KFLR=2
73444 DO 200 KFLC=1,KFLB-1
73445 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
73446 CALL PYNAME(KF,CHAP)
73447 CALL PYNAME(-KF,CHAN)
73448 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73451 CALL PYNAME(KFK,CHAP)
73452 WRITE(MSTU(11),7600) KFK,CHAP
73454 CALL PYNAME(KFK,CHAP)
73455 WRITE(MSTU(11),7600) KFK,CHAP
73458 KF=10000*KFLR+110*KFLB+KFLS
73459 CALL PYNAME(KF,CHAP)
73460 WRITE(MSTU(11),7600) KF,CHAP
73464 CALL PYNAME(KF,CHAP)
73465 WRITE(MSTU(11),7600) KF,CHAP
73467 CALL PYNAME(KF,CHAP)
73468 WRITE(MSTU(11),7600) KF,CHAP
73474 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
73476 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
73477 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
73478 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
73479 CALL PYNAME(KF,CHAP)
73480 CALL PYNAME(-KF,CHAN)
73481 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73488 IF(KF.LT.1000000) GOTO 270
73489 CALL PYNAME(KF,CHAP)
73490 CALL PYNAME(-KF,CHAN)
73491 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73492 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73495 C...List parton/particle data table. Check whether to be listed.
73496 ELSEIF(MLIST.EQ.12) THEN
73497 WRITE(MSTU(11),7700)
73498 DO 300 KC=1,MSTU(6)
73500 IF(KF.EQ.0) GOTO 300
73501 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
73504 C...Find particle name and mass. Print information.
73505 CALL PYNAME(KF,CHAP)
73506 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
73507 CALL PYNAME(-KF,CHAN)
73508 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
73509 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
73511 C...Particle decay: channel number, branching ratios, matrix element,
73512 C...decay products.
73513 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73515 CALL PYNAME(KFDP(IDC,J),CHAD(J))
73517 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73522 C...List parameter value table.
73523 ELSEIF(MLIST.EQ.13) THEN
73524 WRITE(MSTU(11),8000)
73526 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
73530 C...Format statements for output on unit MSTU(11) (by default 6).
73531 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
73532 &5X,'KF orig p_x p_y p_z E m'/)
73533 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
73534 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73535 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73536 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
73537 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73538 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
73539 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73540 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
73541 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
73542 & ,' C tag AC tag'/)
73543 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
73544 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
73545 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
73546 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
73547 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
73548 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
73549 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
73550 6200 FORMAT(66X,5(1X,F12.3))
73551 6300 FORMAT(1X,78('='))
73552 6400 FORMAT(1X,130('='))
73553 6500 FORMAT(1X,65('='))
73554 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
73555 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
73556 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
73557 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
73559 7000 FORMAT(19X,'sum charge:',F6.2)
73560 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
73561 &//' I IST ID Mothers Daughters p_x p_y p_z',
73563 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
73564 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
73565 &//' I IST ID Mothers Colours p_x p_y p_z',
73567 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
73568 7500 FORMAT(///20X,'List of KF codes in program'/)
73569 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
73570 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
73571 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
73572 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
73573 &1X,'ME',3X,'Br.rat.',4X,'decay products')
73574 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
73575 &1X,1P,E13.5,3X,I2)
73576 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
73577 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
73578 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
73579 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
73584 C*********************************************************************
73587 C...Writes a logo for the program.
73591 C...Double precision and integer declarations.
73592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73593 IMPLICIT INTEGER(I-N)
73594 INTEGER PYK,PYCHGE,PYCOMP
73595 C...Parameter for length of information block.
73596 PARAMETER (IREFER=21)
73598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73599 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
73600 SAVE /PYDAT1/,/PYPARS/
73601 C...Local arrays and character variables.
73603 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73604 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
73606 C...Data on months, logo, titles, and references.
73607 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73608 &'Oct','Nov','Dec'/
73609 DATA (LOGO(J),J=1,19)/
73611 &' *:::!!:::::::::::* ',
73612 &' *::::::!!::::::::::::::* ',
73613 &' *::::::::!!::::::::::::::::* ',
73614 &' *:::::::::!!:::::::::::::::::* ',
73615 &' *:::::::::!!:::::::::::::::::* ',
73616 &' *::::::::!!::::::::::::::::*! ',
73617 &' *::::::!!::::::::::::::* !! ',
73618 &' !! *:::!!:::::::::::* !! ',
73619 &' !! !* -><- * !! ',
73629 DATA (LOGO(J),J=20,38)/
73630 &'Welcome to the Lund Monte Carlo!',
73632 &'PPP Y Y TTTTT H H III A ',
73633 &'P P Y Y T H H I A A ',
73634 &'PPP Y T HHHHH I AAAAA',
73635 &'P Y T H H I A A',
73636 &'P Y T H H III A A',
73638 &'This is PYTHIA version x.xxx ',
73639 &'Last date of change: xx xxx 200x',
73641 &'Now is xx xxx 200x at xx:xx:xx ',
73643 &'Disclaimer: this program comes ',
73644 &'without any guarantees. Beware ',
73645 &'of errors and use common sense ',
73646 &'when interpreting results. ',
73648 &'Copyright T. Sjostrand (2008) '/
73649 DATA (REFER(J),J=1,14)/
73650 &'An archive of program versions and d',
73651 &'ocumentation is found on the web: ',
73652 &'http://www.thep.lu.se/~torbjorn/Pyth',
73656 &'When you cite this program, the offi',
73657 &'cial reference is to the 6.4 manual:',
73658 &'T. Sjostrand, S. Mrenna and P. Skand',
73659 &'s, JHEP05 (2006) 026 ',
73660 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73661 &'-T) [hep-ph/0603175]. ',
73664 DATA (REFER(J),J=15,32)/
73665 &'Also remember that the program, to a',
73666 &' large extent, represents original ',
73667 &'physics research. Other publications',
73668 &' of special relevance to your ',
73669 &'studies may therefore deserve separa',
73673 &'Main author: Torbjorn Sjostrand; Dep',
73674 &'artment of Theoretical Physics, ',
73675 &' Lund University, Solvegatan 14A, S',
73676 &'-223 62 Lund, Sweden; ',
73677 &' phone: + 46 - 46 - 222 48 16; e-ma',
73678 &'il: torbjorn@thep.lu.se ',
73679 &'Author: Stephen Mrenna; Computing Di',
73680 &'vision, GDS Group, ',
73681 &' Fermi National Accelerator Laborat',
73682 &'ory, MS 234, Batavia, IL 60510, USA;'/
73683 DATA (REFER(J),J=33,2*IREFER)/
73684 &' phone: + 1 - 630 - 840 - 2556; e-m',
73685 &'ail: mrenna@fnal.gov ',
73686 &'Author: Peter Skands; Theoretical Ph',
73687 &'ysics Department, ',
73688 &' Fermi National Accelerator Laborat',
73689 &'ory, MS 106, Batavia, IL 60510, USA;',
73690 &' and CERN/PH, CH-1211 Geneva, Switz',
73692 &' phone: + 41 - 22 - 767 24 59; e-ma',
73693 &'il: skands@fnal.gov '/
73695 C...Check that PYDATA linked.
73696 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
73698 & 'Error: PYDATA has not been linked.'
73699 WRITE(*,'(1X,A)') 'Execution stopped!'
73702 C...Write current version number and current date+time.
73704 WRITE(VERS,'(I1)') MSTP(181)
73705 LOGO(28)(24:24)=VERS
73706 WRITE(SUBV,'(I3)') MSTP(182)
73707 LOGO(28)(26:28)=SUBV
73708 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
73709 WRITE(DATE,'(I2)') MSTP(185)
73710 LOGO(29)(22:23)=DATE
73711 LOGO(29)(25:27)=MONTH(MSTP(184))
73712 WRITE(YEAR,'(I4)') MSTP(183)
73713 LOGO(29)(29:32)=YEAR
73715 IF(IDATI(1).LE.0) THEN
73718 WRITE(DATE,'(I2)') IDATI(3)
73720 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
73721 WRITE(YEAR,'(I4)') IDATI(1)
73722 LOGO(31)(15:18)=YEAR
73723 WRITE(HOUR,'(I2)') IDATI(4)
73724 LOGO(31)(23:24)=HOUR
73725 WRITE(MINU,'(I2)') IDATI(5)
73726 LOGO(31)(26:27)=MINU
73727 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
73728 WRITE(SECO,'(I2)') IDATI(6)
73729 LOGO(31)(29:30)=SECO
73730 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
73734 C...Loop over lines in header. Define page feed and side borders.
73735 DO 100 ILIN=1,29+IREFER
73744 C...Separator lines and logos.
73745 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
73746 LINE(4:77)='***********************************************'//
73747 & '***************************'
73748 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
73749 LINE(6:37)=LOGO(ILIN-5)
73750 LINE(44:75)=LOGO(ILIN+14)
73751 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
73752 LINE(5:40)=REFER(2*ILIN-51)
73753 LINE(41:76)=REFER(2*ILIN-50)
73756 C...Write lines to appropriate unit.
73757 WRITE(MSTU(11),'(A79)') LINE
73763 C*********************************************************************
73766 C...Facilitates the updating of particle and decay data
73767 C...by allowing it to be done in an external file.
73769 SUBROUTINE PYUPDA(MUPDA,LFN)
73771 C...Double precision and integer declarations.
73772 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73773 IMPLICIT INTEGER(I-N)
73774 INTEGER PYK,PYCHGE,PYCOMP
73776 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73777 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73778 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73779 COMMON/PYDAT4/CHAF(500,2)
73781 COMMON/PYINT4/MWID(500),WIDS(500,5)
73782 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
73783 C...Local arrays, character variables and data.
73784 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73785 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
73786 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73787 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73788 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73789 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73790 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73792 C...Write header if not yet done.
73793 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73795 C...Write information on file for editing.
73796 IF(MUPDA.EQ.1) THEN
73798 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73799 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73800 & MWID(KC),MDCY(KC,1)
73801 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73802 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73803 & (KFDP(IDC,J),J=1,5)
73807 C...Read complete set of information from edited file or
73808 C...read partial set of new or updated information from edited file.
73809 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
73811 C...Reset counters.
73815 IF(MUPDA.EQ.2) THEN
73820 DO 130 KC=1,MSTU(6)
73821 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
73822 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
73826 C...Begin of loop: read new line; unknown whether particle or
73828 140 READ(LFN,5200,END=190) CHINL
73830 C...Identify particle code and whether already defined (for MUPDA=3).
73831 IF(CHINL(2:10).NE.' ') THEN
73834 IF(MUPDA.EQ.2) THEN
73847 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
73850 C...Remove duplicate old decay data.
73851 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
73852 IDCREP=MDCY(KCREP,2)
73853 NDCREP=MDCY(KCREP,3)
73855 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
73857 DO 180 I=IDCREP,NDC-NDCREP
73858 MDME(I,1)=MDME(I+NDCREP,1)
73859 MDME(I,2)=MDME(I+NDCREP,2)
73860 BRAT(I)=BRAT(I+NDCREP)
73862 KFDP(I,J)=KFDP(I+NDCREP,J)
73867 ELSEIF(KCREP.NE.0) THEN
73875 C...Study line with particle data.
73876 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
73877 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
73878 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73879 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73880 & MWID(KC),MDCY(KC,1)
73884 C...Study line with decay data.
73887 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
73888 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
73889 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
73890 MDCY(KC,3)=MDCY(KC,3)+1
73891 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
73892 & (KFDP(NDC,J),J=1,5)
73895 C...End of loop; ensure that PYCOMP tables are updated.
73900 C...Perform possible tests that new information is consistent.
73901 DO 220 KC=1,MSTU(6)
73903 IF(KF.EQ.0) GOTO 220
73904 WRITE(CHKF,5300) KF
73905 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
73906 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
73907 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
73909 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73910 IF(MDME(IDC,2).GT.80) GOTO 210
73912 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
73916 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
73918 ELSEIF(PYCOMP(KP).EQ.0) THEN
73923 PMS=PMS-PMAS(KPC,1)
73924 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
73928 IF(KQ.NE.0) MERR=MAX(2,MERR)
73929 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
73931 IF(MERR.EQ.3) CALL PYERRM(17,
73932 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
73933 IF(MERR.EQ.2) CALL PYERRM(17,
73934 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
73935 IF(MERR.EQ.1) CALL PYERRM(7,
73936 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
73937 BRSUM=BRSUM+BRAT(IDC)
73939 WRITE(CHTMP,5500) BRSUM
73940 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
73941 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
73942 & CHTMP(9:16)//' for KF ='//CHKF)
73945 C...Write DATA statements for inclusion in program.
73946 ELSEIF(MUPDA.EQ.4) THEN
73948 C...Find out how many codes and decay channels are actually used.
73952 IF(KCHG(I,4).NE.0) THEN
73954 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
73958 C...Initialize writing of DATA statements for inclusion in program.
73961 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
73964 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
73968 C...Loop through variables for conversion to characters.
73970 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
73971 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
73972 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
73973 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
73974 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
73975 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
73976 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
73977 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
73978 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
73979 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
73980 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
73981 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
73982 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
73983 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
73984 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
73985 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
73986 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
73987 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
73988 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
73989 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
73990 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
73991 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
73993 C...Replace variables beyond what is properly defined.
73995 IF(IDIM.GT.KCC) CHTMP=' 0'
73996 ELSEIF(IVAR.LE.8) THEN
73997 IF(IDIM.GT.KCC) CHTMP=' 0.0'
73998 ELSEIF(IVAR.LE.11) THEN
73999 IF(IDIM.GT.KCC) CHTMP=' 0'
74000 ELSEIF(IVAR.LE.13) THEN
74001 IF(IDIM.GT.NDC) CHTMP=' 0'
74002 ELSEIF(IVAR.LE.14) THEN
74003 IF(IDIM.GT.NDC) CHTMP=' 0.0'
74004 ELSEIF(IVAR.LE.19) THEN
74005 IF(IDIM.GT.NDC) CHTMP=' 0'
74006 ELSEIF(IVAR.LE.21) THEN
74007 IF(IDIM.GT.KCC) CHTMP=' '
74009 IF(IDIM.GT.KCC) CHTMP=' 0'
74012 C...Length of variable, trailing decimal zeros, quotation marks.
74016 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
74017 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
74019 CHNEW=CHTMP(LLOW:LHIG)//' '
74021 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
74024 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
74025 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
74030 CHNEW(LNEW+1:LNEW+2)='D0'
74033 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
74034 DO 260 LL=LNEW,1,-1
74035 IF(CHNEW(LL:LL).EQ.'''') THEN
74037 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
74043 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
74047 C...Form composite character string, often including repetition counter.
74048 IF(CHNEW.NE.CHOLD) THEN
74055 IF(NRPT.GE.2) LRPT=LNEW+3
74056 IF(NRPT.GE.10) LRPT=LNEW+4
74057 IF(NRPT.GE.100) LRPT=LNEW+5
74058 IF(NRPT.GE.1000) LRPT=LNEW+6
74061 WRITE(CHTMP,5400) NRPT
74063 IF(NRPT.GE.10) LRPT=2
74064 IF(NRPT.GE.100) LRPT=3
74065 IF(NRPT.GE.1000) LRPT=4
74066 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
74070 C...Add characters to end of line, to new line (after storing old line),
74071 C...or to new block of lines (after writing old block).
74072 IF(LLIN+LCOM.LE.70) THEN
74073 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
74075 ELSEIF(NLIN.LE.19) THEN
74076 CHLIN(LLIN+1:72)=' '
74079 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
74082 CHLIN(LLIN:72)='/'//' '
74084 WRITE(CHTMP,5400) IDIM-NRPT
74085 CHBLK(1)(30:33)=CHTMP(13:16)
74087 WRITE(LFN,5700) CHBLK(ILIN)
74091 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
74092 & ',I= , )/'//CHCOM(1:LCOM)//','
74093 WRITE(CHTMP,5400) IDIM-NRPT+1
74094 CHLIN(25:28)=CHTMP(13:16)
74099 C...Write final block of lines.
74100 CHLIN(LLIN:72)='/'//' '
74102 WRITE(CHTMP,5400) NDIM
74103 CHBLK(1)(30:33)=CHTMP(13:16)
74105 WRITE(LFN,5700) CHBLK(ILIN)
74110 C...Formats for reading and writing particle data.
74111 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
74112 5100 FORMAT(10X,2I5,F12.6,5I10)
74123 C*********************************************************************
74126 C...Provides various integer-valued event related data.
74130 C...Double precision and integer declarations.
74131 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74132 IMPLICIT INTEGER(I-N)
74133 INTEGER PYK,PYCHGE,PYCOMP
74135 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74137 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74138 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74140 C...Default value. For I=0 number of entries, number of stable entries
74141 C...or 3 times total charge.
74143 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74144 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
74146 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
74148 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
74149 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
74152 ELSEIF(I.EQ.0) THEN
74154 C...For I > 0 direct readout of K matrix or charge.
74155 ELSEIF(J.LE.5) THEN
74157 ELSEIF(J.EQ.6) THEN
74160 C...Status (existing/fragmented/decayed), parton/hadron separation.
74161 ELSEIF(J.LE.8) THEN
74162 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
74163 IF(J.EQ.8) PYK=PYK*K(I,2)
74164 ELSEIF(J.LE.12) THEN
74168 IF(KC.NE.0) KQ=KCHG(KC,2)
74169 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
74170 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
74172 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
74174 C...Heaviest flavour in hadron/diquark.
74175 ELSEIF(J.EQ.13) THEN
74177 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
74178 IF(KFA.LT.10) PYK=KFA
74179 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
74180 PYK=PYK*ISIGN(1,K(I,2))
74182 C...Particle history: generation, ancestor, rank.
74183 ELSEIF(J.LE.15) THEN
74190 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
74193 ELSEIF(J.EQ.16) THEN
74195 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
74196 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
74203 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
74204 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
74206 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
74207 IF(ILP.EQ.1) GOTO 120
74209 IF(K(I1,1).EQ.12) THEN
74211 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
74212 & .AND.K(I3,2).NE.93) PYK=PYK+1
74218 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
74222 C...Particle coming from collapsing jet system or not.
74223 ELSEIF(J.EQ.17) THEN
74230 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
74231 IF(PYK.EQ.1) PYK=-1
74235 IF(KCHG(KC,2).EQ.0) GOTO 150
74236 IF(K(I1,1).NE.12) PYK=0
74237 IF(K(I1,1).NE.12) RETURN
74240 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
74242 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
74244 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
74246 C...Number of decay products. Colour flow.
74247 ELSEIF(J.EQ.18) THEN
74248 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
74249 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
74250 ELSEIF(J.LE.22) THEN
74251 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
74252 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
74253 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
74254 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
74255 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
74262 C*********************************************************************
74265 C...Provides various real-valued event related data.
74269 C...Double precision and integer declarations.
74270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74271 IMPLICIT INTEGER(I-N)
74272 INTEGER PYK,PYCHGE,PYCOMP
74274 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74276 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74277 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74281 C...Set default value. For I = 0 sum of momenta or charges,
74282 C...or invariant mass of system.
74284 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74285 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
74287 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
74289 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
74293 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
74297 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
74298 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
74300 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
74302 ELSEIF(I.EQ.0) THEN
74304 C...Direct readout of P matrix.
74305 ELSEIF(J.LE.5) THEN
74308 C...Charge, total momentum, transverse momentum, transverse mass.
74309 ELSEIF(J.LE.12) THEN
74310 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
74311 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
74312 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
74313 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
74314 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
74316 C...Theta and phi angle in radians or degrees.
74317 ELSEIF(J.LE.16) THEN
74318 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
74319 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
74320 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
74322 C...True rapidity, rapidity with pion mass, pseudorapidity.
74323 ELSEIF(J.LE.19) THEN
74325 IF(J.EQ.17) PMR=P(I,5)
74326 IF(J.EQ.18) PMR=PYMASS(211)
74327 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
74328 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
74331 C...Energy and momentum fractions (only to be used in CM frame).
74332 ELSEIF(J.LE.25) THEN
74333 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
74334 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
74335 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
74336 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
74337 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
74338 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
74344 C*********************************************************************
74347 C...Performs sphericity tensor analysis to give sphericity,
74348 C...aplanarity and the related event axes.
74350 SUBROUTINE PYSPHE(SPH,APL)
74352 C...Double precision and integer declarations.
74353 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74354 IMPLICIT INTEGER(I-N)
74355 INTEGER PYK,PYCHGE,PYCOMP
74356 C...Parameter statement to help give large particle numbers.
74357 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74358 &KEXCIT=4000000,KDIMEN=5000000)
74360 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74361 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74362 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74363 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74365 DIMENSION SM(3,3),SV(3,3)
74367 C...Calculate matrix to be diagonalized.
74376 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74377 IF(MSTU(41).GE.2) THEN
74379 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74380 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74381 & K(I,2).EQ.KSUSY1+39) GOTO 140
74382 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74386 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74388 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
74389 & MAX(1D-10,PA)**(PARU(41)-2D0)
74392 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
74398 C...Very low multiplicities (0 or 1) not considered.
74400 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
74407 SM(J1,J2)=SM(J1,J2)/PS
74411 C...Find eigenvalues to matrix (third degree equation).
74412 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
74413 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
74414 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
74415 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
74416 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
74417 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
74418 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
74419 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
74420 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
74421 IF(P(N+2,4).LT.1D-5) THEN
74422 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
74428 C...Find first and last eigenvector by solving equation system.
74431 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
74433 SV(J1,J2)=SM(J1,J2)
74434 SV(J2,J1)=SM(J1,J2)
74440 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
74443 SMAX=ABS(SV(J1,J2))
74447 DO 220 J3=JA+1,JA+2
74449 RL=SV(J1,JB)/SV(JA,JB)
74451 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
74452 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
74454 SMAX=ABS(SV(J1,J2))
74458 JB2=JB+2-3*((JB+1)/3)
74459 P(N+I,JB1)=-SV(JC,JB2)
74460 P(N+I,JB2)=SV(JC,JB1)
74461 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
74463 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
74464 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74466 P(N+I,J)=SGN*P(N+I,J)/PA
74470 C...Middle axis orthogonal to other two. Fill other codes.
74471 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74472 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
74473 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
74474 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
74487 C...Calculate sphericity and aplanarity. Select storing option.
74488 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
74492 IF(MSTU(43).LE.1) MSTU(3)=3
74493 IF(MSTU(43).GE.2) N=N+3
74498 C*********************************************************************
74501 C...Performs thrust analysis to give thrust, oblateness
74502 C...and the related event axes.
74504 SUBROUTINE PYTHRU(THR,OBL)
74506 C...Double precision and integer declarations.
74507 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74508 IMPLICIT INTEGER(I-N)
74509 INTEGER PYK,PYCHGE,PYCOMP
74510 C...Parameter statement to help give large particle numbers.
74511 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74512 &KEXCIT=4000000,KDIMEN=5000000)
74514 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74515 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74516 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74517 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74519 DIMENSION TDI(3),TPR(3)
74521 C...Take copy of particles that are to be considered in thrust analysis.
74525 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
74526 IF(MSTU(41).GE.2) THEN
74528 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74529 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74530 & K(I,2).EQ.KSUSY1+39) GOTO 100
74531 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74534 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
74535 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
74545 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74547 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
74548 & P(N+NP,4)**(PARU(42)-1D0)
74549 PS=PS+P(N+NP,4)*P(N+NP,5)
74552 C...Very low multiplicities (0 or 1) not considered.
74554 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
74560 C...Loop over thrust and major. T axis along z direction in latter case.
74564 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
74566 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
74567 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
74568 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
74571 C...Find and order particles with highest p (pT for major).
74572 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
74576 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
74577 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
74578 IF(P(I,4).LE.P(ILF,4)) GOTO 140
74580 P(ILF+1,J)=P(ILF,J)
74589 C...Find and order initial axes with highest thrust (major).
74590 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
74593 NC=2**(MIN(MSTU(44),NP)-1)
74598 DO 200 ILF=1,MIN(MSTU(44),NP)
74599 SGN=P(N+NP+ILF+3,5)
74600 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
74602 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
74605 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
74606 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
74607 IF(TDS.LE.P(ILG,4)) GOTO 230
74609 P(ILG+1,J)=P(ILG,J)
74612 ILG=N+NP+MSTU(44)+4
74619 C...Iterate direction of axis until stable maximum.
74626 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
74627 IF(THP.GT.1D-10) TDI(J)=TPR(J)
74631 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
74633 TPR(J)=TPR(J)+SGN*P(I,J)
74636 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
74637 IF(THP.GE.THPS+PARU(48)) GOTO 270
74639 C...Save good axis. Try new initial axis until a number of tries agree.
74640 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
74641 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
74643 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74645 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
74651 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
74654 C...Find minor axis and value by orthogonality.
74655 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74656 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
74657 P(N+NP+3,2)=SGN*P(N+NP+2,1)
74661 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
74666 C...Fill axis information. Rotate back to original coordinate system.
74674 P(N+ILD,J)=P(N+NP+ILD,J)
74678 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
74680 C...Calculate thrust and oblateness. Select storing option.
74682 OBL=P(N+2,4)-P(N+3,4)
74685 IF(MSTU(43).LE.1) MSTU(3)=3
74686 IF(MSTU(43).GE.2) N=N+3
74691 C*********************************************************************
74694 C...Subdivides the particle content of an event into jets/clusters.
74696 SUBROUTINE PYCLUS(NJET)
74698 C...Double precision and integer declarations.
74699 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74700 IMPLICIT INTEGER(I-N)
74701 INTEGER PYK,PYCHGE,PYCOMP
74702 C...Parameter statement to help give large particle numbers.
74703 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74704 &KEXCIT=4000000,KDIMEN=5000000)
74706 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74707 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74708 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74709 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74710 C...Local arrays and saved variables.
74712 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
74714 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74715 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
74716 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
74717 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
74718 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74719 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
74720 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74722 C...If first time, reset. If reentering, skip preliminaries.
74723 IF(MSTU(48).LE.0) THEN
74729 PIMASS=PMAS(PYCOMP(211),1)
74732 IF(MSTU(43).GE.2) N=N-NJET
74733 DO 110 I=N+1,N+NJET
74734 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74736 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74739 R2ACC=PARU(45)*PS(5)**2
74745 C...Find which particles are to be considered in cluster search.
74747 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74748 IF(MSTU(41).GE.2) THEN
74750 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74751 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74752 & K(I,2).EQ.KSUSY1+39) GOTO 140
74753 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74756 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
74757 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
74762 C...Take copy of these particles, with space left for jets later on.
74768 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
74769 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
74770 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74771 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74773 PS(J)=PS(J)+P(N+NP,J)
74783 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
74785 C...Very low multiplicities not considered.
74786 IF(NP.LT.MSTU(47)) THEN
74787 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
74792 C...Find precluster configuration. If too few jets, make harder cuts.
74794 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74797 R2ACC=PARU(45)*PS(5)**2
74799 RINIT=1.25D0*PARU(43)
74800 IF(NP.LE.MSTU(47)+2) RINIT=0D0
74801 170 RINIT=0.8D0*RINIT
74804 DO 180 I=N+NP+1,N+2*NP
74808 C...Sum up small momentum region. Jet if enough absolute momentum.
74809 IF(MSTU(46).LE.2) THEN
74813 DO 210 I=N+NP+1,N+2*NP
74814 IF(P(I,5).GT.2D0*RINIT) GOTO 210
74818 P(N+1,J)=P(N+1,J)+P(I,J)
74821 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
74822 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
74823 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74824 IF(NREM.EQ.0) GOTO 170
74827 C...Find fastest remaining particle.
74830 DO 230 I=N+NP+1,N+2*NP
74831 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
74836 P(N+NPRE,J)=P(IMAX,J)
74841 C...Sum up precluster around it according to pT separation.
74842 IF(MSTU(46).LE.2) THEN
74843 DO 260 I=N+NP+1,N+2*NP
74844 IF(K(I,4).NE.0) GOTO 260
74846 IF(R2.GT.RINIT**2) GOTO 260
74850 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
74853 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74855 C...Sum up precluster around it according to mass or
74856 C...Durham pT separation.
74860 DO 280 I=N+NP+1,N+2*NP
74861 IF(K(I,4).NE.0) GOTO 280
74862 IF(MSTU(46).LE.4) THEN
74867 IF(R2.GE.R2MIN) GOTO 280
74873 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
74875 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74882 C...Check if more preclusters to be found. Start over if too few.
74883 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74884 IF(NREM.GT.0) GOTO 220
74887 C...Reassign all particles to nearest jet. Sum up new jet momenta.
74890 310 IF(MSTU(46).LE.1) THEN
74891 DO 330 I=N+1,N+NJET
74896 DO 360 I=N+NP+1,N+2*NP
74898 DO 340 IJET=N+1,N+NJET
74899 IF(P(IJET,5).LT.RINIT) GOTO 340
74901 IF(R2.GE.R2MIN) GOTO 340
74907 V(IMIN,J)=V(IMIN,J)+P(I,J)
74911 DO 380 I=N+1,N+NJET
74915 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74920 C...Find two closest jets.
74921 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
74922 DO 400 ITRY1=N+1,N+NJET-1
74923 DO 390 ITRY2=ITRY1+1,N+NJET
74924 IF(MSTU(46).LE.2) THEN
74925 R2=R2T(ITRY1,ITRY2)
74926 ELSEIF(MSTU(46).LE.4) THEN
74927 R2=R2M(ITRY1,ITRY2)
74929 R2=R2D(ITRY1,ITRY2)
74931 IF(R2.GE.R2MIN) GOTO 390
74938 C...If allowed, join two closest jets and start over.
74939 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
74940 IREC=MIN(IMIN1,IMIN2)
74941 IDEL=MAX(IMIN1,IMIN2)
74943 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
74945 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
74946 DO 430 I=IDEL+1,N+NJET
74951 IF(MSTU(46).GE.2) THEN
74952 DO 440 I=N+NP+1,N+2*NP
74954 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
74955 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
74961 C...Divide up broad jet if empty cluster in list of final ones.
74962 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
74963 DO 450 I=N+1,N+NJET
74966 DO 460 I=N+NP+1,N+2*NP
74967 K(N+K(I,4),5)=K(N+K(I,4),5)+1
74970 DO 470 I=N+1,N+NJET
74971 IF(K(I,5).EQ.0) IEMP=I
74977 DO 480 I=N+NP+1,N+2*NP
74978 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
74981 IF(R2.LE.R2MAX) GOTO 480
74988 P(IEMP,J)=P(ISPL,J)
74989 P(IJET,J)=P(IJET,J)-P(ISPL,J)
74991 P(IEMP,5)=P(ISPL,5)
74992 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
74993 IF(NLOOP.LE.2) GOTO 300
74998 C...If generalized thrust has not yet converged, continue iteration.
74999 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
75005 C...Reorder jets according to energy.
75006 DO 510 I=N+1,N+NJET
75011 DO 540 INEW=N+1,N+NJET
75013 DO 520 ITRY=N+1,N+NJET
75014 IF(V(ITRY,4).LE.PEMAX) GOTO 520
75023 P(INEW,J)=V(IMAX,J)
75029 C...Clean up particle-jet assignments and jet information.
75030 DO 550 I=N+NP+1,N+2*NP
75033 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
75034 K(IORI,4)=K(IORI,4)+1
75038 DO 570 I=N+1,N+NJET
75041 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
75045 IF(K(I,4).EQ.0) IEMP=I
75048 C...Select storing option. Output variables. Check for failure.
75054 PARU(63)=SQRT(R2MIN)
75055 IF(NJET.LE.1) PARU(63)=0D0
75057 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
75061 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75062 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75068 C*********************************************************************
75071 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75072 C...as used for calorimeters at hadron colliders.
75074 SUBROUTINE PYCELL(NJET)
75076 C...Double precision and integer declarations.
75077 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75078 IMPLICIT INTEGER(I-N)
75079 INTEGER PYK,PYCHGE,PYCOMP
75080 C...Parameter statement to help give large particle numbers.
75081 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75082 &KEXCIT=4000000,KDIMEN=5000000)
75084 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75085 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75086 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75087 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75089 C...Loop over all particles. Find cell that was hit by given particle.
75090 PTLRAT=1D0/SINH(PARU(51))**2
75094 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75095 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
75096 IF(MSTU(41).GE.2) THEN
75098 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75099 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75100 & K(I,2).EQ.KSUSY1+39) GOTO 110
75101 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75105 PT=SQRT(P(I,1)**2+P(I,2)**2)
75106 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
75107 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
75108 & (ETA/PARU(51)+1D0))))
75109 PHI=PYANGL(P(I,1),P(I,2))
75110 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
75111 & (PHI/PARU(1)+1D0))))
75112 IETPH=MSTU(52)*IETA+IPHI
75114 C...Add to cell already hit, or book new cell.
75116 IF(IETPH.EQ.K(IC,3)) THEN
75122 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
75123 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75131 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
75132 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
75136 C...Smear true bin content by calorimeter resolution.
75137 IF(MSTU(53).GE.1) THEN
75140 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
75141 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
75142 & COS(PARU(2)*PYR(0))
75143 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
75145 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
75149 C...Remove cells below threshold.
75150 IF(PARU(58).GT.0D0) THEN
75154 IF(P(IC,5).GT.PARU(58)) THEN
75166 C...Find initiator cell: the one with highest pT of not yet used ones.
75170 IF(K(IC,5).NE.2) GOTO 160
75171 IF(P(IC,5).LE.ETMAX) GOTO 160
75177 IF(ETMAX.LT.PARU(52)) GOTO 220
75178 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
75179 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75193 C...Sum up unused cells within required distance of initiator.
75195 IF(K(IC,5).EQ.0) GOTO 170
75196 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
75197 DPHIA=ABS(P(IC,2)-PHI)
75198 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
75200 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
75201 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
75203 K(NJ,4)=K(NJ,4)+K(IC,4)
75204 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
75205 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
75206 P(NJ,5)=P(NJ,5)+P(IC,5)
75209 C...Reject cluster below minimum ET, else accept.
75210 IF(P(NJ,5).LT.PARU(53)) THEN
75213 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
75215 ELSEIF(MSTU(54).LE.2) THEN
75216 P(NJ,3)=P(NJ,3)/P(NJ,5)
75217 P(NJ,4)=P(NJ,4)/P(NJ,5)
75218 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
75221 IF(K(IC,5).LT.0) K(IC,5)=0
75228 IF(K(IC,5).GE.0) GOTO 210
75229 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
75230 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
75231 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
75232 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
75238 C...Arrange clusters in falling ET sequence.
75239 220 DO 250 I=1,NJ-NC
75242 IF(K(IJ,5).EQ.0) GOTO 230
75243 IF(P(IJ,5).LT.ETMAX) GOTO 230
75251 K(N+I,4)=K(IJMAX,4)
75254 P(N+I,J)=P(IJMAX,J)
75260 C...Convert to massless or massive four-vectors.
75261 IF(MSTU(54).EQ.2) THEN
75262 DO 260 I=N+1,N+NJET
75264 P(I,1)=P(I,5)*COS(P(I,4))
75265 P(I,2)=P(I,5)*SIN(P(I,4))
75266 P(I,3)=P(I,5)*SINH(ETA)
75267 P(I,4)=P(I,5)*COSH(ETA)
75270 ELSEIF(MSTU(54).GE.3) THEN
75271 DO 270 I=N+1,N+NJET
75272 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
75276 C...Information about storage.
75280 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75281 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75286 C*********************************************************************
75289 C...Determines, approximately, the two jet masses that minimize
75290 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75292 SUBROUTINE PYJMAS(PMH,PML)
75294 C...Double precision and integer declarations.
75295 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75296 IMPLICIT INTEGER(I-N)
75297 INTEGER PYK,PYCHGE,PYCOMP
75298 C...Parameter statement to help give large particle numbers.
75299 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75300 &KEXCIT=4000000,KDIMEN=5000000)
75302 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75303 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75304 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75305 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75307 DIMENSION SM(3,3),SAX(3),PS(3,5)
75320 PIMASS=PMAS(PYCOMP(211),1)
75322 C...Take copy of particles that are to be considered in mass analysis.
75324 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
75325 IF(MSTU(41).GE.2) THEN
75327 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75328 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75329 & K(I,2).EQ.KSUSY1+39) GOTO 170
75330 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75333 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
75334 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
75343 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
75344 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
75345 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
75347 C...Fill information in sphericity tensor and total momentum vector.
75350 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
75353 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75355 PS(3,J)=PS(3,J)+P(N+NP,J)
75359 C...Very low multiplicities (0 or 1) not considered.
75361 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
75366 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
75369 C...Find largest eigenvalue to matrix (third degree equation).
75372 SM(J1,J2)=SM(J1,J2)/PSS
75375 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
75376 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
75377 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
75378 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
75379 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
75380 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
75381 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
75383 C...Find largest eigenvector by solving equation system.
75385 SM(J1,J1)=SM(J1,J1)-SMA
75387 SM(J2,J1)=SM(J1,J2)
75393 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
75396 SMAX=ABS(SM(J1,J2))
75400 DO 250 J3=JA+1,JA+2
75402 RL=SM(J1,JB)/SM(JA,JB)
75404 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
75405 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
75407 SMAX=ABS(SM(J1,J2))
75411 JB2=JB+2-3*((JB+1)/3)
75412 SAX(JB1)=-SM(JC,JB2)
75413 SAX(JB2)=SM(JC,JB1)
75414 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
75416 C...Divide particles into two initial clusters by hemisphere.
75418 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
75420 IF(PSAX.LT.0D0) IS=2
75423 PS(IS,J)=PS(IS,J)+P(I,J)
75426 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
75427 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
75429 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75433 PS(3,J)=PS(1,J)-PS(2,J)
75436 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)
75437 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
75438 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
75439 IF(PMDI.LT.PMD) THEN
75445 C...Loop back if significant reduction in sum of m^2.
75446 IF(PMD.LT.-PARU(48)*PMS) THEN
75450 PS(IS,J)=PS(IS,J)-P(IM,J)
75451 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
75457 C...Final masses and output.
75460 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
75461 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
75462 PMH=MAX(PS(1,5),PS(2,5))
75463 PML=MIN(PS(1,5),PS(2,5))
75468 C*********************************************************************
75471 C...Calculates the first few Fox-Wolfram moments.
75473 SUBROUTINE PYFOWO(H10,H20,H30,H40)
75475 C...Double precision and integer declarations.
75476 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75477 IMPLICIT INTEGER(I-N)
75478 INTEGER PYK,PYCHGE,PYCOMP
75479 C...Parameter statement to help give large particle numbers.
75480 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75481 &KEXCIT=4000000,KDIMEN=5000000)
75483 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75486 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75488 C...Copy momenta for particles and calculate H0.
75493 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75494 IF(MSTU(41).GE.2) THEN
75496 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75497 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75498 & K(I,2).EQ.KSUSY1+39) GOTO 110
75499 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75502 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
75503 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
75514 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75520 C...Very low multiplicities (0 or 1) not considered.
75522 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
75530 C...Calculate H1 - H4.
75536 DO 120 I2=I1+1,N+NP
75537 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
75538 & (P(I1,4)*P(I2,4))
75539 H10=H10+P(I1,4)*P(I2,4)*CTHE
75540 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
75541 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
75542 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
75547 C...Calculate H1/H0 - H4/H0. Output.
75550 H10=(HD+2D0*H10)/H0
75551 H20=(HD+2D0*H20)/H0
75552 H30=(HD+2D0*H30)/H0
75553 H40=(HD+2D0*H40)/H0
75558 C*********************************************************************
75561 C...Evaluates various properties of an event, with statistics
75562 C...accumulated during the course of the run and
75563 C...printed at the end.
75565 SUBROUTINE PYTABU(MTABU)
75567 C...Double precision and integer declarations.
75568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75569 IMPLICIT INTEGER(I-N)
75570 INTEGER PYK,PYCHGE,PYCOMP
75571 C...Parameter statement to help give large particle numbers.
75572 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75573 &KEXCIT=4000000,KDIMEN=5000000)
75575 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75577 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75578 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75579 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
75580 C...Local arrays, character variables, saved variables and data.
75581 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
75582 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
75583 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
75584 &KFDM(8),KFDC(200,0:8),NPDC(200)
75585 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
75586 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
75587 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
75588 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75589 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
75590 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
75591 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
75592 &NEVDC/0/,NKFDC/0/,NREDC/0/
75594 C...Reset statistics on initial parton state.
75595 IF(MTABU.EQ.10) THEN
75599 C...Identify and order flavour content of initial state.
75600 ELSEIF(MTABU.EQ.11) THEN
75602 KFM1=2*IABS(MSTU(161))
75603 IF(MSTU(161).GT.0) KFM1=KFM1-1
75604 KFM2=2*IABS(MSTU(162))
75605 IF(MSTU(162).GT.0) KFM2=KFM2-1
75606 KFMN=MIN(KFM1,KFM2)
75607 KFMX=MAX(KFM1,KFM2)
75609 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
75612 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
75613 & KFMX.LT.KFIS(I,2))) THEN
75619 110 IF(IKFIS.LT.0) THEN
75622 IF(NKFIS.GE.100) RETURN
75623 DO 130 I=NKFIS,IKFIS,-1
75624 KFIS(I+1,1)=KFIS(I,1)
75625 KFIS(I+1,2)=KFIS(I,2)
75627 NPIS(I+1,J)=NPIS(I,J)
75637 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
75639 C...Count number of partons in initial state.
75642 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
75643 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
75644 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
75649 IF(IM.LE.0.OR.IM.GT.N) THEN
75651 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75653 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
75654 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
75664 IF(NP.GE.11) NPCO=8
75665 IF(NP.GE.16) NPCO=9
75666 IF(NP.GE.26) NPCO=10
75667 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
75670 C...Write statistics on initial parton state.
75671 ELSEIF(MTABU.EQ.12) THEN
75672 FAC=1D0/MAX(1,NEVIS)
75673 WRITE(MSTU(11),5000) NEVIS
75676 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75678 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75679 CALL PYNAME(KFM1,CHAU)
75681 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
75683 IF(KFIS(I,1).EQ.0) KFMX=0
75685 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75686 CALL PYNAME(KFM2,CHAU)
75688 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
75689 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
75690 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
75693 C...Copy statistics on initial parton state into /PYJETS/.
75694 ELSEIF(MTABU.EQ.13) THEN
75695 FAC=1D0/MAX(1,NEVIS)
75698 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75700 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75702 IF(KFIS(I,1).EQ.0) KFMX=0
75704 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75711 P(I,J)=FAC*NPIS(I,J)
75712 V(I,J)=FAC*NPIS(I,J+5)
75726 C...Reset statistics on number of particles/partons.
75727 ELSEIF(MTABU.EQ.20) THEN
75734 C...Identify whether particle/parton is primary or not.
75735 ELSEIF(MTABU.EQ.21) THEN
75739 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
75740 MSTU(62)=MSTU(62)+1
75743 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
75745 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
75747 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
75749 ELSEIF(KC.EQ.0) THEN
75750 ELSEIF(K(K(I,3),1).EQ.13) THEN
75752 IF(IM.LE.0.OR.IM.GT.N) THEN
75754 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75757 ELSEIF(KCHG(KC,2).EQ.0) THEN
75758 KCM=PYCOMP(K(K(I,3),2))
75760 IF(KCHG(KCM,2).NE.0) MPRI=1
75763 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
75764 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
75766 IF(K(I,1).LE.10) THEN
75768 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
75771 C...Fill statistics on number of particles/partons in event.
75773 KFS=3-ISIGN(1,K(I,2))-MPRI
75775 IF(KFA.EQ.KFFS(IP)) THEN
75778 ELSEIF(KFA.LT.KFFS(IP)) THEN
75784 220 IF(IKFFS.LT.0) THEN
75787 IF(NKFFS.GE.400) RETURN
75788 DO 240 IP=NKFFS,IKFFS,-1
75789 KFFS(IP+1)=KFFS(IP)
75791 NPFS(IP+1,J)=NPFS(IP,J)
75800 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
75803 C...Write statistics on particle/parton composition of events.
75804 ELSEIF(MTABU.EQ.22) THEN
75805 FAC=1D0/MAX(1,NEVFS)
75806 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
75808 CALL PYNAME(KFFS(I),CHAU)
75811 IF(KC.NE.0) MDCYF=MDCY(KC,1)
75812 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
75813 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
75816 C...Copy particle/parton composition information into /PYJETS/.
75817 ELSEIF(MTABU.EQ.23) THEN
75818 FAC=1D0/MAX(1,NEVFS)
75824 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
75826 P(I,J)=FAC*NPFS(I,J)
75846 C...Reset factorial moments statistics.
75847 ELSEIF(MTABU.EQ.30) THEN
75853 FM1FM(IM,IB,IP)=0D0
75854 FM2FM(IM,IB,IP)=0D0
75859 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75860 ELSEIF(MTABU.EQ.31) THEN
75865 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
75866 IF(MSTU(41).GE.2) THEN
75868 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75869 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75870 & K(I,2).EQ.KSUSY1+39) GOTO 410
75871 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
75872 & PYCHGE(K(I,2)).EQ.0) GOTO 410
75875 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
75876 IF(MSTU(42).GE.2) PMR=P(I,5)
75877 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
75878 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
75880 IF(ABS(YETA).GT.PARU(57)) GOTO 410
75881 PHI=PYANGL(P(I,1),P(I,2))
75882 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
75883 IYETA=MAX(0,MIN(511,IYETA))
75884 IPHI=512D0*(PHI+PARU(1))/PARU(2)
75885 IPHI=MAX(0,MIN(511,IPHI))
75888 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
75891 C...Order particles in (pseudo)rapidity and/or azimuth.
75892 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
75893 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
75897 IF(NUPP.EQ.NLOW+1) THEN
75902 DO 350 I1=NUPP-1,NLOW+1,-1
75903 IF(IYETA.GE.K(I1,1)) GOTO 360
75906 360 K(I1+1,1)=IYETA
75907 DO 370 I1=NUPP-1,NLOW+1,-1
75908 IF(IPHI.GE.K(I1,2)) GOTO 380
75912 DO 390 I1=NUPP-1,NLOW+1,-1
75913 IF(IYEP.GE.K(I1,3)) GOTO 400
75923 C...Calculate sum of factorial moments in event.
75931 IF(IM.LE.2) IBIN=2**(10-IB)
75932 IF(IM.EQ.3) IBIN=4**(10-IB)
75933 IAGR=K(NLOW+1,IM)/IBIN
75935 DO 440 I=NLOW+2,NUPP+1
75937 IF(ICUT.EQ.IAGR) THEN
75941 ELSEIF(NAGR.EQ.2) THEN
75942 FEVFM(IB,1)=FEVFM(IB,1)+2D0
75943 ELSEIF(NAGR.EQ.3) THEN
75944 FEVFM(IB,1)=FEVFM(IB,1)+6D0
75945 FEVFM(IB,2)=FEVFM(IB,2)+6D0
75946 ELSEIF(NAGR.EQ.4) THEN
75947 FEVFM(IB,1)=FEVFM(IB,1)+12D0
75948 FEVFM(IB,2)=FEVFM(IB,2)+24D0
75949 FEVFM(IB,3)=FEVFM(IB,3)+24D0
75951 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
75952 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
75953 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75955 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75956 & (NAGR-3D0)*(NAGR-4D0)
75964 C...Add results to total statistics.
75967 IF(FEVFM(1,IP).LT.0.5D0) THEN
75969 ELSEIF(IM.LE.2) THEN
75970 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75972 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75974 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
75975 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
75979 NMUFM=NMUFM+(NUPP-NLOW)
75982 C...Write accumulated statistics on factorial moments.
75983 ELSEIF(MTABU.EQ.32) THEN
75984 FAC=1D0/MAX(1,NEVFM)
75985 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
75986 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
75987 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
75989 WRITE(MSTU(11),5500)
75992 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
75994 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
75995 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
75996 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
75998 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
75999 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
76002 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
76007 C...Copy statistics on factorial moments into /PYJETS/.
76008 ELSEIF(MTABU.EQ.33) THEN
76009 FAC=1D0/MAX(1,NEVFM)
76016 IF(IM.NE.2) K(I,3)=2**(IB-1)
76018 IF(IM.NE.1) K(I,4)=2**(IB-1)
76020 P(I,1)=2D0*PARU(57)/K(I,3)
76021 V(I,1)=PARU(2)/K(I,4)
76023 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
76024 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
76040 C...Reset statistics on Energy-Energy Correlation.
76041 ELSEIF(MTABU.EQ.40) THEN
76052 C...Find particles to include, with proper assumed mass.
76053 ELSEIF(MTABU.EQ.41) THEN
76059 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
76060 IF(MSTU(41).GE.2) THEN
76062 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76063 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76064 & K(I,2).EQ.KSUSY1+39) GOTO 570
76065 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
76066 & PYCHGE(K(I,2)).EQ.0) GOTO 570
76069 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
76070 IF(MSTU(42).GE.2) PMR=P(I,5)
76071 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
76072 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
76079 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76080 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
76083 IF(NUPP.EQ.NLOW) RETURN
76085 C...Analyze Energy-Energy Correlation in event.
76086 FAC=(2D0/ECM**2)*50D0/PARU(1)
76090 DO 600 I1=NLOW+2,NUPP
76091 DO 590 I2=NLOW+1,I1-1
76092 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
76093 & (P(I1,5)*P(I2,5))
76094 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
76095 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
76096 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
76100 FE1EC(J)=FE1EC(J)+FEVEE(J)
76101 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
76102 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
76103 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
76104 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
76105 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
76109 C...Write statistics on Energy-Energy Correlation.
76110 ELSEIF(MTABU.EQ.42) THEN
76111 FAC=1D0/MAX(1,NEVEE)
76112 WRITE(MSTU(11),5700) NEVEE
76115 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
76116 FEEC2=FAC*FE1EC(51-J)
76117 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
76119 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
76120 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
76121 & FEEC2,FEES2,FEECA,FEESA
76124 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76125 ELSEIF(MTABU.EQ.43) THEN
76126 FAC=1D0/MAX(1,NEVEE)
76133 P(I,1)=FAC*FE1EC(I)
76134 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
76135 P(I,2)=FAC*FE1EC(51-I)
76136 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
76137 P(I,3)=FAC*FE1EA(I)
76138 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
76139 P(I,4)=PARU(1)*(I-1)/50D0
76140 P(I,5)=PARU(1)*I/50D0
76155 C...Reset statistics on decay channels.
76156 ELSEIF(MTABU.EQ.50) THEN
76161 C...Identify and order flavour content of final state.
76162 ELSEIF(MTABU.EQ.51) THEN
76166 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
76173 IF(K(I,2).LT.0) KFM=KFM-1
76174 DO 650 IDS=NDS-1,1,-1
76176 IF(KFM.LT.KFDM(IDS)) GOTO 660
76177 KFDM(IDS+1)=KFDM(IDS)
76183 C...Find whether old or new final state.
76185 IF(NDS.LT.KFDC(IDC,0)) THEN
76188 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
76190 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
76193 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
76202 700 IF(IKFDC.LT.0) THEN
76204 ELSEIF(NKFDC.GE.200) THEN
76208 DO 720 IDC=NKFDC,IKFDC,-1
76209 NPDC(IDC+1)=NPDC(IDC)
76211 KFDC(IDC+1,I)=KFDC(IDC,I)
76217 KFDC(IKFDC,I)=KFDM(I)
76221 NPDC(IKFDC)=NPDC(IKFDC)+1
76223 C...Write statistics on decay channels.
76224 ELSEIF(MTABU.EQ.52) THEN
76225 FAC=1D0/MAX(1,NEVDC)
76226 WRITE(MSTU(11),5900) NEVDC
76228 DO 740 I=1,KFDC(IDC,0)
76231 IF(2*KF.NE.KFM) KF=-KF
76232 CALL PYNAME(KF,CHAU)
76234 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
76236 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
76238 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
76240 C...Copy statistics on decay channels into /PYJETS/.
76241 ELSEIF(MTABU.EQ.53) THEN
76242 FAC=1D0/MAX(1,NEVDC)
76248 K(IDC,5)=KFDC(IDC,0)
76253 DO 770 I=1,KFDC(IDC,0)
76256 IF(2*KF.NE.KFM) KF=-KF
76257 IF(I.LE.5) P(IDC,I)=KF
76258 IF(I.GE.6) V(IDC,I-5)=KF
76260 V(IDC,5)=FAC*NPDC(IDC)
76275 C...Format statements for output on unit MSTU(11) (default 6).
76276 5000 FORMAT(///20X,'Event statistics - initial state'/
76277 &20X,'based on an analysis of ',I6,' events'//
76278 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
76279 &'according to fragmenting system multiplicity'/
76280 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
76281 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
76282 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
76283 5200 FORMAT(///20X,'Event statistics - final state'/
76284 &20X,'based on an analysis of ',I7,' events'//
76285 &5X,'Mean primary multiplicity =',F10.4/
76286 &5X,'Mean final multiplicity =',F10.4/
76287 &5X,'Mean charged multiplicity =',F10.4//
76288 &5X,'Number of particles produced per event (directly and via ',
76289 &'decays/branchings)'/
76290 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
76291 &8X,'Total'/35X,'prim seco prim seco'/)
76292 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
76293 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
76294 &20X,'based on an analysis of ',I6,' events'//
76295 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
76296 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
76298 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
76299 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
76300 &20X,'based on an analysis of ',I6,' events'//
76301 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
76302 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
76303 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
76304 5900 FORMAT(///20X,'Decay channel analysis - final state'/
76305 &20X,'based on an analysis of ',I6,' events'//
76306 &2X,'Probability',10X,'Complete final state'/)
76307 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
76308 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
76309 &'or table overflow)')
76314 C*********************************************************************
76317 C...Handles the generation of an e+e- annihilation jet event.
76319 SUBROUTINE PYEEVT(KFL,ECM)
76321 C...Double precision and integer declarations.
76322 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76323 IMPLICIT INTEGER(I-N)
76324 INTEGER PYK,PYCHGE,PYCOMP
76326 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76327 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76328 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76329 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76331 C...Check input parameters.
76332 IF(MSTU(12).NE.12345) CALL PYLIST(0)
76333 IF(KFL.LT.0.OR.KFL.GT.8) THEN
76334 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
76335 IF(MSTU(21).GE.1) RETURN
76337 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
76338 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
76339 IF(ECM.LT.ECMMIN) THEN
76340 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
76341 IF(MSTU(21).GE.1) RETURN
76344 C...Check consistency of MSTJ options set.
76345 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
76347 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76350 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
76352 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76356 C...Initialize alpha_strong and total cross-section.
76357 MSTU(111)=MSTJ(108)
76358 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
76360 PARU(112)=PARJ(121)
76361 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
76362 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
76363 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
76365 IF(MSTJ(116).GE.3) MSTJ(116)=1
76368 C...Add initial e+e- to event record (documentation only).
76371 IF(NTRY.GT.100) THEN
76372 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
76377 IF(MSTJ(115).GE.2) THEN
76379 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
76381 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
76385 C...Radiative photon (in initial state).
76388 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
76390 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
76391 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
76393 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
76394 K(NC,3)=MIN(MSTJ(115)/2,1)
76397 C...Virtual exchange boson (gamma or Z0).
76398 IF(MSTJ(115).GE.3) THEN
76401 IF(MSTJ(102).EQ.2) KF=23
76405 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
76411 C...Choice of flavour and jet configuration.
76412 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
76413 IF(KFLC.EQ.0) GOTO 100
76414 CALL PYXJET(ECMC,NJET,CUT)
76416 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
76418 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
76419 IF(NJET.EQ.2) MSTJ(120)=1
76421 C...Fill jet configuration and origin.
76422 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
76423 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
76425 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
76426 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
76427 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76428 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
76429 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76430 IF(MSTU(24).NE.0) GOTO 100
76432 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
76435 C...Angular orientation according to matrix element.
76436 IF(MSTJ(106).EQ.1) THEN
76437 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
76438 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
76439 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
76442 C...Rotation and boost from radiative photon.
76444 DBEK=-PAK/(ECM-PAK)
76445 NMIN=NC+1-MSTJ(115)/3
76446 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
76447 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
76448 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
76451 C...Generate parton shower. Rearrange along strings and check.
76452 IF(MSTJ(101).EQ.5) THEN
76453 CALL PYSHOW(N-1,N,ECMC)
76455 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
76456 IF(MSTJ(105).GE.0) MSTU(28)=0
76459 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
76462 C...Fragmentation/decay generation. Information for PYTABU.
76463 IF(MSTJ(105).EQ.1) CALL PYEXEC
76470 C*********************************************************************
76473 C...Calculates total cross-section, including initial state
76474 C...radiation effects.
76476 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
76478 C...Double precision and integer declarations.
76479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76480 IMPLICIT INTEGER(I-N)
76481 INTEGER PYK,PYCHGE,PYCOMP
76483 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76484 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76485 SAVE /PYDAT1/,/PYDAT2/
76487 C...Status, (optimized) Q^2 scale, alpha_strong.
76489 MSTJ(119)=10*MSTJ(102)+KFL
76490 IF(MSTJ(111).EQ.0) THEN
76492 ELSEIF(MSTU(111).EQ.0) THEN
76493 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76494 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76495 Q2R=PARJ(168)*ECM**2
76497 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76498 & (2D0*PARU(112)/ECM)**2))
76499 Q2R=PARJ(168)*ECM**2
76501 ALSPI=PYALPS(Q2R)/PARU(1)
76503 C...QCD corrections factor in R.
76504 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
76506 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
76508 ELSEIF(MSTJ(109).EQ.0) THEN
76509 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76510 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
76511 & LOG(PARJ(168))*ALSPI**2)
76512 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
76513 RQCD=1D0+(3D0/4D0)*ALSPI
76515 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
76518 C...Calculate Z0 width if default value not acceptable.
76519 IF(MSTJ(102).GE.3) THEN
76520 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
76521 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
76524 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
76525 & (2D0*PYMASS(KFLC)/ ECM)**2))
76526 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
76527 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
76528 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
76530 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
76534 C...Calculate propagator and related constants for QFD case.
76535 POLL=1D0-PARJ(131)*PARJ(132)
76536 IF(MSTJ(102).GE.2) THEN
76537 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76538 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76539 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
76540 VE=4D0*PARU(102)-1D0
76541 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
76542 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76547 C...Loop over different flavours: charge, velocity.
76552 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
76553 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
76556 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
76557 QF=KCHG(KFLC,1)/3D0
76559 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
76561 C...Calculate R and sum of charges for QED or QFD case.
76562 RQQ=RQQ+3D0*QF**2*POLL
76563 IF(MSTJ(102).LE.1) THEN
76564 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
76566 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76567 RQV=RQV-6D0*QF*VF*SF1I
76568 RVA=RVA+3D0*(VF**2+1D0)*SF1W
76569 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
76570 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
76574 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
76576 C...Calculate cross-section, including QCD corrections.
76579 PARJ(143)=RTOT*RQCD
76580 PARJ(144)=PARJ(143)
76581 PARJ(145)=PARJ(141)*86.8D0/ECM**2
76582 PARJ(146)=PARJ(142)*86.8D0/ECM**2
76583 PARJ(147)=PARJ(143)*86.8D0/ECM**2
76584 PARJ(148)=PARJ(147)
76585 PARJ(157)=RSUM*RQCD
76589 IF(MSTJ(107).LE.0) RETURN
76591 C...Virtual cross-section.
76593 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76594 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
76595 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
76596 &1.526D0*LOG(ECM**2/0.932D0)
76598 C...Soft and hard radiative cross-section in QED case.
76599 IF(MSTJ(102).LE.1) THEN
76600 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
76601 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
76602 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
76604 C...Soft and hard radiative cross-section in QFD case.
76606 SZM=1D0-(PARJ(123)/ECM)**2
76607 SZW=PARJ(123)*PARJ(124)/ECM**2
76608 PARJ(161)=-RQQ/RSUM
76609 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
76610 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
76611 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
76612 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
76613 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
76614 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
76615 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
76616 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
76617 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
76618 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
76619 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
76620 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
76621 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
76624 C...Total cross-section and fraction of hard photon events.
76625 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
76626 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
76627 PARJ(144)=PARJ(157)
76628 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76634 C*********************************************************************
76637 C...Generates initial state photon radiation.
76639 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
76641 C...Double precision and integer declarations.
76642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76643 IMPLICIT INTEGER(I-N)
76644 INTEGER PYK,PYCHGE,PYCOMP
76646 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76649 C...Function: cumulative hard photon spectrum in QFD case.
76650 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
76651 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
76653 C...Determine whether radiative photon or not.
76656 IF(PARJ(160).LT.PYR(0)) RETURN
76659 C...Photon energy range. Find photon momentum in QED case.
76661 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76662 IF(MSTJ(102).LE.1) THEN
76663 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
76664 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
76666 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76668 SZM=1D0-(PARJ(123)/ECM)**2
76669 SZW=PARJ(123)*PARJ(124)/ECM**2
76672 FXKD=1D-4*(FXKU-FXKL)
76673 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
76678 IF(FXKV.GT.FXKR) THEN
76685 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
76686 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
76690 C...Photon polar and azimuthal angle.
76691 PME=2D0*(PYMASS(11)/ECM)**2
76692 120 CTHM=PME*(2D0/PME)**PYR(0)
76693 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
76694 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
76696 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
76697 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
76698 THEK=PYANGL(CTHE,STHE)
76699 PHIK=PARU(2)*PYR(0)
76701 C...Rotation angle for hadronic system.
76703 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
76705 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
76706 &(2D0-XK*(1D0-SGN*CTHE)))
76711 C*********************************************************************
76714 C...Selects flavour for produced qqbar pair.
76716 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
76718 C...Double precision and integer declarations.
76719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76720 IMPLICIT INTEGER(I-N)
76721 INTEGER PYK,PYCHGE,PYCOMP
76723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76725 SAVE /PYDAT1/,/PYDAT2/
76727 C...Calculate maximum weight in QED or QFD case.
76728 IF(MSTJ(102).LE.1) THEN
76731 POLL=1D0-PARJ(131)*PARJ(132)
76732 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76733 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76734 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
76735 VE=4D0*PARU(102)-1D0
76736 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
76737 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76738 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
76739 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
76740 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
76744 C...Choose flavour. Gives charge and velocity.
76747 IF(NTRY.GT.100) THEN
76748 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
76753 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
76756 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
76757 QF=KCHG(KFLC,1)/3D0
76759 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
76761 C...Calculate weight in QED or QFD case.
76762 IF(MSTJ(102).LE.1) THEN
76764 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
76766 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76767 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
76768 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
76770 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
76773 C...Weighting or new event (radiative photon). Cross-section update.
76774 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
76775 PARJ(158)=PARJ(158)+1D0
76776 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
76777 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
76778 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
76779 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
76780 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76785 C*********************************************************************
76788 C...Selects number of jets in matrix element approach.
76790 SUBROUTINE PYXJET(ECM,NJET,CUT)
76792 C...Double precision and integer declarations.
76793 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76794 IMPLICIT INTEGER(I-N)
76795 INTEGER PYK,PYCHGE,PYCOMP
76797 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76799 C...Local array and data.
76801 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
76803 C...Trivial result for two-jets only, including parton shower.
76804 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76807 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76808 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
76810 IF(MSTJ(109).EQ.2) CF=1D0
76811 IF(MSTJ(111).EQ.0) THEN
76814 ELSEIF(MSTU(111).EQ.0) THEN
76815 PARJ(169)=MIN(1D0,PARJ(129))
76816 Q2=PARJ(169)*ECM**2
76817 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76818 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76819 Q2R=PARJ(168)*ECM**2
76821 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
76822 Q2=PARJ(169)*ECM**2
76823 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76824 & (2D0*PARU(112)/ECM)**2))
76825 Q2R=PARJ(168)*ECM**2
76828 C...alpha_strong for R and R itself.
76829 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
76830 IF(IABS(MSTJ(101)).EQ.1) THEN
76832 ELSEIF(MSTJ(109).EQ.0) THEN
76833 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76834 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
76835 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
76837 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
76840 C...alpha_strong for jet rate. Initial value for y cut.
76841 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76842 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
76843 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
76844 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
76845 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76847 C...Parametrization of first order three-jet cross-section.
76848 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
76851 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
76852 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
76853 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
76854 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
76855 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
76859 C...Parametrization of second order three-jet cross-section.
76860 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
76861 & CUT.GE.0.25D0) THEN
76863 ELSEIF(MSTJ(110).LE.1) THEN
76864 CT=LOG(1D0/CUT-2D0)
76865 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
76866 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
76868 C...Interpolation in second/first order ratio for Zhu parametrization.
76869 ELSEIF(MSTJ(110).EQ.2) THEN
76872 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
76878 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
76880 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
76883 C...Shift in second order three-jet cross-section with optimized Q^2.
76884 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
76885 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
76886 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
76888 C...Parametrization of second order four-jet cross-section.
76889 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
76892 CT=LOG(1D0/CUT-5D0)
76893 IF(CUT.LE.0.018D0) THEN
76894 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
76895 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
76897 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
76898 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76900 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
76901 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
76902 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
76903 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
76904 & 0.002093D0*CT**3)
76905 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76907 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
76908 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
76911 C...If negative three-jet rate, change y' optimization parameter.
76912 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
76913 & PARJ(169).LT.0.99D0) THEN
76914 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76915 Q2=PARJ(169)*ECM**2
76916 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76920 C...If too high cross-section, use harder cuts, or fail.
76921 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
76922 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
76923 & PARJ(169).LT.0.99D0) THEN
76924 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76925 Q2=PARJ(169)*ECM**2
76926 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76928 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
76930 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76932 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
76933 & PARJ(154))**(-1D0/3D0)
76934 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76938 C...Scalar gluon (first order only).
76940 ALSPI=PYALPS(ECM**2)/PARU(1)
76941 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
76943 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
76944 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
76949 C...Select number of jets.
76951 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76953 ELSEIF(MSTJ(101).LE.0) THEN
76954 NJET=MIN(4,2-MSTJ(101))
76958 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
76959 IF(PARJ(154).GT.RNJ) NJET=4
76965 C*********************************************************************
76968 C...Selects the kinematical variables of three-jet events.
76970 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
76972 C...Double precision and integer declarations.
76973 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76974 IMPLICIT INTEGER(I-N)
76975 INTEGER PYK,PYCHGE,PYCOMP
76977 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76980 DIMENSION ZHUP(5,12)
76982 C...Coefficients of Zhu second order parametrization.
76983 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
76984 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
76985 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
76986 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
76987 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
76988 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
76989 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
76990 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
76991 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
76992 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
76993 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
76995 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76996 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
76999 C...Event type. Mass effect factors and other common constants.
77003 QME=(2D0*PMQ/ECM)**2
77004 IF(MSTJ(109).NE.1) THEN
77006 CUTD=LOG(1D0/CUT-2D0)
77007 IF(MSTJ(109).EQ.0) THEN
77011 WTMX=MIN(20D0,37D0-6D0*CUTD)
77012 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
77020 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
77021 ALS2PI=PARU(118)/PARU(2)
77023 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
77024 & LOG(PARJ(169))*ALS2PI
77025 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
77027 C...Choose three-jet events in allowed region.
77029 110 Y13L=CUTL+CUTD*PYR(0)
77030 Y23L=CUTL+CUTD*PYR(0)
77034 IF(Y12.LE.CUT) GOTO 110
77035 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
77037 C...Second order corrections.
77038 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
77043 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
77044 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
77045 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
77046 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
77047 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
77048 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
77049 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
77050 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
77051 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
77052 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
77053 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
77054 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
77055 & TR*(2D0*CUTL/3D0-10D0/9D0)+
77056 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
77057 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
77058 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
77059 & Y13*Y23)/(Y12+Y13)**2)/WT1+
77060 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
77061 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
77062 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
77063 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
77064 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
77065 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
77066 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
77067 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77068 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77069 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
77071 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
77072 C...Second order corrections; Zhu parametrization of ERT.
77077 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
77081 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77082 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77083 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77084 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77087 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77088 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77089 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77090 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77092 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77093 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77094 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77095 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77096 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
77098 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77099 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77100 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
77103 C...Impose mass cuts (gives two jets). For fixed jet number new try.
77107 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
77108 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
77109 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
77110 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
77111 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
77113 C...Scalar gluon model (first order only, no mass effects).
77116 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
77117 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
77118 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
77119 X1=1D0-0.5D0*(X3+YD)
77120 X2=1D0-0.5D0*(X3-YD)
77121 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
77122 IF(MSTJ(102).GE.2) THEN
77123 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
77124 & X3**2*PYR(0)) NJET=2
77126 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
77132 C*********************************************************************
77135 C...Selects the kinematical variables of four-jet events.
77137 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77139 C...Double precision and integer declarations.
77140 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77141 IMPLICIT INTEGER(I-N)
77142 INTEGER PYK,PYCHGE,PYCOMP
77144 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77147 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
77149 C...Common constants. Colour factors for QCD and Abelian gluon theory.
77151 QME=(2D0*PMQ/ECM)**2
77152 CT=LOG(1D0/CUT-5D0)
77153 IF(MSTJ(109).EQ.0) THEN
77163 C...Choice of process (qqbargg or qqbarqqbar).
77166 IF(PARJ(155).GT.PYR(0)) IT=2
77167 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
77168 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
77169 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
77170 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
77173 C...Sample the five kinematical variables (for qqgg preweighted in y34).
77174 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77175 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77176 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
77177 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
77178 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
77180 CP=COS(PARU(1)*PYR(0))
77183 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
77184 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
77185 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
77187 Y12=1D0-Y134-Y23-Y24
77188 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
77192 C...Calculate matrix elements for qqgg or qqqq process.
77197 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
77198 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
77199 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
77200 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
77201 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
77202 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
77203 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
77204 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
77205 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
77206 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
77207 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
77208 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
77209 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
77210 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
77211 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
77212 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
77213 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
77214 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
77215 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
77216 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
77217 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
77218 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
77219 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
77220 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
77221 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
77222 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
77223 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
77224 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
77225 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
77226 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
77227 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
77228 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
77229 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
77230 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
77231 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
77232 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
77233 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
77234 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
77235 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
77236 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
77237 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
77240 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
77241 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
77242 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
77243 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
77244 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
77245 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
77246 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
77247 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
77248 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
77249 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
77250 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
77251 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
77252 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
77253 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
77254 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
77255 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
77256 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
77257 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
77260 C...Permutations of momenta in matrix element. Weighting.
77261 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
77272 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
77283 IF(IC.LE.3) GOTO 120
77284 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
77287 C...qqgg events: string configuration and event type.
77289 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
77290 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
77291 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
77292 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
77293 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
77294 IF(ID.EQ.2) GOTO 130
77295 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
77296 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
77297 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
77298 IF(ID.EQ.2) GOTO 130
77301 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
77302 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
77305 C...Mass cuts. Kinematical variables out.
77306 IF(Y12.LE.CUT+QME) NJET=2
77307 IF(NJET.EQ.2) GOTO 150
77308 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
77309 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
77310 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
77312 X12=(1D0-Q12)*Y13+Q12*Y23
77314 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77316 C...qqbarqqbar events: string configuration, choose new flavour.
77319 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
77320 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
77321 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
77322 IF(WTR.LT.WTD(4)) ID=4
77323 IF(ID.GE.2) GOTO 130
77326 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
77327 140 KFLN=1+INT(5D0*PYR(0))
77328 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
77329 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
77330 IF(KFLN.GT.MSTJ(104)) NJET=2
77332 QMEN=(2D0*PMQN/ECM)**2
77334 C...Mass cuts. Kinematical variables out.
77335 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
77336 IF(NJET.EQ.2) GOTO 150
77337 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
77338 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
77339 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
77340 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
77341 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
77342 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
77345 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
77347 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
77348 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
77349 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77351 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
77356 C*********************************************************************
77359 C...Gives the angular orientation of events.
77361 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
77363 C...Double precision and integer declarations.
77364 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77365 IMPLICIT INTEGER(I-N)
77366 INTEGER PYK,PYCHGE,PYCOMP
77368 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77369 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77370 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77371 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77373 C...Charge. Factors depending on polarization for QED case.
77375 POLL=1D0-PARJ(131)*PARJ(132)
77376 POLD=PARJ(132)-PARJ(131)
77377 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
77383 C...Factors depending on flavour, energy and polarization for QFD case.
77385 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
77386 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
77387 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
77389 VE=4D0*PARU(102)-1D0
77391 VF=AF-4D0*QF*PARU(102)
77392 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
77393 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
77394 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
77395 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
77396 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
77397 & SFW*SFF**2*(VE**2-AE**2))
77398 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
77402 C...Mass factor. Differential cross-sections for two-jet events.
77405 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
77406 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
77408 SIGU=4D0*SQRT(1D0-QME)
77409 SIGL=2D0*QME*SQRT(1D0-QME)
77415 C...Kinematical variables. Reduce four-jet event to three-jet one.
77418 X1=2D0*P(NC+1,4)/ECM
77419 X2=2D0*P(NC+3,4)/ECM
77421 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
77422 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
77423 X1=2D0*P(NC+1,4)/ECMR
77424 X2=2D0*P(NC+4,4)/ECMR
77427 C...Differential cross-sections for three-jet (or reduced four-jet).
77428 XQ=(1D0-X1)/(1D0-X2)
77429 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
77430 ST12=SQRT(1D0-CT12**2)
77431 IF(MSTJ(109).NE.1) THEN
77432 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
77433 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
77434 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
77435 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
77437 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
77438 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
77439 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
77440 SIGA=X2**2*ST12/SQ2
77441 SIGP=2D0*(X1**2-X2**2*CT12)
77443 C...Differential cross-sect for scalar gluons (no mass effects).
77447 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
77448 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
77449 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
77450 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
77451 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
77452 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
77453 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
77454 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
77455 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
77456 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
77457 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
77461 C...Upper bounds for differential cross-section.
77466 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
77467 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
77468 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
77469 &2D0*HF2A*ABS(SIGP)
77471 C...Generate angular orientation according to differential cross-sect.
77472 100 CHI=PARU(2)*PYR(0)
77473 CTHE=2D0*PYR(0)-1D0
77481 C2PHI=COS(2D0*(PHI-PARJ(134)))
77482 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77483 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
77484 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
77485 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
77486 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
77487 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
77488 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
77489 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
77490 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
77495 C*********************************************************************
77498 C...Generates Upsilon and toponium decays into three gluons
77499 C...or two gluons and a photon.
77501 SUBROUTINE PYONIA(KFL,ECM)
77503 C...Double precision and integer declarations.
77504 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77505 IMPLICIT INTEGER(I-N)
77506 INTEGER PYK,PYCHGE,PYCOMP
77508 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77509 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77510 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77511 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77513 C...Printout. Check input parameters.
77514 IF(MSTU(12).NE.12345) CALL PYLIST(0)
77515 IF(KFL.LT.0.OR.KFL.GT.8) THEN
77516 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
77517 IF(MSTU(21).GE.1) RETURN
77519 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
77520 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
77521 IF(MSTU(21).GE.1) RETURN
77524 C...Initial e+e- and onium state (optional).
77526 IF(MSTJ(115).GE.2) THEN
77528 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
77530 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
77534 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
77540 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
77546 C...Choose x1 and x2 according to matrix element.
77551 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
77552 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
77555 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
77556 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
77558 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77559 MSTU(111)=MSTJ(108)
77560 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
77562 PARU(112)=PARJ(121)
77563 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
77565 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
77566 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
77569 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
77570 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
77572 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
77573 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
77576 ECMC=SQRT(1D0-X1)*ECM
77577 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
77582 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
77583 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
77584 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
77585 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
77587 IF(ECMC.LT.4D0*PARJ(127)) THEN
77591 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
77597 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
77600 C...Differential cross-sections. Upper limit for cross-section.
77601 IF(MSTJ(106).EQ.1) THEN
77603 HF1=1D0-PARJ(131)*PARJ(132)
77605 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
77606 ST13=SQRT(1D0-CT13**2)
77607 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
77608 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
77610 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
77611 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
77612 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
77614 C...Angular orientation of event.
77615 120 CHI=PARU(2)*PYR(0)
77616 CTHE=2D0*PYR(0)-1D0
77624 C2PHI=COS(2D0*(PHI-PARJ(134)))
77625 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77626 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
77627 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
77628 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
77629 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
77630 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
77631 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
77632 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
77633 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
77636 C...Generate parton shower. Rearrange along strings and check.
77637 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
77638 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
77640 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
77641 IF(MSTJ(105).GE.0) MSTU(28)=0
77644 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
77647 C...Generate fragmentation. Information for PYTABU:
77648 IF(MSTJ(105).EQ.1) CALL PYEXEC
77649 MSTU(161)=110*KFLC+3
77655 C*********************************************************************
77658 C...Books a histogram.
77660 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
77662 C...Double precision declaration.
77663 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77664 IMPLICIT INTEGER(I-N)
77666 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77668 C...Local character variables.
77669 CHARACTER TITLE*(*), TITFX*60
77671 C...Check that input is sensible. Find initial address in memory.
77672 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77673 &'(PYBOOK:) not allowed histogram number')
77674 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
77675 &'(PYBOOK:) not allowed number of bins')
77676 IF(XL.GE.XU) CALL PYERRM(28,
77677 &'(PYBOOK:) x limits in wrong order')
77679 IHIST(4)=IHIST(4)+28+NX
77680 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
77681 &'(PYBOOK:) out of histogram space')
77684 C...Store histogram size and reset contents.
77688 BIN(IS+4)=(XU-XL)/NX
77691 C...Store title by conversion to integer to double precision.
77694 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
77695 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
77701 C*********************************************************************
77704 C...Fills entry in histogram.
77706 SUBROUTINE PYFILL(ID,X,W)
77708 C...Double precision declaration.
77709 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77710 IMPLICIT INTEGER(I-N)
77712 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77715 C...Find initial address in memory. Increase number of entries.
77716 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77717 &'(PYFILL:) not allowed histogram number')
77719 IF(IS.EQ.0) CALL PYERRM(28,
77720 &'(PYFILL:) filling unbooked histogram')
77721 BIN(IS+5)=BIN(IS+5)+1D0
77723 C...Find bin in x, including under/overflow, and fill.
77724 IF(X.LT.BIN(IS+2)) THEN
77725 BIN(IS+6)=BIN(IS+6)+W
77726 ELSEIF(X.GE.BIN(IS+3)) THEN
77727 BIN(IS+8)=BIN(IS+8)+W
77729 BIN(IS+7)=BIN(IS+7)+W
77730 IX=(X-BIN(IS+2))/BIN(IS+4)
77731 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
77732 BIN(IS+9+IX)=BIN(IS+9+IX)+W
77738 C*********************************************************************
77741 C...Multiplies histogram contents by factor.
77743 SUBROUTINE PYFACT(ID,F)
77745 C...Double precision declaration.
77746 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77747 IMPLICIT INTEGER(I-N)
77749 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77752 C...Find initial address in memory. Multiply all contents bins.
77753 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77754 &'(PYFACT:) not allowed histogram number')
77756 IF(IS.EQ.0) CALL PYERRM(28,
77757 &'(PYFACT:) scaling unbooked histogram')
77758 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
77765 C*********************************************************************
77768 C...Performs operations between histograms.
77770 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
77772 C...Double precision declaration.
77773 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77774 IMPLICIT INTEGER(I-N)
77776 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77778 C...Character variable.
77781 C...Find initial addresses in memory, and histogram size.
77782 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
77783 &'(PYFACT:) not allowed histogram number')
77785 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
77786 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
77787 NX=NINT(BIN(IS3+1))
77788 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
77790 C...Update info on number of histogram entries.
77791 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
77792 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
77793 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
77794 BIN(IS3+5)=BIN(IS1+5)
77797 C...Operations on pair of histograms: addition, subtraction,
77798 C...multiplication, division.
77799 IF(OPER.EQ.'+') THEN
77801 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
77803 ELSEIF(OPER.EQ.'-') THEN
77805 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
77807 ELSEIF(OPER.EQ.'*') THEN
77809 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
77811 ELSEIF(OPER.EQ.'/') THEN
77814 IF(ABS(FA2).LE.1D-20) THEN
77817 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
77821 C...Operations on single histogram: multiplication+addition,
77822 C...square root+addition, logarithm+addition.
77823 ELSEIF(OPER.EQ.'A') THEN
77825 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
77827 ELSEIF(OPER.EQ.'S') THEN
77829 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
77831 ELSEIF(OPER.EQ.'L') THEN
77834 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
77835 & ZMIN=0.8D0*BIN(IS1+IX)
77838 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
77841 C...Operation on two or three histograms: average and
77842 C...standard deviation.
77843 ELSEIF(OPER.EQ.'M') THEN
77845 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77848 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
77851 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77854 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
77858 BIN(IS1+IX)=F1*BIN(IS1+IX)
77865 C*********************************************************************
77868 C...Prints and resets all histograms.
77872 C...Double precision declaration.
77873 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77874 IMPLICIT INTEGER(I-N)
77876 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77879 C...Loop over histograms, print and reset used ones.
77880 DO 100 ID=1,IHIST(1)
77882 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
77891 C*********************************************************************
77894 C...Prints a histogram (but does not reset it).
77896 SUBROUTINE PYPLOT(ID)
77898 C...Double precision declaration.
77899 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77900 IMPLICIT INTEGER(I-N)
77902 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77903 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77904 SAVE /PYDAT1/,/PYBINS/
77905 C...Local arrays and character variables.
77906 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
77907 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77909 C...Steps in histogram scale. Character sequence.
77910 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77911 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
77913 C...Find initial address in memory; skip if empty histogram.
77914 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
77917 IF(NINT(BIN(IS+5)).LE.0) THEN
77918 WRITE(MSTU(11),5000) ID
77922 C...Number of histogram lines and x bins.
77926 C...Extract title by conversion from double precision via integer.
77928 IEQ=NINT(BIN(IS+8+NX+IT))
77929 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
77930 & //CHAR(MOD(IEQ,256))
77933 C...Find time; print title.
77935 IF(IDATI(1).GT.0) THEN
77936 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
77938 WRITE(MSTU(11),5200) ID, TITLE
77941 C...Find minimum and maximum bin content.
77944 DO 110 IX=IS+10,IS+8+NX
77945 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
77946 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
77949 C...Determine scale and step size for y axis.
77950 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
77951 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
77952 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
77953 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
77954 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
77955 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
77958 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
77962 C...Convert bin contents to integer form; fractional fill in top row.
77964 CTA=ABS(BIN(IS+8+IX))/DY
77965 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
77966 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
77968 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
77969 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
77971 C...Print histogram row by row.
77972 DO 150 IR=IRMA,IRMI,-1
77973 IF(IR.EQ.0) GOTO 150
77976 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
77977 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
77979 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
77982 C...Print sign and value of bin contents.
77983 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
77986 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
77987 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
77989 WRITE(MSTU(11),5400) OUT
77992 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77994 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
77997 C...Print sign and value of lower bin edge.
77998 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
78002 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
78003 & OUT(IX:IX)=CHA(11)
78004 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
78006 WRITE(MSTU(11),5600) OUT
78009 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
78011 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
78015 C...Calculate and print statistics.
78020 CTA=ABS(BIN(IS+8+IX))
78021 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
78024 CXXSUM=CXXSUM+CTA*X**2
78026 XMEAN=CXSUM/MAX(CSUM,1D-20)
78027 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
78028 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
78029 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
78031 C...Formats for output.
78032 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
78033 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
78035 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
78036 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
78037 5400 FORMAT(/8X,'Contents',3X,A100)
78038 5500 FORMAT(9X,'*10**',I2,3X,A100)
78039 5600 FORMAT(/8X,'Low edge',3X,A100)
78040 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
78041 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
78042 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
78047 C*********************************************************************
78050 C...Resets bin contents of a histogram.
78052 SUBROUTINE PYNULL(ID)
78054 C...Double precision declaration.
78055 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78056 IMPLICIT INTEGER(I-N)
78058 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78061 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
78064 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
78071 C*********************************************************************
78074 C...Dumps histogram contents on file for reading by other program.
78075 C...Can also read back own dump.
78077 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
78079 C...Double precision declaration.
78080 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78081 IMPLICIT INTEGER(I-N)
78083 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78085 C...Local arrays and character variables.
78086 DIMENSION IHI(*),ISS(100),VAL(5)
78087 CHARACTER TITLE*60,FORMAT*13
78089 C...Dump all histograms that have been booked,
78090 C...including titles and ranges, one after the other.
78091 IF(MDUMP.EQ.1) THEN
78093 C...Loop over histograms and find which are wanted and booked.
78108 C...Write title, histogram size, filling statistics.
78111 IEQ=NINT(BIN(IS+8+NX+IT))
78112 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
78113 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
78115 WRITE(LFN,5100) ID,TITLE
78116 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
78117 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
78121 C...Write histogram contents, in groups of five.
78122 DO 120 IXG=1,(NX+4)/5
78126 VAL(IXV)=BIN(IS+8+IX)
78131 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
78134 C...Go to next histogram; finish.
78135 ELSEIF(NHI.GT.0) THEN
78136 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78140 C...Read back in histograms dumped MDUMP=1.
78141 ELSEIF(MDUMP.EQ.2) THEN
78143 C...Read histogram number, title and range, and book.
78144 140 READ(LFN,5100,END=170) ID,TITLE
78145 READ(LFN,5200) NX,XL,XU
78146 CALL PYBOOK(ID,TITLE,NX,XL,XU)
78149 C...Read filling statistics.
78150 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
78151 BIN(IS+5)=DBLE(NENTRY)
78153 C...Read histogram contents, in groups of five.
78154 DO 160 IXG=1,(NX+4)/5
78155 READ(LFN,5400) (VAL(IXV),IXV=1,5)
78158 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
78162 C...Go to next histogram; finish.
78166 C...Write histogram contents in column format,
78167 C...convenient e.g. for GNUPLOT input.
78168 ELSEIF(MDUMP.EQ.3) THEN
78170 C...Find addresses to wanted histograms.
78184 IF(IS.NE.0.AND.NSS.LT.100) THEN
78187 ELSEIF(NSS.GE.100) THEN
78188 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
78189 ELSEIF(NHI.GT.0) THEN
78190 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78194 C...Check that they have common number of x bins. Fix format.
78195 NX=NINT(BIN(ISS(1)+1))
78197 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
78198 CALL PYERRM(8,'(PYDUMP:) different number of bins')
78202 FORMAT='(1P,000E12.4)'
78203 WRITE(FORMAT(5:7),'(I3)') NSS+1
78205 C...Write histogram contents; first column x values.
78207 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
78208 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
78213 C...Formats for output.
78214 5100 FORMAT(I5,5X,A60)
78215 5200 FORMAT(I5,1P,2D12.4)
78216 5300 FORMAT(I12,1P,3D12.4)
78217 5400 FORMAT(1P,5D12.4)
78222 C*********************************************************************
78225 C...Allows users to handle STOP statemens
78227 SUBROUTINE PYSTOP(MCOD)
78229 C...Double precision and integer declarations.
78230 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78231 IMPLICIT INTEGER(I-N)
78232 INTEGER PYK,PYCHGE,PYCOMP
78234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78238 C...Write message, then stop
78239 WRITE(MSTU(11),5000) MCOD
78243 C...Formats for output.
78244 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
78247 C*********************************************************************
78250 C...Dummy routine, which the user can replace in order to make cuts on
78251 C...the kinematics on the parton level before the matrix elements are
78252 C...evaluated and the event is generated. The cross-section estimates
78253 C...will automatically take these cuts into account, so the given
78254 C...values are for the allowed phase space region only. MCUT=0 means
78255 C...that the event has passed the cuts, MCUT=1 that it has failed.
78257 SUBROUTINE PYKCUT(MCUT)
78259 C...Double precision and integer declarations.
78260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78261 IMPLICIT INTEGER(I-N)
78262 INTEGER PYK,PYCHGE,PYCOMP
78264 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78265 COMMON/PYINT1/MINT(400),VINT(400)
78266 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78267 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78269 C...Set default value (accepting event) for MCUT.
78272 C...Read out subprocess number.
78276 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78280 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78282 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78284 C...Calculate x_1, x_2, x_F.
78285 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
78286 X1=SQRT(TAU)*EXP(YST)
78287 X2=SQRT(TAU)*EXP(-YST)
78289 X1=SQRT(TAUP)*EXP(YST)
78290 X2=SQRT(TAUP)*EXP(-YST)
78294 C...Calculate shat, that, uhat, p_T^2.
78300 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
78301 RPTS=4D0*VINT(71)**2/SHAT
78302 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
78305 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
78306 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
78307 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
78308 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
78310 C...Decisions by user to be put here.
78312 C...Stop program if this routine is ever called.
78313 C...You should not copy these lines to your own routine.
78314 WRITE(MSTU(11),5000)
78317 C...Format for error printout.
78318 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
78319 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78320 &1X,'Execution stopped!')
78325 C*********************************************************************
78327 c Dummy routine commented out:
78328 c A reweighting routine for AliRoot is implemented in pyevwt.f
78331 C...Dummy routine, which the user can replace in order to multiply the
78332 C...standard PYTHIA differential cross-section by a process- and
78333 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78334 C...to generation of weighted events, with weight 1/WTXS, while for
78335 C...MSTP(142)=2 it corresponds to a modification of the underlying
78338 c SUBROUTINE PYEVWT(WTXS)
78340 C...Double precision and integer declarations.
78341 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78342 c IMPLICIT INTEGER(I-N)
78343 c INTEGER PYK,PYCHGE,PYCOMP
78345 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78346 c COMMON/PYINT1/MINT(400),VINT(400)
78347 c COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78348 c SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78350 C...Set default weight for WTXS.
78353 C...Read out subprocess number.
78357 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78361 c IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78363 c IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78365 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78374 C...Modifications by user to be put here.
78376 C...Stop program if this routine is ever called.
78377 C...You should not copy these lines to your own routine.
78378 c WRITE(MSTU(11),5000)
78381 C...Format for error printout.
78382 c 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
78383 c &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78384 c &1X,'Execution stopped!')
78389 C*********************************************************************
78392 C...Dummy routine, to be replaced by a user implementing external
78393 C...processes. Is supposed to fill the HEPRUP commonblock with info
78394 C...on incoming beams and allowed processes.
78396 C...New example: handles a standard Les Houches Events File.
78400 C...Double precision and integer declarations.
78401 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78402 IMPLICIT INTEGER(I-N)
78404 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78405 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78408 C...User process initialization commonblock.
78410 PARAMETER (MAXPUP=100)
78411 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78412 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78413 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78414 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78418 C...Lines to read in assumed never longer than 200 characters.
78419 PARAMETER (MAXLEN=200)
78420 CHARACTER*(MAXLEN) STRING
78422 C...Format for reading lines.
78425 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78427 C...Loop until finds line beginning with "<init>" or "<init ".
78428 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
78431 C...Allow indentation.
78432 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
78433 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
78434 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
78436 C...Read first line of initialization info.
78437 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78438 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78440 C...Read NPRUP subsequent lines with information on each process.
78442 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78443 & XMAXUP(IPR),LPRUP(IPR)
78447 C...Error exit: give up if initalization does not work.
78448 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78449 WRITE(*,*) ' Event generation will be stopped.'
78455 C...Old example: handles a simple Pythia 6.4 initialization file.
78457 c SUBROUTINE UPINIT
78459 C...Double precision and integer declarations.
78460 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78461 c IMPLICIT INTEGER(I-N)
78464 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78465 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78466 c SAVE /PYDAT1/,/PYPARS/
78468 C...User process initialization commonblock.
78470 c PARAMETER (MAXPUP=100)
78471 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78472 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78473 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78474 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78478 C...Read info from file.
78479 c IF(MSTP(161).GT.0) THEN
78480 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78481 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78482 c DO 100 IPR=1,NPRUP
78483 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78484 c & XMAXUP(IPR),LPRUP(IPR)
78487 C...Error or prematurely reached end of file.
78488 c 110 WRITE(MSTU(11),5000)
78491 C...Else not implemented.
78493 c WRITE(MSTU(11),5100)
78497 C...Format for error printout.
78498 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78499 c &1X,'Execution stopped!')
78500 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78501 c &1X,'Dummy routine in PYTHIA file called instead.'/
78502 c &1X,'Execution stopped!')
78507 C*********************************************************************
78510 C...Dummy routine, to be replaced by a user implementing external
78511 C...processes. Depending on cross section model chosen, it either has
78512 C...to generate a process of the type IDPRUP requested, or pick a type
78513 C...itself and generate this event. The event is to be stored in the
78514 C...HEPEUP commonblock, including (often) an event weight.
78516 C...New example: handles a standard Les Houches Events File.
78520 C...Double precision and integer declarations.
78521 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78522 IMPLICIT INTEGER(I-N)
78524 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78525 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78528 C...User process event common block.
78530 PARAMETER (MAXNUP=500)
78531 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78532 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78533 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78534 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78535 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78538 C...Lines to read in assumed never longer than 200 characters.
78539 PARAMETER (MAXLEN=200)
78540 CHARACTER*(MAXLEN) STRING
78542 C...Format for reading lines.
78545 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78547 C...Loop until finds line beginning with "<event>" or "<event ".
78548 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
78551 C...Allow indentation.
78552 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
78553 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
78554 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
78556 C...Read first line of event info.
78557 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78560 C...Read NUP subsequent lines with information on each particle.
78562 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78563 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78564 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78568 C...Error exit, typically when no more events.
78569 130 WRITE(*,*) ' Failed to read LHEF event information.'
78570 WRITE(*,*) ' Will assume end of file has been reached.'
78577 C...Old example: handles a simple Pythia 6.4 event file.
78579 c SUBROUTINE UPEVNT
78581 C...Double precision and integer declarations.
78582 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78583 c IMPLICIT INTEGER(I-N)
78586 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78587 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78588 c SAVE /PYDAT1/,/PYPARS/
78590 C...User process event common block.
78592 c PARAMETER (MAXNUP=500)
78593 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78594 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78595 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78596 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78597 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78600 C...Read info from file.
78601 c IF(MSTP(162).GT.0) THEN
78602 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78605 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78606 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78607 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78610 C...Special when reached end of file or other error.
78613 C...Else not implemented.
78615 c WRITE(MSTU(11),5000)
78619 C...Format for error printout.
78620 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78621 c &1X,'Dummy routine in PYTHIA file called instead.'/
78622 c &1X,'Execution stopped!')
78627 C*********************************************************************
78630 C...Dummy routine, to be replaced by user, to veto event generation
78631 C...on the parton level, after parton showers but before multiple
78632 C...interactions, beam remnants and hadronization is added.
78633 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78634 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78635 C...be undecayed at this stage; if decayed their decay products will
78636 C...have been allowed to shower.
78638 C...All partons at the end of the shower phase are stored in the
78639 C...HEPEVT commonblock. The interesting information is
78640 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78641 C...IDHEP(I) = the particle ID code according to PDG conventions,
78642 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78643 C...All ISTHEP entries are 1, while the rest is zeroed.
78645 C...The user decision is to be conveyed by the IVETO value.
78646 C...IVETO = 0 : retain current event and generate in full;
78647 C... = 1 : abort generation of current event and move to next.
78649 SUBROUTINE UPVETO(IVETO)
78651 C...HEPEVT commonblock.
78652 PARAMETER (NMXHEP=4000)
78653 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
78654 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
78655 DOUBLE PRECISION PHEP,VHEP
78658 C...Next few lines allow you to see what info PYVETO extracted from
78659 C...the full event record for the first two events.
78660 C...Delete if you don't want it.
78663 IF(NLIST.LE.2) THEN
78664 WRITE(*,*) ' Full event record at time of UPVETO call:'
78666 WRITE(*,*) ' Part of event record made available to UPVETO:'
78671 C...Make decision here.
78677 C*********************************************************************
78679 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78681 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78682 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78683 IMPLICIT INTEGER(I-N)
78684 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78687 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78690 C...Stop program if this routine is ever called.
78691 WRITE(MSTU(11),5000)
78694 C...Format for error printout.
78695 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78696 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
78697 &1X,'Execution stopped!')
78702 C*********************************************************************
78705 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78709 IMPLICIT INTEGER(I-N)
78710 CHARACTER*40 VISAJE
78713 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78716 C...Assign default value.
78719 C...Stop program if this routine is ever called.
78720 WRITE(MSTU(11),5000)
78723 C...Format for error printout.
78724 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78725 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
78726 &1X,'Execution stopped!')
78731 C*********************************************************************
78734 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78736 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78737 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78738 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78741 IMPLICIT INTEGER(I-N)
78742 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78743 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78744 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
78746 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78749 C...Stop program if this routine is ever called.
78750 WRITE(MSTU(11),5000)
78753 C...Format for error printout.
78754 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78755 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78756 &1X,'Execution stopped!')
78760 C*********************************************************************
78763 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78765 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78766 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78767 IMPLICIT INTEGER(I-N)
78768 Cmssmpart = 4 # full MSSM [recommended]
78769 Cfieldren = 0 # MSbar field ren. [strongly recommended]
78770 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78771 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78772 Cp2approx = 0 # no approximation [recommended]
78773 Clooplevel= 2 # include 2-loop corrections
78774 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78775 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78778 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78781 C...Stop program if this routine is ever called.
78782 WRITE(MSTU(11),5000)
78785 C...Format for error printout.
78786 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78787 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78788 &1X,'Execution stopped!')
78792 C*********************************************************************
78795 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78797 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78798 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78799 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78800 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78801 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78802 IMPLICIT INTEGER(I-N)
78804 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78805 DOUBLE COMPLEX DMU,
78806 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78810 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78813 C...Stop program if this routine is ever called.
78814 WRITE(MSTU(11),5000)
78817 C...Format for error printout.
78818 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78819 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78820 &1X,'Execution stopped!')
78824 C*********************************************************************
78827 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78829 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
78830 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78831 IMPLICIT INTEGER(I-N)
78833 C...FeynHiggs variables
78834 DOUBLE PRECISION RMHIGG(4)
78835 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78836 DOUBLE COMPLEX DMU,
78837 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78844 C...Stop program if this routine is ever called.
78845 WRITE(MSTU(11),5000)
78848 C...Format for error printout.
78849 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78850 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78851 &1X,'Execution stopped!')
78855 C*********************************************************************
78858 C...Dummy routine, to be replaced by user, to handle the decay of a
78859 C...polarized tau lepton.
78861 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78862 C...IORIG is the position where the mother of the tau is stored;
78863 C... is 0 when the mother is not stored.
78864 C...KFORIG is the flavour of the mother of the tau;
78865 C... is 0 when the mother is not known.
78866 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78867 C... e.g. in B hadron semileptonic decays the W propagator
78868 C... is not explicitly stored but the W code is still unambiguous.
78870 C...NDECAY is the number of decay products in the current tau decay.
78871 C...These decay products should be added to the /PYJETS/ common block,
78872 C...in positions N+1 through N+NDECAY. For each product I you must
78873 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78874 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78876 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
78878 C...Double precision and integer declarations.
78879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78880 IMPLICIT INTEGER(I-N)
78881 INTEGER PYK,PYCHGE,PYCOMP
78883 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78884 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78885 SAVE /PYJETS/,/PYDAT1/
78887 C...Stop program if this routine is ever called.
78888 C...You should not copy these lines to your own routine.
78889 NDECAY=ITAU+IORIG+KFORIG
78890 WRITE(MSTU(11),5000)
78893 C...Format for error printout.
78894 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
78895 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78896 &1X,'Execution stopped!')
78901 C*********************************************************************
78904 C...Finds current date and time.
78905 C...Since this task is not standardized in Fortran 77, the routine
78906 C...is dummy, to be replaced by the user. Examples are given for
78907 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78908 C...you do not have access to suitable routines.
78910 SUBROUTINE PYTIME(IDATI)
78912 C...Double precision and integer declarations.
78913 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78914 IMPLICIT INTEGER(I-N)
78915 INTEGER PYK,PYCHGE,PYCOMP
78918 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
78920 C...Example 0: if you do not have suitable routines.
78925 C...Example 1: Fortran 90 routine.
78926 C CALL DATE_AND_TIME(VALUES=IVAL)
78934 C...Example 2: DEC Fortran 77. AIX.
78935 C CALL IDATE(IMON,IDAY,IYEAR)
78939 C CALL ITIME(IHOUR,IMIN,ISEC)
78944 C...Example 3: DEC Fortran, IRIX, IRIX64.
78945 C CALL IDATE(IMON,IDAY,IYEAR)
78953 C READ(ATIME(1:2),'(I2)') IHOUR
78954 C READ(ATIME(4:5),'(I2)') IMIN
78955 C READ(ATIME(7:8),'(I2)') ISEC
78960 C...Example 4: GNU LINUX libU77, SunOS.
78961 C CALL IDATE(IDTEMP)
78962 C IDATI(1)=IDTEMP(3)
78963 C IDATI(2)=IDTEMP(2)
78964 C IDATI(3)=IDTEMP(1)
78965 C CALL ITIME(IDTEMP)
78966 C IDATI(4)=IDTEMP(1)
78967 C IDATI(5)=IDTEMP(2)
78968 C IDATI(6)=IDTEMP(3)
78970 C...Common code to ensure right century.
78971 IDATI(1)=2000+MOD(IDATI(1),100)
78975 C... ALICE interface to PDFLIB with possibility to select nuclear structure
78978 C... The MSTP array in the PYPARS common block is used to enable and
78979 C... select the nuclear structure functions.
78980 C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
78981 C... =1: internal PYTHIA acording to MSTP(51)
78982 C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
78983 C... MSTP( 51) = 1000xNPGROUP+NPSET
78984 C... MSTP(151) = 1000xNAGROUP+NASET
78985 C... MSTP(192) : Mass number of nucleus side 1
78986 C... MSTP(193) : Mass number of nucleus side 2
78989 C... MINT(124) : side (1 or 2)
78992 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
78994 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78995 IMPLICIT INTEGER(I-N)
78996 C...Interface to PDFLIB.
78997 COMMON/LW50512/QCDL4,QCDL5
78999 DOUBLE PRECISION QCDL4,QCDL5
79000 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
79002 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
79004 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79005 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
79006 DOUBLE PRECISION VALUE(20)
79007 CHARACTER*20 PARM(20)
79008 write(6,*) MSTP(52)
79012 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
79016 VALUE(6)=MSTP(191)/1000
79018 VALUE(7)=MOD(MSTP(191),1000)
79019 CALL PDFSET(PARM,VALUE,
79020 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
79022 > XMIN,XMAX,Q2MIN,Q2MAX)
79023 IF (MSTP(194) .EQ. 0) THEN
79024 CALL SETLHAPARM("EKS98")
79025 ELSE IF (MSTP(194) .EQ. 9) THEN
79026 CALL SETLHAPARM("EPS09LO")
79027 ELSE IF (MSTP(194) .EQ. 19) THEN
79028 CALL SETLHAPARM("EPS09NLO")
79029 ELSE IF (MSTP(194) .EQ. 8) THEN
79030 CALL SETLHAPARM("EPS08")
79032 CALL SETLHAPARM("EPS09LO")
79035 write(6,*) "-> pdfset"
79036 CALL PDFSET(PARM,VALUE,
79037 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
79039 > XMIN,XMAX,Q2MIN,Q2MAX)
79046 SUBROUTINE STRUCTM_ALICE
79047 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
79049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79050 IMPLICIT INTEGER(I-N)
79051 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
79052 COMMON/PYINT1/MINT(400),VINT(400)
79053 C write(6,*) "structm_alice->"
79054 A=MSTP(191+MINT(124))
79056 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
79058 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
git://git.uio.no / u / mrichter / AliRoot.git / blob