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* CERN/PH, CH-1211 Geneva, Switzerland **
28 C* phone +41 - 22 - 767 2447 **
29 C* E-mail peter.skands@cern.ch **
31 C* Several parts are written by Hans-Uno Bengtsson **
32 C* PYSHOW is written together with Mats Bengtsson **
33 C* PYMAEL is written by Emanuel Norrbin **
34 C* advanced popcorn baryon production written by Patrik Eden **
35 C* code for virtual photons mainly written by Christer Friberg **
36 C* code for low-mass strings mainly written by Emanuel Norrbin **
37 C* Bose-Einstein code mainly written by Leif Lonnblad **
38 C* CTEQ parton distributions are by the CTEQ collaboration **
39 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
40 C* SaS photon parton distributions together with Gerhard Schuler **
41 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
42 C* MSSM Higgs mass calculation code by M. Carena, **
43 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
44 C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
45 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
46 C* NRQCD/colour octet production of onium by S. Wolf **
48 C* The latest program version and documentation is found on WWW **
49 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
51 C* Copyright Torbjorn Sjostrand, Lund 2010 **
53 C*********************************************************************
54 C*********************************************************************
56 C List of subprograms in order of appearance, with main purpose *
57 C (S = subroutine, F = function, B = block data) *
59 C B PYDATA to contain all default values *
60 C S PYCKBD to check that BLOCK DATA has been correctly loaded *
61 C S PYTEST to test the proper functioning of the package *
62 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
64 C S PYINIT to administer the initialization procedure *
65 C S PYEVNT to administer the generation of an event *
66 C S PYEVNW ditto, for new multiple interactions scenario *
67 C S PYSTAT to print cross-section and other information *
68 C S PYUPEV to administer the generation of an LHA hard process *
69 C S PYUPIN to provide initialization needed for LHA input *
70 C S PYLHEF to produce a Les Houches Event File from run *
71 C S PYINRE to initialize treatment of resonances *
72 C S PYINBM to read in beam, target and frame choices *
73 C S PYINKI to initialize kinematics of incoming particles *
74 C S PYINPR to set up the selection of included processes *
75 C S PYXTOT to give total, elastic and diffractive cross-sect. *
76 C S PYMAXI to find differential cross-section maxima *
77 C S PYPILE to select multiplicity of pileup events *
78 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
79 C S PYGAGA to handle lepton -> lepton + gamma branchings *
80 C S PYRAND to select subprocess and kinematics for event *
81 C S PYSCAT to set up kinematics and colour flow of event *
82 C S PYEVOL handler for pT-ordered ISR and multiple interactions *
83 C S PYSSPA to simulate initial state spacelike showers *
84 C S PYPTIS to do pT-ordered initial state spacelike showers *
85 C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
86 C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
87 C S PYPTMI to do pT-ordered multiple interactions *
88 C F PYFCMP to give companion quark x*f distribution *
89 C F PYPCMP to calculate momentum integral for companion quarks *
90 C S PYUPRE to rearranges contents of the HEPEUP commonblock *
91 C S PYADSH to administrate sequential final-state showers *
92 C S PYVETO to allow the generation of an event to be aborted *
93 C S PYRESD to perform resonance decays *
94 C S PYMULT to generate multiple interactions - old scheme *
95 C S PYREMN to add on target remnants - old scheme *
96 C S PYMIGN to generate multiple interactions - new scheme *
97 C S PYMIHK to connect colours in mult. int. - new scheme *
98 C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
99 C S PYMIHG to collapse two pairs of LHA1 colour tags. *
100 C S PYMIRM to add on target remnants in mult. int.- new scheme *
101 C S PYFSCR to perform final state colour reconnections - -"- *
102 C S PYDIFF to set up kinematics for diffractive events *
103 C S PYDISG to set up kinematics, remnant and showers for DIS *
104 C S PYDOCU to compute cross-sections and handle documentation *
105 C S PYFRAM to perform boosts between different frames *
106 C S PYWIDT to calculate full and partial widths of resonances *
107 C S PYOFSH to calculate partial width into off-shell channels *
108 C S PYRECO to handle colour reconnection in W+W- events *
109 C S PYKLIM to calculate borders of allowed kinematical region *
110 C S PYKMAP to construct value of kinematical variable *
111 C S PYSIGH to calculate differential cross-sections *
112 C S PYSGQC auxiliary to PYSIGH for QCD processes *
113 C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
114 C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
115 C S PYSGHG auxiliary to PYSIGH for Higgs processes *
116 C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
117 C S PYSGTC auxiliary to PYSIGH for technicolor processes *
118 C S PYSGEX auxiliary to PYSIGH for various exotic processes *
119 C S PYPDFU to evaluate parton distributions *
120 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
121 C S PYPDEL to evaluate electron parton distributions *
122 C S PYPDGA to evaluate photon parton distributions (generic) *
123 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
124 C S PYGVMD to evaluate VMD part of photon parton distributions *
125 C S PYGANO to evaluate anomalous part of photon PDFs *
126 C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
127 C S PYGDIR to evaluate direct contribution to photon PDFs *
128 C S PYPDPI to evaluate pion parton distributions *
129 C S PYPDPR to evaluate proton parton distributions *
130 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
131 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
132 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
133 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
134 C F PYGRVV auxiliary to the PYGRV* routines *
135 C F PYGRVW auxiliary to the PYGRV* routines *
136 C F PYGRVS auxiliary to the PYGRV* routines *
137 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
138 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
139 C S PYPDPO to evaluate old proton parton distributions *
140 C F PYHFTH to evaluate threshold factor for heavy flavour *
141 C S PYSPLI to find flavours left in hadron when one removed *
142 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
143 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
144 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
145 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
146 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
147 C S PYSTBH to evaluate matrix element for t + b + H processes *
148 C S PYTBHB auxiliary to PYSTBH *
149 C S PYTBHG auxiliary to PYSTBH *
150 C S PYTBHQ auxiliary to PYSTBH *
151 C F PYTBHS auxiliary to PYSTBH *
153 C S PYMSIN to initialize the supersymmetry simulation *
154 C S PYSLHA to interface to SUSY spectrum and decay calculators *
155 C S PYAPPS to determine MSSM parameters from SUGRA input *
156 C S PYSUGI to determine MSSM parameters using ISASUSY *
157 C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
158 C F PYRNMQ to determine running squark masses *
159 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
160 C S PYINOM to calculate neutralino/chargino mass eigenstates *
161 C F PYRNM3 to determine running M3, gluino mass *
162 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
163 C S PYHGGM to determine Higgs mass spectrum *
164 C S PYSUBH to determine Higgs masses in the MSSM *
165 C S PYPOLE to determine Higgs masses in the MSSM *
166 C S PYRGHM auxiliary to PYPOLE *
167 C S PYGFXX auxiliary to PYRGHM *
168 C F PYFINT auxiliary to PYPOLE *
169 C F PYFISB auxiliary to PYFINT *
170 C S PYSFDC to calculate sfermion decay partial widths *
171 C S PYGLUI to calculate gluino decay partial widths *
172 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
173 C S PYTBBC to calculate 3-body decay of gluino to chargino *
174 C S PYNJDC to calculate neutralino decay partial widths *
175 C S PYCJDC to calculate chargino decay partial widths *
176 C F PYXXZ6 auxiliary for ino 3-body decays *
177 C F PYXXGA auxiliary for ino -> ino + gamma decay *
178 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
179 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
180 C S PYHEXT to calculate non-SM Higgs decay partial widths *
181 C F PYH2XX auxiliary for H -> ino + ino decay *
182 C F PYGAUS to perform Gaussian integration *
183 C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
184 C F PYSIMP to perform Simpson integration *
185 C F PYLAMF to evaluate the lambda kinematics function *
186 C S PYTBDY to perform 3-body decay of gauginos *
187 C S PYTECM to calculate techni_rho/omega masses *
188 C S PYXDIN to initialize Universal Extra Dimensions *
189 C S PYUEDC to compute UED mass radiative corrections *
190 C S PYXUED to compute UED cross sections *
191 C S PYGRAM to generate UED G* (excited graviton) mass spectrum *
192 C F PYGRAW to compute UED partial widths to G* *
193 C F PYWDKK to compute UED differential partial widths to G* *
194 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
195 C S PYCMQR auxiliary to PYEICG *
196 C S PYCMQ2 auxiliary to PYEICG *
197 C S PYCDIV auxiliary to PYCMQR *
198 C S PYCSRT auxiliary to PYCMQR *
199 C S PYTHAG auxiliary to PYCMQR *
200 C S PYCBAL auxiliary to PYEICG *
201 C S PYCBA2 auxiliary to PYEICG *
202 C S PYCRTH auxiliary to PYEICG *
203 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
204 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
205 C S PYWIDX to calculate decay widths from within PYWIDT *
206 C S PYRVSF to calculate R-violating sfermion decay widths *
207 C S PYRVNE to calculate R-violating neutralino decay widths *
208 C S PYRVCH to calculate R-violating chargino decay widths *
209 C S PYRVGL to calculate R-violating gluino decay widths *
210 C F PYRVSB auxiliary to PYRVSF *
211 C S PYRVGW to calculate R-Violating 3-body widths *
212 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
213 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
214 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
215 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
216 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
217 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
218 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
219 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
220 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
222 C S PY1ENT to fill one entry (= parton or particle) *
223 C S PY2ENT to fill two entries *
224 C S PY3ENT to fill three entries *
225 C S PY4ENT to fill four entries *
226 C S PY2FRM to interface to generic two-fermion generator *
227 C S PY4FRM to interface to generic four-fermion generator *
228 C S PY6FRM to interface to generic six-fermion generator *
229 C S PY4JET to generate a shower from a given 4-parton config *
230 C S PY4JTW to evaluate the weight od a shower history for above *
231 C S PY4JTS to set up the parton configuration for above *
232 C S PYJOIN to connect entries with colour flow information *
233 C S PYGIVE to fill (or query) commonblock variables *
234 C S PYONOF to allow easy control of particle decay modes *
235 C S PYTUNE to select a predefined 'tune' for min-bias and UE *
236 C S PYEXEC to administrate fragmentation and decay chain *
237 C S PYPREP to rearrange showered partons along strings *
238 C S PYSTRF to do string fragmentation of jet system *
239 C S PYJURF to find boost to string junction rest frame *
240 C S PYINDF to do independent fragmentation of one or many jets *
241 C S PYDECY to do the decay of a particle *
242 C S PYDCYK to select parton and hadron flavours in decays *
243 C S PYKFDI to select parton and hadron flavours in fragm *
244 C S PYNMES to select number of popcorn mesons *
245 C S PYKFIN to calculate falvour prod. ratios from input params. *
246 C S PYPTDI to select transverse momenta in fragm *
247 C S PYZDIS to select longitudinal scaling variable in fragm *
248 C S PYSHOW to do m-ordered timelike parton shower evolution *
249 C S PYPTFS to do pT-ordered timelike parton shower evolution *
250 C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
251 C S PYBOEI to include Bose-Einstein effects (crudely) *
252 C S PYBESQ auxiliary to PYBOEI *
253 C F PYMASS to give the mass of a particle or parton *
254 C F PYMRUN to give the running MSbar mass of a quark *
255 C S PYNAME to give the name of a particle or parton *
256 C F PYCHGE to give three times the electric charge *
257 C F PYCOMP to compress standard KF flavour code to internal KC *
258 C S PYERRM to write error messages and abort faulty run *
259 C F PYALEM to give the alpha_electromagnetic value *
260 C F PYALPS to give the alpha_strong value *
261 C F PYANGL to give the angle from known x and y components *
262 C F PYR to provide a random number generator *
263 C S PYRGET to save the state of the random number generator *
264 C S PYRSET to set the state of the random number generator *
265 C S PYROBO to rotate and/or boost an event *
266 C S PYEDIT to remove unwanted entries from record *
267 C S PYLIST to list event record or particle data *
268 C S PYLOGO to write a logo *
269 C S PYUPDA to update particle data *
270 C F PYK to provide integer-valued event information *
271 C F PYP to provide real-valued event information *
272 C S PYSPHE to perform sphericity analysis *
273 C S PYTHRU to perform thrust analysis *
274 C S PYCLUS to perform three-dimensional cluster analysis *
275 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
276 C S PYJMAS to give high and low jet mass of event *
277 C S PYFOWO to give Fox-Wolfram moments *
278 C S PYTABU to analyze events, with tabular output *
280 C S PYEEVT to administrate the generation of an e+e- event *
281 C S PYXTEE to give the total cross-section at given CM energy *
282 C S PYRADK to generate initial state photon radiation *
283 C S PYXKFL to select flavour of primary qqbar pair *
284 C S PYXJET to select (matrix element) jet multiplicity *
285 C S PYX3JT to select kinematics of three-jet event *
286 C S PYX4JT to select kinematics of four-jet event *
287 C S PYXDIF to select angular orientation of event *
288 C S PYONIA to perform generation of onium decay to gluons *
290 C S PYBOOK to book a histogram *
291 C S PYFILL to fill an entry in a histogram *
292 C S PYFACT to multiply histogram contents by a factor *
293 C S PYOPER to perform operations between histograms *
294 C S PYHIST to print and reset all histograms *
295 C S PYPLOT to print a single histogram *
296 C S PYNULL to reset contents of a single histogram *
297 C S PYDUMP to dump histogram contents onto a file *
299 C S PYSTOP routine to handle Fortran STOP condition *
301 C S PYKCUT dummy routine for user kinematical cuts *
302 C S PYEVWT dummy routine for weighting events *
303 C S UPINIT dummy routine to initialize user processes *
304 C S UPEVNT dummy routine to generate a user process event *
305 C S UPVETO dummy routine to abort event at parton level *
306 C S PDFSET dummy routine to be removed when using PDFLIB *
307 C S STRUCTM dummy routine to be removed when using PDFLIB *
308 C S STRUCTP dummy routine to be removed when using PDFLIB *
309 C S SUGRA dummy routine to be removed when linking with ISAJET *
310 C F VISAJE dummy functn. to be removed when linking with ISAJET *
311 C S SSMSSM dummy routine to be removed when linking with ISAJET *
312 C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
313 C S FHSETPARA dummy routine -"- FEYNHIGGS *
314 C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
315 C S PYTAUD dummy routine for interface to tau decay libraries *
316 C S PYTIME dummy routine for giving date and time *
318 C*********************************************************************
321 C...Default values for switches and parameters,
322 C...and particle, decay and process data.
326 C...Double precision and integer declarations.
327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
328 IMPLICIT INTEGER(I-N)
329 INTEGER PYK,PYCHGE,PYCOMP
331 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
332 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
333 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
334 COMMON/PYDAT4/CHAF(500,2)
336 COMMON/PYDATR/MRPY(6),RRPY(100)
337 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
338 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
339 COMMON/PYINT1/MINT(400),VINT(400)
340 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
341 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
342 COMMON/PYINT4/MWID(500),WIDS(500,5)
343 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
344 COMMON/PYINT6/PROC(0:500)
346 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
347 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
348 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
349 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
350 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
351 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
352 COMMON/PYPUED/IUED(0:99),RUED(0:99)
353 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
354 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
355 & AU(3,3),AD(3,3),AE(3,3)
356 COMMON/PYLH3C/CPRO(2),CVER(2)
357 CHARACTER CPRO*12,CVER*12
358 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
359 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
360 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
361 &/PYBINS/,/PYLH3P/,/PYLH3C/
363 C...PYDAT1, containing status codes and most parameters.
365 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
366 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
367 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
368 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
369 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
370 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
371 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
373 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
374 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
376 DATA (PARU(I),I=1,100)/
377 & 3.141592653589793D0, 6.283185307179586D0,
378 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
379 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
380 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
381 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
382 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
383 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
384 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
386 DATA (PARU(I),I=101,200)/
387 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
388 & 0D0, 0D0, 0D0, 0D0, 0D0,
389 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
390 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
391 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
392 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
393 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
394 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
395 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
396 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
397 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
398 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
400 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
401 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
402 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
403 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
404 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
405 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
407 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
408 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
411 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
412 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
413 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
414 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
415 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
416 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
417 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
418 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
419 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
420 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
421 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
422 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
423 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
424 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
425 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
426 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
427 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
431 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
432 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
433 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
434 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
437 C...PYDAT2, with particle data and flavour treatment parameters.
438 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
439 &-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,
440 &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,
441 &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,
442 &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,
443 &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,
444 &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,
445 &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,
446 &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,
448 C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
449 &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2,
450 &3*-3,0,-3,0,-3,0,-3,
453 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
454 &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,
455 &-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,
456 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
457 &83*0,12*1,9*0,2,3*0,25*0/
458 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
459 &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,
460 &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,
461 &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,
462 &81*0,21*1,3*0,1,25*0/
463 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
464 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
465 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
466 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
467 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
468 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
469 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
470 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
471 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
472 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
473 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
474 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
475 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
476 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
477 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
478 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
479 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
480 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
481 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
482 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
483 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
484 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
485 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
486 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
487 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
488 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
489 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
490 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
491 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
492 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
495 C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
496 &6100001,6100002,6100003,6100004,6100005,6100006,
497 &5100001,5100002,5100003,5100004,5100005,5100006,
498 &6100011,6100013,6100015,
499 &5100012,5100011,5100014,5100013,5100016,5100015,
500 &5100021,5100022,5100023,5100024,
502 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
503 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
504 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
505 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
506 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
507 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
508 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
509 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
510 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
511 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
512 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
513 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
514 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
515 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
516 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
517 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
518 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
519 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
520 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
521 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
522 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
523 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
524 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
525 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
526 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
527 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
528 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
529 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
530 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
531 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
532 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
533 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
534 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
538 &586.,588.,586.,588.,586.,586.,6*598.,
539 &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/
540 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
541 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
542 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
543 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
544 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
545 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
546 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
547 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
548 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
549 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
550 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
551 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
552 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
553 &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
554 &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
555 &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
556 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
557 &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
558 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
559 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
560 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
561 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
562 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
563 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
564 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
565 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
566 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
567 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
568 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
569 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
570 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
571 &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
572 &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
573 &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
574 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
575 &8.80013D0,13*0D0,2.54987D0,2.84456D0,
578 &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/
579 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
580 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
581 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
582 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
583 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
584 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
585 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
586 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
589 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
590 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
591 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
592 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
593 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
594 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
595 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
596 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
597 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
598 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
599 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
600 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
601 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
603 4 0.2D0, 0.5D0, 8*0D0,
605 DATA ((VCKM(I,J),J=1,4),I=1,4)/
606 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
607 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
608 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
609 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
611 C...PYDAT3, with particle decay parameters and data.
612 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
613 &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,
614 &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,
615 &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,
618 &5*1,0,5*1,0,13*1,25*0/
619 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
620 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
621 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
622 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
623 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
624 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
625 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
626 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
627 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
628 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
629 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
630 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
631 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
632 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
633 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
634 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
635 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
636 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
637 &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
638 &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
639 DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
640 &4214,4215,4216,4296,4322,
643 %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
645 &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
647 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
648 &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,
649 &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,
650 &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,
651 &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,
652 &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,
653 &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,
654 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
655 &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,
656 &3*22,15,12,2*7,7*0,6*1,26,30,
659 &6*2,6*3,9*1,24,1,18,6,25*0/
660 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
661 &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,
662 &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,
663 &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,
664 &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,
665 &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
666 &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,
667 &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,
671 &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
673 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
674 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
675 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
676 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
677 &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,
678 &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,
679 &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,
680 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
681 &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,
682 &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,
683 &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,
684 &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,
685 &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,
686 &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,
687 &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
690 &653*0,30*0,9*0,12*0,37*0,2912*0/
691 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
692 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
693 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
694 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
695 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
696 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
697 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
698 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
699 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
700 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
701 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
702 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
703 &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
704 &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
705 &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
706 &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
707 &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
708 &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
709 &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
710 &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
711 DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
712 &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
713 &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
714 &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
715 &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
716 &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
717 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
718 &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
719 &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
720 &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
721 &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
722 &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
723 &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
724 &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
725 &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
726 &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
727 &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
728 &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
729 &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
730 &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
731 DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
732 &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
733 &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
734 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
735 &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
736 &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
737 &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
738 &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
739 &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
740 &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
741 &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
742 &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
743 &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
744 &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
745 &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
746 &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
747 &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
748 &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
749 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
750 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
751 DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
752 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
753 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
754 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
755 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
756 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
757 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
758 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
759 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
760 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
761 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
762 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
763 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
764 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
765 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
766 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
767 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
768 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
769 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
770 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
771 DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
772 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
773 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
774 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
775 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
776 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
777 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
778 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
779 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
780 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
781 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
782 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
783 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
784 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
785 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
786 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
787 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
788 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
789 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
790 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
791 DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
792 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
793 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
794 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
795 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
796 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
797 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
798 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
799 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
800 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
801 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
802 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
803 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
804 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,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 DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
812 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
813 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
814 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
815 &0.015D0,0.005D0,2*0.105D0,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,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
820 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
821 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
822 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
823 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
824 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
825 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
826 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
827 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
828 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
829 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
830 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
831 DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
832 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
833 &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
834 &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
835 &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
836 &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
837 &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
838 &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
839 &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
840 &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
841 &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
842 &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
843 &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
844 &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
845 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
846 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
847 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
848 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
849 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
850 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
851 DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
852 &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
853 &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
854 &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
855 &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
856 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
857 &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
858 &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
859 &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
860 &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
861 &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
862 &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
863 &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
864 &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
865 &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
866 &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
867 &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
868 &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
869 &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
870 &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
871 DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
872 &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
873 &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
874 &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
875 &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
876 &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
877 &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
878 &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
879 &2*0.011947D0,0.011946D0,0D0,
882 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
883 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
884 &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,
885 &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0,
893 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
894 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
895 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
896 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
897 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
898 &-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,
899 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
900 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
901 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
902 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
903 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
904 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
905 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
906 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
907 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
908 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
909 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
910 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
911 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
912 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
913 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
914 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
915 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
916 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
917 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
918 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
919 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
920 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
921 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
922 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
923 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
924 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
925 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
926 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
927 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
928 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
929 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
930 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
931 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
932 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
933 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
934 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
935 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
936 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
937 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
938 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
939 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
940 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
941 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
942 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
943 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
944 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
945 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
946 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
947 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
948 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
949 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
950 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
951 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
952 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
953 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
954 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
955 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
956 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
957 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
958 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
959 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
960 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
961 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
962 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
963 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
964 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
965 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
966 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
967 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
968 &2*-2,2*-4,-2,-4,-12,-14,-16,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,-12,-14,-16,2*-2,2*-4,-2,
970 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
971 &-14,-16,2*-2,2*-4,-2,-4,-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 DATA (KFDP(I,1),I=1403,1713)/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,221,223,221,
976 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
977 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
978 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
979 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
980 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
981 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
982 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
983 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
984 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
985 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
986 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
987 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
988 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
989 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
990 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
991 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
992 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
993 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
994 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
995 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
996 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
997 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
998 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
999 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1000 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
1001 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1002 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
1003 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1004 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
1005 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1006 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
1007 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1008 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
1009 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
1010 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
1011 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
1012 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
1013 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
1014 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1015 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
1016 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1017 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
1018 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
1019 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
1020 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
1021 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
1022 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
1023 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
1024 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
1025 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
1026 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
1027 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
1028 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
1029 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
1030 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
1031 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
1032 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
1033 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1034 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1035 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
1036 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
1037 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
1038 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
1039 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1040 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1041 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1042 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1043 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1044 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1045 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1046 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1047 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1048 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1049 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1050 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1051 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1052 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
1053 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1054 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1055 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1056 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1057 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1058 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1059 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1060 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1061 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1062 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1063 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1064 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1065 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1066 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1067 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1068 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1069 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1070 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1071 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1072 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1073 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1074 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1075 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1076 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1077 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1078 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1079 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1080 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1081 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1082 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1083 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1084 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1085 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1086 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1087 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1088 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1089 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1090 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1091 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1092 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1093 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1094 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1095 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1096 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1097 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1098 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1099 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1100 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1101 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1102 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1103 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1104 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1105 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1106 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1107 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1108 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1109 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1110 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1111 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1112 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1113 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1114 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1115 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1116 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1117 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1118 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1119 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1120 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1121 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1122 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1123 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1124 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1125 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1126 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1127 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1128 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1129 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1130 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1131 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1132 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1133 DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
1134 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1135 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1136 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1137 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1138 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1139 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1140 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1141 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1142 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1143 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1144 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1145 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1146 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1147 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1148 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1149 &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,
1150 &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1151 &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1152 &21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
1154 DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11,
1155 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1156 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1157 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1158 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1159 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1160 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1161 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1165 &5100023,5100022,5100023,5100022,5100023,5100022,
1166 &5100023,5100022,5100023,5100022,5100023,5100022,
1167 &5100023,-5100024,5100022,5100023,5100024,5100022,
1168 &5100023,-5100024,5100022,5100023,5100024,5100022,
1169 &5100023,-5100024,5100022,5100023,5100024,5100022,
1171 &6100001,6100002,6100003,6100004,6100005,6100006,
1172 &5100001,5100002,5100003,5100004,5100005,5100006,
1173 &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1174 &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
1176 &6100011,6100013,6100015,
1177 &5100011,5100013,5100015,
1178 %5100012,5100014,5100016,
1179 &-6100011,-6100013,-6100015,
1180 &-5100011,-5100013,-5100015,
1181 %-5100012,-5100014,-5100016,
1182 &-5100011,-5100013,-5100015,
1183 &5100012,5100014,5100016,
1185 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,
1186 &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,
1187 &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,
1188 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1189 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1190 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1191 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1192 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1193 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1194 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1195 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1196 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1197 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1198 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1199 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1200 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1201 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1202 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1203 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1204 &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/
1205 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1206 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1207 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1208 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1209 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1210 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1211 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1212 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1213 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1214 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1215 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1216 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1217 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1218 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1219 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1220 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1221 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1222 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1223 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1224 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1225 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1226 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1227 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1228 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1229 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1230 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1231 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1232 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1233 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1234 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1235 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1236 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1237 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1238 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1239 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1240 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1241 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1242 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1243 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1244 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1245 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1246 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1247 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1248 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1249 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1250 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1251 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1252 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1253 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1254 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1255 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1256 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1257 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1258 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1259 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1260 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1261 &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,
1262 &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,
1263 &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,
1264 &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/
1265 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1266 &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,
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 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1270 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1271 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1272 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1273 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1274 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1275 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1276 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1277 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1278 &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,
1279 &-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,
1280 &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,
1281 &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,
1282 &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,
1283 &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,
1284 &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/
1285 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1286 &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,
1287 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1288 &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,
1289 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1290 &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,
1291 &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,
1292 &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,
1293 &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,
1294 &-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,
1295 &-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,
1296 &-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,
1297 &-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,
1298 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1299 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1300 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1301 &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,
1302 &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,
1303 &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,
1304 &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/
1305 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1306 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1307 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1308 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1309 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1310 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1311 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1312 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1313 &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,
1314 &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,
1315 &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,
1316 &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,
1317 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1318 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1319 &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,
1320 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1321 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1322 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1323 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1324 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1325 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1326 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1327 &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,
1328 &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,
1329 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1330 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1331 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1332 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1333 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1334 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1335 &-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,
1336 &-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,
1337 &-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,
1338 &-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,
1339 &-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,
1340 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1341 &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,
1342 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1343 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1344 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1345 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1346 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1347 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1348 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1349 &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,
1350 &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,
1351 &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,
1352 &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,
1353 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1354 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1355 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1356 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1357 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1358 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1359 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1360 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1361 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1362 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1363 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1364 &-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/
1365 DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1366 &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,
1367 &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,
1368 &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,
1369 &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,
1370 &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,
1371 &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,
1372 &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,
1373 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1374 &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,
1375 &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,
1376 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1377 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1378 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1379 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1380 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1381 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1382 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3,
1383 &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,
1384 &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1385 DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1386 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1387 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1388 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1389 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1390 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1391 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1392 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1393 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1394 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1395 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1398 &1,1,2,2,3,3,4,4,5,5,6,6,
1399 &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1400 &11,13,15,12,11,14,13,16,15,
1401 &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1402 &1,2,3,4,5,6,1,2,3,4,5,6,
1404 &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1405 &11,13,15,11,13,15,12,14,16,
1406 &12,14,16,-11,-13,-15,
1408 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1409 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1410 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1411 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1412 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1413 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1414 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1415 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1416 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1417 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1418 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1419 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1420 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1421 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1422 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1423 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1424 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1425 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1426 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1427 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1428 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1429 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1430 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1431 &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,
1432 &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,
1433 &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,
1434 &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,
1435 &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,
1436 &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,
1437 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1438 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1439 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1440 &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,
1441 &-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,
1442 &-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,
1443 &-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,
1444 &-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,
1445 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1446 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1447 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1448 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1449 &-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,
1450 &-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,
1451 &-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,
1452 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1453 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1454 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1455 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1456 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1457 &-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,
1458 &-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,
1459 &-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,
1460 &-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,
1461 &-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,
1462 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1463 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1464 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1465 &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,
1466 &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,
1467 &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/
1468 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1469 &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,
1470 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1471 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1472 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1473 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1474 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1475 &-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,
1476 &-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,
1477 &-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,
1478 &-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,
1479 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1480 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1481 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1482 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1483 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1484 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1485 &-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,
1486 &-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,
1487 &-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/
1488 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1489 &-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,
1490 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1491 &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,
1492 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1493 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1494 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1495 &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,
1496 &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,
1497 &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,
1498 &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,
1499 &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,
1500 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1501 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1502 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1503 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1504 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1505 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1506 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1507 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1508 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1509 &-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,
1510 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1511 &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,
1512 &162*81,31*0,-211,111,6516*0/
1513 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1514 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1515 &3*111,-211,111,7193*0/
1517 C...PYDAT4, with particle names (character strings).
1518 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1519 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1520 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1521 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1522 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1523 &'junction',' ','system','cluster','string','indep.','CMshower',
1524 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1525 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1526 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1527 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1528 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1529 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1530 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1531 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1532 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1533 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1534 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1535 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1536 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1537 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1538 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1539 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1540 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1541 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1542 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1543 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1544 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1545 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1546 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1547 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1548 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1549 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1550 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1551 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1552 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1553 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1554 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1555 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1556 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1557 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1558 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1559 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1560 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1561 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1562 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1563 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1564 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1567 &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1568 &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1569 &'e*_S-','mu*_S-','tau*_S-',
1570 &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1571 &'g*','gamma*','Z*0','W*+',25*' '/
1572 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1573 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1574 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1575 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1576 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1577 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1578 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1579 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1580 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1581 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1582 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1583 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1584 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1585 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1586 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1587 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1588 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1589 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1590 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1591 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1592 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1593 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1594 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1595 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1596 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1597 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1598 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1599 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1600 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1601 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1602 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1603 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1604 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1605 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1606 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1607 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1608 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1609 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1610 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1611 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1612 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1613 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1614 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1615 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1618 &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1619 &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1620 &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1621 &'nu*_eDbar','e*_Dbar+',
1622 &'nu*_muDbar','mu*_Dbar+',
1623 &'nu*_tauDbar','tau*_Dbar+',
1624 &'g*','gamma*','Z*0','W*-',25*' '/
1626 C...PYDATR, with initial values for the random number generator.
1627 DATA MRPY/19780503,0,0,97,33,0/
1629 C...Default values for allowed processes and kinematics constraints.
1632 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1633 &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,
1636 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1637 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1638 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1639 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1640 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1641 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1642 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1643 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1644 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1645 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1646 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1647 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1648 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1649 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1650 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1651 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1654 C...Default values for main switches and parameters. Reset information.
1655 DATA (MSTP(I),I=1,100)/
1656 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1657 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1658 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1659 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1660 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1661 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1662 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1663 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1664 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1665 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1666 DATA (MSTP(I),I=101,200)/
1667 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1668 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1669 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1670 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1671 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1672 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1673 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1674 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1675 8 6, 425, 2011, 03, 23, 0, 0, 0, 0, 0,
1676 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1677 DATA (PARP(I),I=1,100)/
1678 & 0.25D0, 10D0, 8*0D0,
1679 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1681 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1682 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1684 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1685 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1686 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1687 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0,
1688 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1689 DATA (PARP(I),I=101,200)/
1690 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1691 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1692 2 1.0D0, 0.4D0, 8*0D0,
1694 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1695 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1696 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1697 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1698 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1699 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1701 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1707 C...Constants for the generation of the various processes.
1708 DATA (ISET(I),I=1,100)/
1709 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1710 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1711 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1712 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1713 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1714 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1715 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1716 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1717 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1718 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1719 DATA (ISET(I),I=101,200)/
1720 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1721 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1722 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1723 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1724 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1725 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1726 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1727 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1728 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1729 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1730 DATA (ISET(I),I=201,300)/
1731 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1732 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1733 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1734 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1735 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1736 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1737 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1738 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1739 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1740 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1741 DATA (ISET(I),I=301,500)/
1742 & 2, 9*-2, 9*2, 21*-2,
1743 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1744 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1745 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1746 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1747 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1748 9 1, 1, 2, 2, 2, 5*-2,
1750 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1751 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1752 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1753 7 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1755 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1756 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1757 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1758 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1759 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1760 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1761 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1762 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1763 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1764 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1765 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1766 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1767 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1768 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1769 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1770 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1771 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1772 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1773 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1774 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1775 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1776 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1777 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1778 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1779 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1780 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1781 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1782 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1783 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1784 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1785 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1786 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1787 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1788 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1789 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1790 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1791 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1792 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1793 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1794 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1795 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1796 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1797 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1798 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1799 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1800 & 1000011, 1000011, 2000011, 2000011, 1000011,
1801 & 2000011, 1000013, 1000013, 2000013, 2000013,
1802 & 1000013, 2000013, 1000015, 1000015, 2000015,
1803 & 2000015, 1000015, 2000015, 1000011, 1000012,
1804 1 1000015, 1000016, 2000015, 1000016, 1000012,
1805 1 1000012, 1000016, 1000016, 0, 0,
1806 1 1000022, 1000022, 1000023, 1000023, 1000025,
1807 1 1000025, 1000035, 1000035, 1000022, 1000023,
1808 2 1000022, 1000025, 1000022, 1000035, 1000023,
1809 2 1000025, 1000023, 1000035, 1000025, 1000035,
1810 2 1000024, 1000024, 1000037, 1000037, 1000024,
1811 2 1000037, 1000022, 1000024, 1000023, 1000024,
1812 3 1000025, 1000024, 1000035, 1000024, 1000022,
1813 3 1000037, 1000023, 1000037, 1000025, 1000037,
1814 3 1000035, 1000037, 1000021, 1000022, 1000021,
1815 3 1000023, 1000021, 1000025, 1000021, 1000035/
1816 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1817 4 1000021, 1000024, 1000021, 1000037, 1000021,
1818 4 1000021, 1000021, 1000021, 0, 0,
1819 4 1000002, 1000022, 2000002, 1000022, 1000002,
1820 4 1000023, 2000002, 1000023, 1000002, 1000025,
1821 5 2000002, 1000025, 1000002, 1000035, 2000002,
1822 5 1000035, 1000001, 1000024, 2000005, 1000024,
1823 5 1000001, 1000037, 2000005, 1000037, 1000002,
1824 5 1000021, 2000002, 1000021, 0, 0,
1825 6 1000006, 1000006, 2000006, 2000006, 1000006,
1826 6 2000006, 1000006, 1000006, 2000006, 2000006,
1829 7 1000002, 1000002, 2000002, 2000002, 1000002,
1830 7 2000002, 1000002, 1000002, 2000002, 2000002,
1831 7 1000002, 2000002, 1000002, 1000002, 2000002,
1832 7 2000002, 1000002, 1000002, 2000002, 2000002/
1833 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1834 8 1000005, 1000002, 2000005, 2000002, 1000005,
1835 8 2000002, 1000005, 1000002, 2000005, 2000002,
1836 8 1000005, 2000002, 1000005, 1000005, 2000005,
1837 8 2000005, 1000005, 1000005, 2000005, 2000005,
1838 9 1000005, 1000005, 2000005, 2000005, 1000005,
1839 9 2000005, 1000005, 1000021, 2000005, 1000021,
1840 9 1000005, 2000005, 37, 25, 37,
1841 9 35, 36, 25, 36, 35,
1847 & 5100002, -5100002,
1848 & 5100002, -5100002,
1849 & 5100002, -6100001,
1850 & 5100002, -5100001,
1852 & 5100001, -5100001,
1854 4 9900041, 0, 9900042, 0, 9900041,
1855 4 11, 9900042, 11, 9900041, 13,
1856 4 9900042, 13, 9900041, 15, 9900042,
1857 4 15, 9900041, 9900041, 9900042, 9900042/
1858 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1859 5 9900041, 0, 9900042, 0, 9900023,
1860 5 0, 9900024, 0, 0, 0,
1863 6 24, 24, 24, 3000211, 3000211,
1864 6 3000211, 22, 3000111, 22, 3000221,
1865 6 23, 3000111, 23, 3000221, 24,
1866 6 3000211, 0, 0, 24, 23,
1867 7 24, 3000111, 3000211, 23, 3000211,
1868 7 3000111, 22, 3000211, 23, 3000211,
1869 7 24, 3000111, 24, 3000221, 22,
1870 7 24, 22, 23, 23, 23,
1871 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1872 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1873 9 5000039, 0, 5000039, 0, 21,
1874 9 5000039, 0, 5000039, 21, 5000039,
1876 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1877 & 37, 6, 37, 6, 36*0,
1878 2 443, 21, 9900443, 21, 9900441,
1879 2 21, 9910441, 21, 0, 9900443,
1880 2 0, 9900441, 0, 9910441, 21,
1881 2 9900443, 21, 9900441, 21, 9910441,
1882 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1883 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1884 6 553, 21, 9900553, 21, 9900551,
1885 6 21, 9910551, 21, 0, 9900553,
1886 6 0, 9900551, 0, 9910551, 21,
1887 6 9900553, 21, 9900551, 21, 9910551,
1888 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1889 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1890 DATA COEF/10000*0D0/
1891 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1892 &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,
1893 &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,
1894 &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,
1895 &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,
1896 &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,
1897 &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,
1898 &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,
1899 &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,
1900 &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,
1901 &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/
1903 C...Treatment of resonances.
1904 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1905 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1906 &81*0,21*1,4*1,25*0/
1908 C...Character constants: name of processes.
1909 DATA PROC(0)/ 'All included subprocesses '/
1910 DATA (PROC(I),I=1,20)/
1911 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1912 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1913 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1914 &' ', 'W+ + W- -> h0 ',
1915 &' ', 'f + f'' -> f + f'' (QFD) ',
1916 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1917 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1918 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1919 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1920 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1921 DATA (PROC(I),I=21,40)/
1922 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1923 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1924 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1925 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1926 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1927 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1928 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1929 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1930 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1931 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1932 DATA (PROC(I),I=41,60)/
1933 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1934 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1935 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1936 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1937 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1938 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1939 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1940 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1941 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1942 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1943 DATA (PROC(I),I=61,80)/
1944 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1945 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1946 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1947 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1948 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1949 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1950 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1951 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1952 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1953 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1954 DATA (PROC(I),I=81,100)/
1955 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1956 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1957 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1958 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1959 8'g + g -> chi_2c + g ', ' ',
1960 9'Elastic scattering ', 'Single diffractive (XB) ',
1961 9'Single diffractive (AX) ', 'Double diffractive ',
1962 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1964 9'q + gamma* -> q ', ' '/
1965 DATA (PROC(I),I=101,120)/
1966 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1967 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1968 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1969 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1970 &' ', 'f + fbar -> gamma + h0 ',
1971 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1972 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1973 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1974 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1976 DATA (PROC(I),I=121,140)/
1977 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1978 2'f + f'' -> f + f'' + h0 ',
1979 2'f + f'' -> f" + f"'' + h0 ',
1983 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1984 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1985 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1986 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1987 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1988 DATA (PROC(I),I=141,160)/
1989 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1990 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1991 4'q + l -> LQ ', 'e + gamma -> e* ',
1992 4'd + g -> d* ', 'u + g -> u* ',
1993 4'g + g -> eta_tc ', ' ',
1994 5'f + fbar -> H0 ', 'g + g -> H0 ',
1995 5'gamma + gamma -> H0 ', ' ',
1996 5' ', 'f + fbar -> A0 ',
1997 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1999 DATA (PROC(I),I=161,180)/
2000 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
2001 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
2002 6'f + fbar -> f'' + fbar'' (g/Z)',
2003 6'f +fbar'' -> f" + fbar"'' (W) ',
2004 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
2005 6'q + qbar -> e + e* ', ' ',
2006 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
2007 7'f + f'' -> f + f'' + H0 ',
2008 7'f + f'' -> f" + f"'' + H0 ',
2009 7' ', 'f + fbar -> Z0 + A0 ',
2010 7'f + fbar'' -> W+/- + A0 ',
2011 7'f + f'' -> f + f'' + A0 ',
2012 7'f + f'' -> f" + f"'' + A0 ',
2014 DATA (PROC(I),I=181,200)/
2015 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
2016 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
2017 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
2018 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
2019 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
2020 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
2021 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
2022 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
2025 DATA (PROC(I),I=201,220)/
2026 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
2027 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
2028 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
2029 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
2030 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
2031 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2032 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
2033 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
2034 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
2035 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
2036 DATA (PROC(I),I=221,240)/
2037 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2038 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2039 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2040 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2041 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2042 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2043 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2044 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2045 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
2046 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
2047 DATA (PROC(I),I=241,260)/
2048 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
2049 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
2050 4' ', 'qj + g -> ~qj_L + ~chi1 ',
2051 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
2052 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
2053 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
2054 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
2055 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
2056 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
2057 5'qj + g -> ~qj_R + ~g ', ' '/
2058 DATA (PROC(I),I=261,300)/
2059 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
2060 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
2061 6'g + g -> ~t_2 + ~t_2bar ', ' ',
2064 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
2065 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
2066 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
2067 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
2068 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
2069 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
2070 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
2071 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
2072 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
2073 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
2074 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
2075 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
2076 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
2077 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
2078 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
2079 DATA (PROC(I),I=301,340)/
2080 &'f + fbar -> H+ + H- ',
2081 &9*' ', 'g + g -> g* + g* ',
2082 &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
2083 &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
2084 &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
2085 &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
2087 DATA (PROC(I),I=341,380)/
2088 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
2089 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
2090 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
2091 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
2092 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
2093 5'f + f -> f'' + f'' + H_L++/-- ',
2094 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
2095 5'f + fbar'' -> W_R+/- ',5*' ',
2096 6' ', 'f + fbar -> W_L+ W_L- ',
2097 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
2098 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
2099 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
2100 6'f + fbar -> W+/- pi_T-/+ ', ' ',
2101 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
2102 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
2103 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
2104 7'f + fbar'' -> W+/- pi_T0 ',
2105 7'f + fbar'' -> W+/- pi_T0'' ',
2106 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2107 7'f + fbar -> Z0 Z0 (ETC) '/
2108 DATA (PROC(I),I=381,420)/
2109 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
2110 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
2111 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
2112 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
2114 9'f + fbar -> G* ', 'g + g -> G* ',
2115 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
2116 9'g + g -> g + G* ', ' ',
2118 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
2120 DATA (PROC(I),I=421,460)/
2121 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2122 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2123 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2124 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2125 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2126 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2127 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2128 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2129 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2130 3'q + q~ -> g + cc~[3P2(1)] ',
2132 DATA (PROC(I),I=461,500)/
2133 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2134 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2135 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2136 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2137 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2138 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2139 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2140 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2141 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2142 7'q + q~ -> g + bb~[3P2(1)] ',
2145 C...Cross sections and slope offsets.
2148 C...Supersymmetry switches and parameters.
2150 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2153 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2154 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2155 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2159 C...Initial values for R-violating SUSY couplings.
2160 C...Should not be changed here. See PYMSIN.
2165 C...Technicolor switches and parameters
2167 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2170 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2171 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2172 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2173 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2174 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2177 C...UED switches and parameters.
2178 C... IUED(0) empty IUED vector element
2179 C... IUED(1) UED ON(=1)/OFF(=0) switch
2180 C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2181 C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2182 C... IUED(4) N the number of large extra dimensions
2183 C... IUED(5) Selects whether the code takes Lambda (=0)
2184 C... or Lambda*R (=1) as input.
2185 C... IUED(6) With radiative corrections to the masses (=1)
2186 C... or without (=0)
2188 C... RUED(0) empty RUED vector element
2189 C... RUED(1) RINV (1/R) the curvature of the extra dimension
2190 C... RUED(2) XMD the (4+N)-dimensional Planck scale
2191 C... RUED(3) LAMUED (Lambda cutoff scale)
2192 C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2194 DATA IUED/0,0,0,5,6,0,1,93*0/
2195 DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
2197 C...Data for histogramming routines.
2198 DATA IHIST/1000,20000,55,1/
2201 C...Data for SUSY Les Houches Accord.
2202 DATA CPRO/'PYTHIA ','PYTHIA '/
2203 DATA CVER/'6.4 ','6.4 '/
2205 DATA PARMIN/100*0D0/
2206 DATA RMSOFT/101*0D0/
2213 C*********************************************************************
2216 C...Check that BLOCK DATA PYDATA has been loaded.
2217 C...Should not be required, except that some compilers/linkers
2218 C...are pretty buggy in this respect.
2222 C...Double precision and integer declarations.
2223 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2224 IMPLICIT INTEGER(I-N)
2225 INTEGER PYK,PYCHGE,PYCOMP
2227 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2228 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2229 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2230 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2231 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2232 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2233 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2235 C...Check a few variables to see they have been sensibly initialized.
2236 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2237 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2239 C...If not, abort the run right away.
2240 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2241 WRITE(*,*) 'The program execution is stopped now!'
2248 C*********************************************************************
2251 C...A simple program (disguised as subroutine) to run at installation
2252 C...as a check that the program works as intended.
2254 SUBROUTINE PYTEST(MTEST)
2256 C...Double precision and integer declarations.
2257 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2258 IMPLICIT INTEGER(I-N)
2259 INTEGER PYK,PYCHGE,PYCOMP
2261 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2262 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2263 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2264 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2265 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2266 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2267 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2269 DIMENSION PSUM(5),PINI(6),PFIN(6)
2271 C...Save defaults for values that are changed.
2288 C...First part: loop over simple events to be generated.
2289 IF(MTEST.GE.1) CALL PYTABU(20)
2293 C...Reset parameter values. Switch on some nonstandard features.
2308 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2310 C...Ten events each for some single jets configurations.
2314 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2315 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2316 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2317 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2318 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2319 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2321 C...Ten events each for some simple jet systems; string fragmentation.
2322 ELSEIF(IEV.LE.130) THEN
2324 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2325 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2326 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2327 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2328 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2329 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2330 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2331 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2332 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2334 C...Seventy events with independent fragmentation and momentum cons.
2335 ELSEIF(IEV.LE.200) THEN
2337 MSTJ(2)=1+MOD(IEV-131,4)
2338 MSTJ(3)=1+MOD((IEV-131)/4,4)
2339 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2340 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2341 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2342 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2343 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2344 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2346 C...A hundred events with random jets (check invariant mass).
2347 ELSEIF(IEV.LE.300) THEN
2354 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2355 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2356 EJET=5D0+20D0*PYR(0)
2357 THETA=ACOS(2D0*PYR(0)-1D0)
2359 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2360 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2361 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2362 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2364 PSUM(J)=PSUM(J)+P(I,J)
2367 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2368 & (PSUM(5)+PARJ(32))**2) GOTO 100
2370 C...Fifty e+e- continuum events with matrix elements.
2371 ELSEIF(IEV.LE.350) THEN
2375 C...Fifty e+e- continuum event with varying shower options.
2376 ELSEIF(IEV.LE.400) THEN
2377 MSTJ(42)=1+MOD(IEV,2)
2378 MSTJ(43)=1+MOD(IEV/2,4)
2379 MSTJ(44)=MOD(IEV/8,3)
2382 C...Fifty e+e- continuum events with coherent shower.
2383 ELSEIF(IEV.LE.450) THEN
2384 CALL PYEEVT(0,500D0)
2386 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2388 CALL PYONIA(5,9.46D0)
2391 C...Generate event. Find total momentum, energy and charge.
2402 C...Check conservation of energy, momentum and charge;
2403 C...usually exact, but only approximate for single jets.
2406 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2408 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2409 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2410 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2413 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2415 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2417 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2418 & (PFIN(J),J=1,4),PFIN(6)
2420 C...Check that all KF codes are known ones, and that partons/particles
2421 C...satisfy energy-momentum-mass relation. Store particle statistics.
2423 IF(K(I,1).GT.20) GOTO 170
2424 IF(PYCOMP(K(I,2)).EQ.0) THEN
2425 WRITE(MSTU(11),5100) I
2428 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2429 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2431 WRITE(MSTU(11),5200) I
2435 IF(MTEST.GE.1) CALL PYTABU(21)
2437 C...List all erroneous events and some normal ones.
2438 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2439 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2441 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2445 C...Stop execution if too many errors.
2446 IF(MERR.NE.0) NERR=NERR+1
2448 WRITE(MSTU(11),6300)
2454 C...Summarize result of run.
2455 IF(MTEST.GE.1) CALL PYTABU(22)
2457 C...Reset commonblock variables changed during run.
2474 C...Second part: complete events of various kinds.
2475 C...Common initial values. Loop over initiating conditions.
2476 MSTP(122)=MAX(0,MIN(2,MTEST))
2477 MDCY(PYCOMP(111),1)=0
2480 C...Reset process type, kinematics cuts, and the flags used.
2497 C...Prompt photon production at fixed target.
2500 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2504 CALL PYINIT('FIXT','pi+','p',PZSUM)
2506 C...QCD processes at ISR energies.
2507 ELSEIF(IPROC.EQ.2) THEN
2513 CALL PYINIT('CMS','p','p',PESUM)
2515 C...W production + multiple interactions at CERN Collider.
2516 ELSEIF(IPROC.EQ.3) THEN
2525 CALL PYINIT('CMS','p','pbar',PESUM)
2527 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2528 ELSEIF(IPROC.EQ.4) THEN
2540 CALL PYINIT('CMS','p','pbar',PESUM)
2542 C...Higgs production at LHC.
2543 ELSEIF(IPROC.EQ.5) THEN
2555 CALL PYINIT('CMS','p','p',PESUM)
2557 C...Z' production at SSC.
2558 ELSEIF(IPROC.EQ.6) THEN
2567 CALL PYINIT('CMS','p','p',PESUM)
2569 C...W pair production at 1 TeV e+e- collider.
2570 ELSEIF(IPROC.EQ.7) THEN
2577 CALL PYINIT('CMS','e+','e-',PESUM)
2579 C...Deep inelastic scattering at a LEP+LHC ep collider.
2580 ELSEIF(IPROC.EQ.8) THEN
2593 CALL PYINIT('3MOM','p','e-',PESUM)
2596 C...Generate 20 events of each required type.
2600 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2602 C...Check conservation of energy/momentum/flavour.
2613 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2614 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2615 DEVQ=ABS(PFIN(6)-PINI(6))
2616 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2617 & DEVQ.GT.0.1D0) MERR=1
2618 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2619 & (PFIN(J),J=1,4),PFIN(6)
2621 C...Check that all KF codes are known ones, and that partons/particles
2622 C...satisfy energy-momentum-mass relation.
2624 IF(K(I,1).GT.20) GOTO 210
2625 IF(PYCOMP(K(I,2)).EQ.0) THEN
2626 WRITE(MSTU(11),5100) I
2629 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2631 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2632 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2633 WRITE(MSTU(11),5200) I
2638 C...Listing of erroneous events, and first event of each type.
2639 IF(MERR.GE.1) NERR=NERR+1
2641 WRITE(MSTU(11),6300)
2645 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2646 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2651 C...List statistics for each process type.
2652 IF(MTEST.GE.1) CALL PYSTAT(1)
2655 C...Summarize result of run.
2656 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2657 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2659 C...Format statements for output.
2660 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2661 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2662 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2663 &4(1X,F12.5),1X,F8.2)
2664 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2665 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2667 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2668 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2669 6400 FORMAT(5X,'Faulty event follows:')
2670 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2671 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2672 &5X,'This should not have happened!')
2677 C*********************************************************************
2680 C...Converts PYTHIA event record contents to or from
2681 C...the standard event record commonblock.
2683 SUBROUTINE PYHEPC(MCONV)
2685 C...Double precision and integer declarations.
2686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2687 IMPLICIT INTEGER(I-N)
2688 INTEGER PYK,PYCHGE,PYCOMP
2690 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2691 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2692 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2693 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2694 C...HEPEVT commonblock.
2695 PARAMETER (NMXHEP=4000)
2696 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2697 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2698 DOUBLE PRECISION PHEP,VHEP
2701 C...Store HEPEVT commonblock size (for interfacing issues).
2704 C...Initialize variable(s)
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) THEN
2806 IF(K(I,4).GT.0.AND.(K(I,4).EQ.K(I,5)).AND.
2807 $ (K(K(I,4),2).GE.91.AND.K(K(I,4),2).LE.93).AND.
2808 $ (I.LT.N).AND.(K(I,4).EQ.K(I+1,4))) K(I,1)=12
2810 IF(ISTHEP(I).EQ.3) K(I,1)=21
2822 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2824 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2825 & PHEP(5,I)/PHEP(4,I)
2828 C...Fill in missing information on colour connection in jet systems.
2829 IF(ISTHEP(I).EQ.1) THEN
2832 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2833 IF(KQ.NE.0) NKQ=NKQ+1
2834 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2835 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2837 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2838 IF(K(I+1,2).EQ.21) K(I,1)=2
2842 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2843 & '(PYHEPC:) input parton configuration not colour singlet')
2848 C*********************************************************************
2851 C...Initializes the generation procedure; finds maxima of the
2852 C...differential cross-sections to be used for weighting.
2854 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2856 C...Double precision and integer declarations.
2857 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2858 IMPLICIT INTEGER(I-N)
2859 INTEGER PYK,PYCHGE,PYCOMP
2861 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2862 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2863 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2864 COMMON/PYDAT4/CHAF(500,2)
2866 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2867 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2868 COMMON/PYINT1/MINT(400),VINT(400)
2869 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2870 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2871 COMMON/PYPUED/IUED(0:99),RUED(0:99)
2872 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2873 &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/
2874 C...Local arrays and character variables.
2875 DIMENSION ALAMIN(20),NFIN(20)
2876 CHARACTER*(*) FRAME,BEAM,TARGET
2877 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2879 C...Interface to PDFLIB.
2880 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
2881 COMMON/W50512/QCDL4,QCDL5
2882 SAVE /W50511/,/W50512/
2883 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2884 CHARACTER*20 PARM(20)
2885 DATA VALUE/20*0D0/,PARM/20*' '/
2887 C...Data:Lambda and n_f values for parton distributions..
2888 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2889 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2891 DATA CHLH/'lepton','hadron'/
2893 C...Check that BLOCK DATA PYDATA has been loaded.
2896 C...Reset MINT and VINT arrays. Write headers.
2902 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2903 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2905 C...Reset error counters.
2910 C...Reset processes that should not be on.
2914 C...Select global FSR/ISR/UE parameter set = 'tune'
2915 C...See routine PYTUNE for details
2916 IF (MSTP(5).NE.0) THEN
2921 C...Call user process initialization routine.
2922 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2928 C...Maximum 4 generations; set maximum number of allowed flavours.
2929 MSTP(1)=MIN(4,MSTP(1))
2930 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2931 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2933 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2937 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2940 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2941 IPM=(5-ISIGN(1,I))/2
2943 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2944 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2946 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2951 C...Initialize parton distributions: PDFLIB.
2952 IF(MSTP(52).EQ.2) THEN
2956 VALUE(2)=MSTP(51)/1000
2958 VALUE(3)=MOD(MSTP(51),1000)
2961 CALL PDFSET_ALICE(PARM,VALUE)
2962 MINT(93)=1000000+MSTP(51)
2965 C...Choose Lambda value to use in alpha-strong.
2967 IF(MSTP(3).GE.2) THEN
2970 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2971 ALAM=ALAMIN(MSTP(51))
2973 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2976 ELSEIF(MSTP(52).EQ.2) THEN
2985 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2988 C...Initialize the UED masses and widths
2989 IF (IUED(1).EQ.1) CALL PYXDIN
2991 C...Initialize the SUSY generation: couplings, masses,
2992 C...decay modes, branching ratios, and so on.
2994 C...Initialize widths and partial widths for resonances.
2996 C...Set Z0 mass and width for e+e- routines.
2997 PARJ(123)=PMAS(23,1)
2998 PARJ(124)=PMAS(23,2)
3000 C...Identify beam and target particles and frame of process.
3004 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3005 IF(MINT(65).EQ.1) GOTO 170
3007 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3008 C...For e-gamma allow 2 alternatives.
3010 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3011 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3012 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3013 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
3014 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3015 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
3016 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3017 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3018 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3019 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
3020 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3021 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3022 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
3023 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
3024 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3025 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3026 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
3027 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
3030 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
3031 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
3032 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
3033 IF(MSTP(14).EQ.11) MINT(123)=0
3034 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
3035 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
3036 IF(MSTP(14).EQ.15) MINT(123)=2
3037 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
3038 IF(MSTP(14).EQ.19) MINT(123)=3
3039 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
3040 IF(MSTP(14).EQ.21) MINT(123)=0
3041 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
3042 IF(MSTP(14).EQ.24) MINT(123)=1
3043 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
3044 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
3045 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
3048 C...Set up kinematics of process.
3051 C...Set up kinematics for photons inside leptons.
3052 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
3054 C...Precalculate flavour selection weights.
3057 C...Loop over gamma-p or gamma-gamma alternatives.
3060 DO 160 IGA=1,MINT(121)
3064 C...Select partonic subprocesses to be included in the simulation.
3071 C...Count number of subprocesses on.
3074 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3075 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
3077 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3078 & MSUB(ISUB).EQ.1) THEN
3079 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
3081 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
3082 WRITE(MSTU(11),5300) ISUB
3084 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
3085 WRITE(MSTU(11),5400) ISUB
3087 ELSEIF(MSUB(ISUB).EQ.1) THEN
3092 C...Stop or raise warning flag if no subprocesses on.
3093 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
3094 IF(MSTP(127).NE.1) THEN
3095 WRITE(MSTU(11),5500)
3098 WRITE(MSTU(11),5700)
3102 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
3103 MSAV48=MSAV48+MINT(48)
3105 C...Reset variables for cross-section calculation.
3113 C...Find parametrized total cross-sections.
3117 C...Maxima of differential cross-sections.
3118 IF(MSTP(121).LE.1) CALL PYMAXI
3120 C...Initialize possibility of pileup events.
3121 IF(MINT(121).GT.1) MSTP(131)=0
3122 IF(MSTP(131).NE.0) CALL PYPILE(1)
3124 C...Initialize multiple interactions with variable impact parameter.
3125 IF(MINT(50).EQ.1) THEN
3126 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3127 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
3128 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
3129 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
3137 C...Save results for gamma-p and gamma-gamma alternatives.
3138 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
3141 C...Initialization finished.
3142 IF(MSAV48.EQ.0) THEN
3143 IF(MSTP(127).NE.1) THEN
3144 WRITE(MSTU(11),5500)
3147 WRITE(MSTU(11),5700)
3151 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
3153 C...Formats for initialization information.
3154 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3155 &'routines',1X,17('*'))
3156 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3157 &'-',A6,' interactions.'/1X,'Execution stopped!')
3158 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3159 &1X,'Execution stopped!')
3160 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3161 &1X,'Execution stopped!')
3162 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3163 &1X,'Execution stopped.')
3164 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3166 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3167 &1X,'Execution will stop if you try to generate events.')
3172 C*********************************************************************
3175 C...Administers the generation of a high-pT event via calls to
3176 C...a number of subroutines.
3180 C...Double precision and integer declarations.
3181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3182 IMPLICIT INTEGER(I-N)
3183 INTEGER PYK,PYCHGE,PYCOMP
3184 PARAMETER (MAXNUR=1000)
3186 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3187 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3188 COMMON/PYCTAG/NCT,MCT(4000,2)
3189 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3190 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3191 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3192 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3193 COMMON/PYINT1/MINT(400),VINT(400)
3194 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3195 COMMON/PYINT4/MWID(500),WIDS(500,5)
3196 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3197 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3198 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3202 C...Optionally let PYEVNW do the whole job.
3203 IF(MSTP(81).GE.20) THEN
3208 C...Stop if no subprocesses on.
3209 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3210 WRITE(MSTU(11),5100)
3214 C...Initial values for some counters.
3227 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3231 C...Let called routines know call is from PYEVNT (not PYEVNW).
3233 IF (MSTP(81).GE.10) MINT(35)=2
3235 C...If variable energies: redo incoming kinematics and cross-section.
3237 IF(MSTP(171).EQ.1) THEN
3239 IF(MSTI(61).EQ.1) THEN
3243 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3247 C...Loop over number of pileup events; check space left.
3248 IF(MSTP(131).LE.0) THEN
3254 DO 270 IPILE=1,NPILE
3255 IF(MINT(84)+100.GE.MSTU(4)) THEN
3257 & '(PYEVNT:) no more space in PYJETS for pileup events')
3258 IF(MSTU(21).GE.1) GOTO 280
3262 C...Generate variables of hard scattering.
3266 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3272 IF(MSTI(61).EQ.1) THEN
3276 IF(MINT(51).EQ.2) RETURN
3278 IF(MSTP(111).EQ.-1) GOTO 260
3280 C...Loopback point if PYPREP fails, especially for junction topologies.
3286 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3287 C...Hard scattering (including low-pT):
3288 C...reconstruct kinematics and colour flow of hard scattering.
3293 IF(MINT(51).EQ.1) GOTO 100
3296 IF(ISUB.EQ.95) GOTO 140
3298 C...Reset statistics on activity in event.
3304 C...Showering of initial state partons (optional).
3308 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3309 & CALL PYSSPA(IPU1,IPU2)
3311 IF(MINT(51).EQ.1) GOTO 100
3313 C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3314 IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
3315 PTMAX=0.5*SQRT(PARP(71))*VINT(55)
3316 CALL PYPTFS(3,PTMAX,0D0,PTGEN)
3319 C...Showering of final state partons (optional).
3322 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3326 IF(ISET(ISUB).EQ.5) IPU4=-3
3328 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3329 CALL PYSHOW(IPU3,IPU4,QMAX)
3330 ELSEIF(ISET(ISUB).EQ.11) THEN
3335 C...Allow possibility for user to abort event generation.
3337 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3338 IF(IVETO.EQ.1) GOTO 100
3340 C...Decay of final state resonances.
3342 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3343 IF(MINT(51).EQ.1) GOTO 100
3347 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3348 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3349 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3351 IF(MINT(51).EQ.1) GOTO 100
3354 C...Beam remnant flavour and colour assignments - new scheme.
3356 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3358 IF(MINT(51).EQ.1) GOTO 100
3360 C...Primordial kT and beam remnant momentum sharing - new scheme.
3362 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3364 IF(MINT(51).EQ.1) GOTO 100
3365 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3367 C...Multiple interactions - PYTHIA 6.2 style.
3368 ELSEIF(MINT(111).NE.12) THEN
3369 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3374 C...Hadron remnants and primordial kT.
3375 CALL PYREMN(IPU1,IPU2)
3376 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3378 IF(MINT(51).EQ.1) GOTO 100
3381 ELSEIF(ISUB.NE.99) THEN
3382 C...Diffractive and elastic scattering.
3386 C...DIS scattering (photon flux external).
3388 IF(MINT(51).EQ.1) GOTO 100
3391 C...Check that no odd resonance left undecayed.
3393 IF(MSTP(111).GE.1) THEN
3395 DO 150 I=MINT(84)+1,NFIX
3396 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3397 & K(I,2).NE.22) THEN
3399 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3401 IF(MINT(51).EQ.1) GOTO 100
3407 C...Boost hadronic subsystem to overall rest frame.
3408 C..(Only relevant when photon inside lepton beam.)
3409 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3411 C...Recalculate energies from momenta and masses (if desired).
3412 IF(MSTP(113).GE.1) THEN
3413 DO 160 I=MINT(83)+1,N
3414 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3415 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3420 C...Colour reconnection before string formation
3421 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3423 C...Rearrange partons along strings, check invariant mass cuts.
3425 IF(MSTP(111).LE.0) MSTJ(14)=-1
3426 CALL PYPREP(MINT(84)+1)
3428 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3432 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3433 IF (MINT(51).EQ.1) GOTO 100
3434 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3435 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3436 DO 190 I=MINT(84)+1,N
3437 IF(K(I,2).EQ.94) THEN
3438 DO 180 I1=I+1,MIN(N,I+10)
3439 IF(K(I1,3).EQ.I) THEN
3440 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3441 IF(K(I1,3).EQ.0) THEN
3442 DO 170 II=MINT(84)+1,I-1
3443 IF(K(II,2).EQ.K(I1,2)) THEN
3444 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3445 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3448 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3456 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3457 IF(MSTP(125).EQ.0) MINT(4)=0
3458 DO 210 I=MINT(83)+1,N
3459 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3461 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3462 IF(K(I1,3).EQ.I) K(I,5)=I1
3468 C...Introduce separators between sections in PYLIST event listing.
3469 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3472 ELSEIF(IPILE.EQ.1) THEN
3479 C...Go back to lab frame (needed for vertices, also in fragmentation).
3482 C...Set nonvanishing production vertex (optional).
3483 IF(MSTP(151).EQ.1) THEN
3485 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3486 & SIN(PARU(2)*PYR(0))
3488 DO 240 I=MINT(83)+1,N
3490 V(I,J)=V(I,J)+VTX(J)
3495 C...Perform hadronization (if desired).
3496 IF(MSTP(111).GE.1) THEN
3498 IF(MSTU(24).NE.0) GOTO 100
3500 IF(MSTP(113).GE.1) THEN
3502 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3503 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3506 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3508 C...Store event information and calculate Monte Carlo estimates of
3509 C...subprocess cross-sections.
3510 260 IF(IPILE.EQ.1) CALL PYDOCU
3512 C...Set counters for current pileup event and loop to next one.
3514 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3515 IF(MSTU70.LT.10) THEN
3520 MINT(84)=N+MSTP(126)
3521 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3524 C...Generic information on pileup events. Reconstruct missing history.
3525 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3529 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3533 C...Transform to the desired coordinate frame.
3534 280 CALL PYFRAM(MSTP(124))
3539 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3540 &1X,'Execution stopped.')
3545 C*********************************************************************
3548 C...Administers the generation of a high-pT event via calls to
3549 C...a number of subroutines for the new multiple interactions and
3550 C...showering framework.
3554 C...Double precision and integer declarations.
3555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3556 IMPLICIT INTEGER(I-N)
3557 INTEGER PYK,PYCHGE,PYCOMP
3558 PARAMETER (MAXNUR=1000)
3560 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3562 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3563 COMMON/PYCTAG/NCT,MCT(4000,2)
3564 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3565 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3566 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3567 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3568 COMMON/PYINT1/MINT(400),VINT(400)
3569 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3570 COMMON/PYINT4/MWID(500),WIDS(500,5)
3571 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3572 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3573 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3574 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3575 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3576 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3580 C...Stop if no subprocesses on.
3581 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3582 WRITE(MSTU(11),5100)
3586 C...Initial values for some counters.
3599 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3602 C...Zero counters for pT-ordered showers (failsafe)
3606 C...Let called routines know call is from PYEVNW (not PYEVNT).
3609 C...If variable energies: redo incoming kinematics and cross-section.
3611 IF(MSTP(171).EQ.1) THEN
3613 IF(MSTI(61).EQ.1) THEN
3617 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3621 C...Loop over number of pileup events; check space left.
3622 IF(MSTP(131).LE.0) THEN
3628 DO 300 IPILE=1,NPILE
3629 IF(MINT(84)+100.GE.MSTU(4)) THEN
3631 & '(PYEVNW:) no more space in PYJETS for pileup events')
3632 IF(MSTU(21).GE.1) GOTO 310
3636 C...Generate variables of hard scattering.
3642 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3643 IF(LOOPHS.GE.10) THEN
3644 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3645 & //'multiple interactions. Returning.')
3655 IF(MSTI(61).EQ.1) THEN
3659 IF(MINT(51).EQ.2) RETURN
3661 IF(MSTP(111).EQ.-1) GOTO 290
3663 C...Loopback point if PYPREP fails, especially for junction topologies.
3669 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3670 C...Hard scattering (including low-pT):
3671 C...reconstruct kinematics and colour flow of hard scattering.
3676 IF(MINT(51).EQ.1) GOTO 100
3680 C...Intertwined initial state showers and multiple interactions.
3681 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3682 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3684 IF (MINT(47).LT.2) MSTP(61)=0
3686 IF (MINT(50).EQ.0) MSTP(81)=0
3687 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3688 & MINT(111).NE.12) THEN
3689 C...Absolute max pT2 scale for evolution: phase space limit.
3690 PT2MXS=0.25D0*VINT(2)
3691 C...Check if more constrained by ISR and MI max scales:
3692 PT2MXS=MIN(PT2MXS,MAX(MAX(1D0,PARP(67))*VINT(56),VINT(62)))
3693 C...Loopback point in case of failure in evolution.
3697 IF(LOOP.GT.100) THEN
3698 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3699 & //'multiple interactions. Trying new point.')
3704 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3705 C...once per event. (E.g. compute constants and save variables to be
3706 C...restored later in case of failure.)
3707 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3709 C...Initialize interleaved MI/ISR/JI evolution.
3710 C...PT2MAX: absolute upper limit for evolution - Initialization may
3711 C... return a PT2MAX which is lower than this.
3712 C...PT2MIN: absolute lower limit for evolution - Initialization may
3713 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3716 CALL PYEVOL(0,PT2MAX,PT2MIN)
3717 C...If failed to initialize evolution, generate a new hard process
3718 IF (MINT(51).EQ.1) GOTO 100
3720 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3721 C...In principle factorized, so can be stopped and restarted.
3722 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3723 C PT2MED=MAX(10D0**2,PT2MIN)
3724 C CALL PYEVOL(1,PT2MAX,PT2MED)
3725 C IF (MINT(51).EQ.1) GOTO 160
3727 CALL PYEVOL(1,PT2MAX,PT2MIN)
3728 C...If fatal error (e.g., massive hard-process initiator, but no available
3729 C...phase space for creation), generate a new hard process
3730 IF (MINT(51).EQ.2) GOTO 100
3731 C...If smaller error, just try running evolution again
3732 IF (MINT(51).EQ.1) GOTO 130
3734 C...Finalize interleaved MI/ISR/JI evolution.
3735 CALL PYEVOL(2,PT2MAX,PT2MIN)
3736 IF (MINT(51).EQ.1) GOTO 130
3741 IF(MINT(51).EQ.1) GOTO 100
3742 C...(MINT(52) is actually obsolete in this routine. Set anyway
3743 C...to ensure PYDOCU stable.)
3747 C...Beam remnants - new scheme.
3748 140 IF(MINT(50).EQ.1) THEN
3749 IF (ISUB.EQ.95) MINT(31)=1
3751 C...Beam remnant flavour and colour assignments - new scheme.
3753 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3755 IF(MINT(51).EQ.1) GOTO 100
3757 C...Primordial kT and beam remnant momentum sharing - new scheme.
3759 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3761 IF(MINT(51).EQ.1) GOTO 100
3762 IF (ISUB.EQ.95) MINT(31)=0
3763 ELSEIF(MINT(111).NE.12) THEN
3764 C...Hadron remnants and primordial kT - old model.
3765 C...Happens e.g. for direct photon on one side.
3768 CALL PYREMN(IPU1,IPU2)
3769 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3771 IF(MINT(51).EQ.1) GOTO 100
3772 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3773 DO 160 I=MINT(53)+1,N
3775 IDA=MOD(K(I,KCS),MSTU(5))
3777 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3783 C...Instruct PYPREP to use colour tags
3787 DO 350 I=MINT(84)+1,N
3789 C...Look for coloured string endpoint, or (later) leftover gluon.
3790 IF (K(I,1).NE.3) GOTO 350
3792 IF(KC.EQ.0) GOTO 350
3794 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3796 C... Pick up loose string end with no previous tag.
3798 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3799 IF(MCT(I,KCS-3).NE.0) GOTO 350
3801 CALL PYCTTR(I,KCS,I)
3802 IF(MINT(51).NE.0) RETURN
3806 C...Now delete any colour processing information if set (since partons
3807 C...otherwise not FS showered!)
3808 DO 170 I=MINT(84)+1,N
3810 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3811 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3816 C...Showering of final state partons (optional).
3819 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3822 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3823 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3824 C...External processes: handle successive showers.
3825 ELSEIF(ISET(ISUB).EQ.11) THEN
3830 C...Allow possibility for user to abort event generation.
3832 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3834 C...........No reason to count this as an error
3840 C...Decay of final state resonances.
3842 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3844 IF(MINT(51).NE.0) GOTO 100
3847 IF(MINT(51).EQ.1) GOTO 100
3849 ELSEIF(ISUB.NE.99) THEN
3850 C...Diffractive and elastic scattering.
3854 C...DIS scattering (photon flux external).
3856 IF(MINT(51).EQ.1) GOTO 100
3859 C...Check that no odd resonance left undecayed.
3861 IF(MSTP(111).GE.1) THEN
3863 DO 180 I=MINT(84)+1,NFIX
3864 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3865 & K(I,2).NE.22) THEN
3867 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3869 IF(MINT(51).EQ.1) GOTO 100
3875 C...Boost hadronic subsystem to overall rest frame.
3876 C..(Only relevant when photon inside lepton beam.)
3877 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3879 C...Recalculate energies from momenta and masses (if desired).
3880 IF(MSTP(113).GE.1) THEN
3881 DO 190 I=MINT(83)+1,N
3882 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3883 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3888 C...Colour reconnection before string formation
3889 CALL PYFSCR(MINT(84)+1)
3891 C...Rearrange partons along strings, check invariant mass cuts.
3893 IF(MSTP(111).LE.0) MSTJ(14)=-1
3894 CALL PYPREP(MINT(84)+1)
3896 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3900 IF(MINT(51).EQ.1) GOTO 110
3901 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3902 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3903 DO 220 I=MINT(84)+1,N
3904 IF(K(I,2).EQ.94) THEN
3905 DO 210 I1=I+1,MIN(N,I+10)
3906 IF(K(I1,3).EQ.I) THEN
3907 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3908 IF(K(I1,3).EQ.0) THEN
3909 DO 200 II=MINT(84)+1,I-1
3910 IF(K(II,2).EQ.K(I1,2)) THEN
3911 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3912 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3915 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3919 C...Also collapse particles decaying to themselves (if same KS)
3920 C...Sep 22 2009: Commented out by PS following suggestion by TS to fix
3921 C...problem with history point-backs in new shower, where a particle is
3922 C...copied with a new momentum when it is the recoiler.
3923 C ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3924 C & .AND.K(I,4).LT.N) THEN
3926 C IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3933 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3934 IF(MSTP(125).EQ.0) MINT(4)=0
3935 DO 240 I=MINT(83)+1,N
3936 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3938 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3939 IF(K(I1,3).EQ.I) K(I,5)=I1
3945 C...Introduce separators between sections in PYLIST event listing.
3946 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3949 ELSEIF(IPILE.EQ.1) THEN
3956 C...Go back to lab frame (needed for vertices, also in fragmentation).
3959 C...Set nonvanishing production vertex (optional).
3960 IF(MSTP(151).EQ.1) THEN
3962 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3963 & SIN(PARU(2)*PYR(0))
3965 DO 270 I=MINT(83)+1,N
3967 V(I,J)=V(I,J)+VTX(J)
3972 C...Perform hadronization (if desired).
3973 IF(MSTP(111).GE.1) THEN
3975 IF(MSTU(24).NE.0) GOTO 100
3977 IF(MSTP(113).GE.1) THEN
3979 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3980 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3983 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3985 C...Store event information and calculate Monte Carlo estimates of
3986 C...subprocess cross-sections.
3987 290 IF(IPILE.EQ.1) CALL PYDOCU
3989 C...Set counters for current pileup event and loop to next one.
3991 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3992 IF(MSTU70.LT.10) THEN
3997 MINT(84)=N+MSTP(126)
3998 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
4001 C...Generic information on pileup events. Reconstruct missing history.
4002 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
4006 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
4010 C...Transform to the desired coordinate frame.
4011 310 CALL PYFRAM(MSTP(124))
4016 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4017 &1X,'Execution stopped.')
4023 C***********************************************************************
4026 C...Prints out information about cross-sections, decay widths, branching
4027 C...ratios, kinematical limits, status codes and parameter values.
4029 SUBROUTINE PYSTAT(MSTAT)
4031 C...Double precision and integer declarations.
4032 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4033 IMPLICIT INTEGER(I-N)
4034 INTEGER PYK,PYCHGE,PYCOMP
4035 C...Parameter statement to help give large particle numbers.
4036 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4037 &KEXCIT=4000000,KDIMEN=5000000)
4038 PARAMETER (EPS=1D-3)
4040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4041 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4042 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4043 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4044 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4045 COMMON/PYINT1/MINT(400),VINT(400)
4046 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4047 COMMON/PYINT4/MWID(500),WIDS(500,5)
4048 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4049 COMMON/PYINT6/PROC(0:500)
4050 CHARACTER PROC*28, CHTMP*16
4051 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4052 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4053 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4054 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4055 C...Local arrays, character variables and data.
4056 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4057 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4058 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4059 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4060 CHARACTER*24 CHD0, CHDC(10)
4061 CHARACTER*6 DNAME(3)
4063 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4064 &'VMD/hadron * anomalous ','direct * direct ',
4065 &'direct * anomalous ','anomalous * anomalous '/
4066 DATA DISGA/'e * VMD','e * anomalous'/
4068 &'direct * direct ','direct * VMD ',
4069 &'direct * anomalous ','VMD * direct ',
4070 &'VMD * VMD ','VMD * anomalous ',
4071 &'anomalous * direct ','anomalous * VMD ',
4072 &'anomalous * anomalous ','DIS * VMD ',
4073 &'DIS * anomalous ','VMD * DIS ',
4074 &'anomalous * DIS '/
4076 &'direct * direct ','direct * resolved ',
4077 &'resolved * direct ','resolved * resolved '/
4079 &'direct * hadron ','resolved * hadron '/
4081 &'VMD * hadron ','direct * hadron ',
4082 &'anomalous * hadron ','DIS * hadron '/
4083 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4084 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4085 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4086 &' y*_small ',' eta*_large ',' eta*_small ',
4087 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4088 &' x_2 ',' x_F ',' cos(theta_hard) ',
4089 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4090 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4092 DATA DNAME /'q ','lepton','nu '/
4096 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4097 WRITE(MSTU(11),5000)
4098 WRITE(MSTU(11),5100)
4099 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4101 IF(MSUB(I).NE.1) GOTO 100
4102 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4104 IF(MINT(121).GT.1) THEN
4105 WRITE(MSTU(11),5300)
4106 DO 110 IGA=1,MINT(121)
4108 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4109 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4111 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4112 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4114 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4115 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4117 ELSEIF(MINT(121).EQ.4) THEN
4118 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4120 ELSEIF(MINT(121).EQ.2) THEN
4121 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4124 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4130 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4131 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4133 C...Decay widths and branching ratios.
4134 ELSEIF(MSTAT.EQ.2) THEN
4135 WRITE(MSTU(11),5500)
4136 WRITE(MSTU(11),5600)
4139 CALL PYNAME(KF,CHKF)
4142 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4143 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4144 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4145 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4146 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4148 IF(MWID(KC).LE.0) GOTO 140
4149 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4150 & KF/KSUSY1.EQ.2)) GOTO 140
4152 C...Off-shell branchings.
4155 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4156 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4157 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4158 DO 120 J=1,MDCY(KC,3)
4161 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4162 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4164 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4165 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4166 CALL PYNAME(KFDP(IDC,1),CHD1)
4167 CALL PYNAME(KFDP(IDC,2),CHD2)
4168 IF(KFDP(IDC,3).EQ.0) THEN
4169 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4170 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4171 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4173 CALL PYNAME(KFDP(IDC,3),CHD3)
4174 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4175 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4176 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4179 C...On-shell decays.
4181 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4183 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4184 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4185 & STATE(MDCY(KC,1)),BRFIN
4186 DO 130 J=1,MDCY(KC,3)
4189 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4190 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4192 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4193 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4195 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4197 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4198 CALL PYNAME(KFDP(IDC,1),CHD1)
4199 CALL PYNAME(KFDP(IDC,2),CHD2)
4200 IF(KFDP(IDC,3).EQ.0) THEN
4201 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4202 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4203 & CHD2(1:10),WDTP(J),BRPRI,
4204 & STATE(MDME(IDC,1)),BRFIN
4206 CALL PYNAME(KFDP(IDC,3),CHD3)
4207 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4208 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4209 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4210 & STATE(MDME(IDC,1)),BRFIN
4215 WRITE(MSTU(11),6000)
4217 C...Allowed incoming partons/particles at hard interaction.
4218 ELSEIF(MSTAT.EQ.3) THEN
4219 WRITE(MSTU(11),6100)
4220 CALL PYNAME(MINT(11),CHAU)
4222 CALL PYNAME(MINT(12),CHAU)
4224 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4228 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4229 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4231 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4234 WRITE(MSTU(11),6400)
4236 C...User-defined limits on kinematical variables.
4237 ELSEIF(MSTAT.EQ.4) THEN
4238 WRITE(MSTU(11),6500)
4239 WRITE(MSTU(11),6600)
4241 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4242 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4243 PTHMIN=MAX(CKIN(3),CKIN(5))
4245 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4246 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4247 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4249 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4252 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4253 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4254 WRITE(MSTU(11),7000)
4256 C...Status codes and parameter values.
4257 ELSEIF(MSTAT.EQ.5) THEN
4258 WRITE(MSTU(11),7100)
4259 WRITE(MSTU(11),7200)
4261 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4265 C...List of all processes implemented in the program.
4266 ELSEIF(MSTAT.EQ.6) THEN
4267 WRITE(MSTU(11),7400)
4268 WRITE(MSTU(11),7500)
4270 IF(ISET(I).LT.0) GOTO 180
4271 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4273 WRITE(MSTU(11),7700)
4275 ELSEIF(MSTAT.EQ.7) THEN
4276 WRITE (MSTU(11),8000)
4282 KFSUSY=ILR*KSUSY1+KFSM
4285 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4291 CALL PYNAME(KFSUSY,CHTMP)
4293 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4294 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4295 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4297 DO 200 J=1,MDCY(KC,3)
4299 ID1=IABS(KFDP(IDC,1))
4300 ID2=IABS(KFDP(IDC,2))
4301 IF (KFDP(IDC,3).EQ.0) THEN
4302 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4303 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4304 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4305 NMODES(1)=NMODES(1)+1
4306 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4307 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4308 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4309 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4310 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4311 NMODES(2)=NMODES(2)+1
4312 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4313 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4314 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4315 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4316 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4317 NMODES(3)=NMODES(3)+1
4318 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4319 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4325 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4331 CALL PYNAME(KFSUSY,CHTMP)
4333 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4334 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4336 DO 220 J=1,MDCY(KC,3)
4338 ID1=IABS(KFDP(IDC,1))
4339 ID2=IABS(KFDP(IDC,2))
4340 IF (KFDP(IDC,3).EQ.0) THEN
4341 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4342 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4343 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4344 NMODES(1)=NMODES(1)+1
4345 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4346 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4347 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4348 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4349 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4350 NMODES(2)=NMODES(2)+1
4351 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4352 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4358 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4364 CALL PYNAME(KFSUSY,CHTMP)
4366 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4367 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4369 DO 240 J=1,MDCY(KC,3)
4371 ID1=IABS(KFDP(IDC,1))
4372 ID2=IABS(KFDP(IDC,2))
4373 IF (KFDP(IDC,3).EQ.0) THEN
4374 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4375 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4376 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4377 NMODES(1)=NMODES(1)+1
4378 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4379 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4381 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4382 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4383 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4384 NMODES(2)=NMODES(2)+1
4385 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4386 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4391 C...SNEUTRINO DECAYS
4392 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4399 CALL PYNAME(KFSUSY,CHTMP)
4401 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4402 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4404 DO 260 J=1,MDCY(KC,3)
4406 ID1=IABS(KFDP(IDC,1))
4407 ID2=IABS(KFDP(IDC,2))
4408 IF (KFDP(IDC,3).EQ.0) THEN
4409 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4410 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4411 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4412 NMODES(1)=NMODES(1)+1
4413 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4414 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4416 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4417 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4418 NMODES(2)=NMODES(2)+1
4419 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4420 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4421 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4426 IF (NRVDC.NE.0) THEN
4428 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4429 NMODES(0)=NMODES(0)+NMODES(I)
4437 C...NEUTRALINO DECAYS
4438 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4444 CALL PYNAME(KFSUSY,CHTMP)
4446 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4447 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4448 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4449 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4451 DO 310 J=1,MDCY(KC,3)
4453 ID1=IABS(KFDP(IDC,1))
4454 ID2=IABS(KFDP(IDC,2))
4455 ID3=IABS(KFDP(IDC,3))
4456 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4457 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4458 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4459 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4460 NMODES(1)=NMODES(1)+1
4461 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4462 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4463 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4464 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4465 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4466 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4467 NMODES(2)=NMODES(2)+1
4468 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4469 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4470 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4471 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4472 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4473 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4474 NMODES(3)=NMODES(3)+1
4475 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4476 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4477 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4478 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4479 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4480 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4481 NMODES(4)=NMODES(4)+1
4482 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4483 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4488 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4494 CALL PYNAME(KFSUSY,CHTMP)
4496 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4497 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4498 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4499 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4500 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4502 DO 330 J=1,MDCY(KC,3)
4504 ID1=IABS(KFDP(IDC,1))
4505 ID2=IABS(KFDP(IDC,2))
4506 ID3=IABS(KFDP(IDC,3))
4507 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4508 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4509 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4510 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4511 NMODES(1)=NMODES(1)+1
4512 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4513 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4514 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4515 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4516 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4517 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4518 NMODES(1)=NMODES(1)+1
4519 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4520 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4521 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4522 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4523 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4524 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4525 NMODES(2)=NMODES(2)+1
4526 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4527 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4528 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4529 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4530 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4531 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4532 NMODES(3)=NMODES(3)+1
4533 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4534 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4535 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4536 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4537 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4538 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4539 NMODES(3)=NMODES(3)+1
4540 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4541 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4542 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4543 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4544 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4545 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4546 NMODES(4)=NMODES(4)+1
4547 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4548 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4549 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4550 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4551 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4552 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4553 NMODES(4)=NMODES(4)+1
4554 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4555 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4556 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4557 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4558 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4559 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4560 NMODES(5)=NMODES(5)+1
4561 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4562 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4563 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4564 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4565 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4566 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4567 NMODES(5)=NMODES(5)+1
4568 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4569 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4574 IF (KFSM.EQ.21) THEN
4580 CALL PYNAME(KFSUSY,CHTMP)
4582 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4583 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4584 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4586 DO 350 J=1,MDCY(KC,3)
4588 ID1=IABS(KFDP(IDC,1))
4589 ID2=IABS(KFDP(IDC,2))
4590 ID3=IABS(KFDP(IDC,3))
4591 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4592 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4593 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4594 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4595 NMODES(1)=NMODES(1)+1
4596 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4597 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4598 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4599 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4600 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4601 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4602 NMODES(2)=NMODES(2)+1
4603 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4604 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4605 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4606 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4607 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4608 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4609 NMODES(3)=NMODES(3)+1
4610 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4611 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4616 IF (NRVDC.NE.0) THEN
4618 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4619 NMODES(0)=NMODES(0)+NMODES(I)
4623 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4625 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4626 WRITE (MSTU(11),8500)
4630 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4631 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4635 WRITE (MSTU(11),8600)
4639 C...Formats for printouts.
4640 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4641 &'Events and Cross-sections',1X,9('*'))
4642 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4643 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4644 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4645 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4646 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4647 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4649 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4651 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4652 &1X,'I',34X,'I',28X,'I',12X,'I')
4653 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4654 &1X,'********* Total number of errors, excluding junctions =',
4655 &1X,I8,' *************'/
4656 &1X,'********* Total number of errors, including junctions =',
4657 &1X,I8,' *************'/
4658 &1X,'********* Total number of warnings = ',
4659 &1X,I8,' *************'/
4660 &1X,'********* Fraction of events that fail fragmentation ',
4661 &'cuts =',1X,F8.5,' *********'/)
4662 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4663 &'Ratios',1X,27('*'))
4664 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4665 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4666 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4667 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4669 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4670 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4671 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4672 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4673 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4674 &1P,D10.3,0P,1X,'I')
4675 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4676 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4677 &1P,D10.3,0P,1X,'I')
4678 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4679 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4680 &'Particles at Hard Interaction',1X,7('*'))
4681 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4682 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4683 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4684 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4685 &78('=')/1X,'I',38X,'I',37X,'I')
4686 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4687 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4688 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4689 &'Kinematical Variables',1X,12('*'))
4690 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4691 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4693 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4694 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4695 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4696 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4697 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4698 &'Parameter Values',1X,12('*'))
4699 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4701 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4702 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4704 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4705 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4706 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4707 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4708 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4710 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4711 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4712 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4713 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4714 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4715 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4716 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4717 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4718 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4720 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4721 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4722 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4724 & 1X,'R-Violating couplings',1X/ 1X /
4726 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4727 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4728 & ,'I',15X,'I',15X,'I',15X,'I')
4729 8600 FORMAT(1X,55('='))
4730 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4731 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4736 C*********************************************************************
4739 C...Administers the hard-process generation required for output to the
4740 C...Les Houches event record.
4744 C...Double precision and integer declarations.
4745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4746 IMPLICIT INTEGER(I-N)
4747 INTEGER PYK,PYCHGE,PYCOMP
4750 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4751 COMMON/PYCTAG/NCT,MCT(4000,2)
4752 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4753 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4754 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4755 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4756 COMMON/PYINT1/MINT(400),VINT(400)
4757 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4758 COMMON/PYINT4/MWID(500),WIDS(500,5)
4759 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4760 &/PYINT1/,/PYINT2/,/PYINT4/
4762 C...HEPEUP for output.
4764 PARAMETER (MAXNUP=500)
4765 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4766 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4767 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4768 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4769 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4772 C...Stop if no subprocesses on.
4773 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4774 WRITE(MSTU(11),5100)
4778 C...Special flags for hard-process generation only.
4784 C...Initial values for some counters.
4795 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4798 C...If variable energies: redo incoming kinematics and cross-section.
4800 IF(MSTP(171).EQ.1) THEN
4802 IF(MSTI(61).EQ.1) THEN
4806 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4810 C...Do not allow pileup events.
4813 C...Generate variables of hard scattering.
4817 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4822 IF(MSTI(61).EQ.1) THEN
4826 IF(MINT(51).EQ.2) RETURN
4829 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4830 C...Hard scattering (including low-pT):
4831 C...reconstruct kinematics and colour flow of hard scattering.
4836 IF(MINT(51).EQ.1) GOTO 100
4840 C...Decay of final state resonances.
4842 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4844 IF(MINT(51).EQ.1) GOTO 100
4847 C...Longitudinal boost of hard scattering.
4848 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4849 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4851 ELSEIF(ISUB.NE.99) THEN
4852 C...Diffractive and elastic scattering.
4856 C...DIS scattering (photon flux external).
4858 IF(MINT(51).EQ.1) GOTO 100
4861 C...Check that no odd resonance left undecayed.
4864 DO 120 I=MINT(84)+1,NFIX
4865 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4866 & K(I,2).NE.22) THEN
4868 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4870 IF(MINT(51).EQ.1) GOTO 100
4875 C...Boost hadronic subsystem to overall rest frame.
4876 C..(Only relevant when photon inside lepton beam.)
4877 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4879 C...Store event information and calculate Monte Carlo estimates of
4880 C...subprocess cross-sections.
4883 C...Transform to the desired coordinate frame.
4884 140 CALL PYFRAM(MSTP(124))
4888 C...Restore special flags for hard-process generation only.
4892 C...Trace colour tags; convert to LHA style labels.
4894 DO 150 I=MINT(84)+1,N
4898 DO 160 I=MINT(84)+1,N
4899 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4900 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4901 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4903 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4904 IDA=MOD(K(I,4),MSTU(5))
4905 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4906 & MCT(IMO,2).NE.0) THEN
4908 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4909 & MCT(IMO,1).NE.0) THEN
4911 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4912 & MCT(IDA,2).NE.0) THEN
4919 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4921 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4922 IDA=MOD(K(I,5),MSTU(5))
4923 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4924 & MCT(IMO,1).NE.0) THEN
4926 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4927 & MCT(IMO,2).NE.0) THEN
4929 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4930 & MCT(IDA,1).NE.0) THEN
4940 C...Put event in HEPEUP commonblock.
4948 IDUP(I)=K(I+MINT(84),2)
4953 ELSEIF(K(I+4,3).EQ.0) THEN
4959 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4962 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4963 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4964 ICOLUP(1,I)=MCT(I+MINT(84),1)
4965 ICOLUP(2,I)=MCT(I+MINT(84),2)
4967 PUP(J,I)=P(I+MINT(84),J)
4973 C...Optionally write out event to disk. Minimal size for time/spin fields.
4974 IF(MSTP(162).GT.0) THEN
4975 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4977 IF(VTIMUP(I).EQ.0D0) THEN
4978 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4979 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4982 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4983 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4988 C...Optional extra line with parton-density information.
4989 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4990 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4993 C...Error messages and other print formats.
4994 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4995 &1X,'Execution stopped.')
4996 5200 FORMAT(1P,2I6,4E14.6)
4997 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4998 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4999 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
5004 C*********************************************************************
5007 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
5008 C...processes, and optionally stores that information on file.
5012 C...Double precision and integer declarations.
5013 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5014 IMPLICIT INTEGER(I-N)
5017 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5018 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5019 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5020 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5021 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5023 C...User process initialization commonblock.
5025 PARAMETER (MAXPUP=100)
5026 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5027 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5028 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5029 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5033 C...Store info on incoming beams.
5043 C...Event weighting strategy.
5046 C...Info on individual processes.
5049 IF(MSUB(ISUB).EQ.1) THEN
5051 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5052 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5058 C...Write info to file.
5059 IF(MSTP(161).GT.0) THEN
5060 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5061 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5063 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5068 C...Formats for printout.
5069 5100 FORMAT(1P,2I8,2E14.6,6I6)
5070 5200 FORMAT(1P,3E14.6,I6)
5076 C*********************************************************************
5078 C...Combine the two old-style Pythia initialization and event files
5079 C...into a single Les Houches Event File.
5083 C...Double precision and integer declarations.
5084 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5085 IMPLICIT INTEGER(I-N)
5087 C...PYTHIA commonblock: only used to provide read/write units and version.
5088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5091 C...User process initialization commonblock.
5093 PARAMETER (MAXPUP=100)
5094 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5095 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5096 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5097 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5101 C...User process event common block.
5103 PARAMETER (MAXNUP=500)
5104 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5105 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5106 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5107 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5108 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5111 C...Lines to read in assumed never longer than 200 characters.
5112 PARAMETER (MAXLEN=200)
5113 CHARACTER*(MAXLEN) STRING
5115 C...Format for reading lines.
5118 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5120 C...Rewind initialization and event files.
5124 C...Write header info.
5125 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5126 WRITE(MSTP(163),'(A)') '<!--'
5127 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5128 &MSTP(181),'.',MSTP(182)
5129 WRITE(MSTP(163),'(A)') '-->'
5131 C...Read first line of initialization info and get number of processes.
5132 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5133 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5134 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5136 C...Copy initialization lines, omitting trailing blanks.
5137 C...Embed in <init> ... </init> block.
5138 WRITE(MSTP(163),'(A)') '<init>'
5140 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5143 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5144 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5146 WRITE(MSTP(163),'(A)') '</init>'
5148 C...Begin event loop. Read first line of event info or already done.
5149 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5152 C...Look at first line to know number of particles in event.
5153 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5155 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5156 WRITE(MSTP(163),'(A)') '<event>'
5158 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5161 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5162 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5165 C...Copy trailing comment lines - with a # in the first column - as is.
5166 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5167 IF(STRING(1:1).EQ.'#') THEN
5170 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5171 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5175 C..End the <event> block. Loop back to look for next event.
5176 WRITE(MSTP(163),'(A)') '</event>'
5179 C...Successfully reached end of event loop: write closing tag
5180 C...and remove temporary intermediate files (unless asked not to).
5181 300 WRITE(MSTP(163),'(A)') '</event>'
5182 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5183 IF(MSTP(164).EQ.1) RETURN
5184 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5185 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5189 400 WRITE(*,*) ' PYLHEF file joining failed!'
5194 C*********************************************************************
5197 C...Calculates full and effective widths of gauge bosons, stores
5198 C...masses and widths, rescales coefficients to be used for
5199 C...resonance production generation.
5203 C...Double precision and integer declarations.
5204 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5205 IMPLICIT INTEGER(I-N)
5206 INTEGER PYK,PYCHGE,PYCOMP
5207 C...Parameter statement to help give large particle numbers.
5208 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5209 &KEXCIT=4000000,KDIMEN=5000000)
5211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5212 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5213 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5214 COMMON/PYDAT4/CHAF(500,2)
5216 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5217 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5218 COMMON/PYINT1/MINT(400),VINT(400)
5219 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5220 COMMON/PYINT4/MWID(500),WIDS(500,5)
5221 COMMON/PYINT6/PROC(0:500)
5223 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5224 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5225 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5226 C...Local arrays and data.
5228 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5229 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5231 C...Born level couplings in MSSM Higgs doublet sector.
5234 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5236 IF(MSTP(4).EQ.2) THEN
5238 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5242 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5243 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5245 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5246 WRITE(MSTU(11),5000)
5249 PMAS(35,1)=SQRT(SQMHP)
5250 PMAS(36,1)=SQRT(SQMA)
5251 PMAS(37,1)=SQRT(SQMHC)
5252 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5257 PARU(161)=-SIN(ALSU)/COS(BESU)
5258 PARU(162)=COS(ALSU)/SIN(BESU)
5260 PARU(164)=SIN(BESU-ALSU)
5262 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5263 PARU(171)=COS(ALSU)/COS(BESU)
5264 PARU(172)=SIN(ALSU)/SIN(BESU)
5266 PARU(174)=COS(BESU-ALSU)
5268 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5270 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5271 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5277 PARU(186)=COS(BESU-ALSU)
5278 PARU(187)=SIN(BESU-ALSU)
5282 PARU(195)=COS(BESU-ALSU)
5285 C...Reset effective widths of gauge bosons.
5292 C...Order resonances by increasing mass (except Z0 and W+/-).
5296 IF(KF.EQ.0) GOTO 140
5297 IF(MWID(KC).EQ.0) GOTO 140
5298 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5299 IF(MSTP(1).LE.3) GOTO 140
5301 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5302 IF(IMSS(1).LE.0) GOTO 140
5306 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5307 DO 120 I1=NRES-1,1,-1
5308 IF(PMRES.GE.PMORD(I1)) GOTO 130
5309 KCORD(I1+1)=KCORD(I1)
5310 PMORD(I1+1)=PMORD(I1)
5316 C...Loop over possible resonances.
5321 C...Check that no fourth generation channels on by mistake.
5322 IF(MSTP(1).LE.3) THEN
5323 DO 150 J=1,MDCY(KC,3)
5325 KFA1=IABS(KFDP(IDC,1))
5326 KFA2=IABS(KFDP(IDC,2))
5327 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5328 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5333 C...Check that no supersymmetric channels on by mistake.
5334 IF(IMSS(1).LE.0) THEN
5335 DO 160 J=1,MDCY(KC,3)
5337 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5338 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5339 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5344 C...Find mass and evaluate width.
5346 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5347 IF(MWID(KC).EQ.3) MINT(63)=1
5348 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5351 C...Evaluate suppression factors due to non-simulated channels.
5352 IF(KCHG(KC,3).EQ.0) THEN
5354 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5355 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5356 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5357 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5358 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5363 IF(MWID(KC).EQ.3) MINT(63)=1
5364 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5367 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5368 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5369 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5370 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5371 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5372 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5373 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5374 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5375 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5376 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5377 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5378 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5379 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5382 C...Set resonance widths and branching ratios;
5383 C...also on/off switch for decays.
5384 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5386 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5387 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5388 DO 170 J=1,MDCY(KC,3)
5391 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5396 C...Flavours of leptoquark: redefine charge and name.
5397 KFLQQ=KFDP(MDCY(42,2),1)
5398 KFLQL=KFDP(MDCY(42,2),2)
5399 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5400 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5402 IF(IABS(KFLQL).EQ.13) LL=2
5403 IF(IABS(KFLQL).EQ.15) LL=3
5404 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5405 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5406 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5408 C...Special cases in treatment of gamma*/Z0: redefine process name.
5409 IF(MSTP(43).EQ.1) THEN
5410 PROC(1)='f + fbar -> gamma*'
5411 PROC(15)='f + fbar -> g + gamma*'
5412 PROC(19)='f + fbar -> gamma + gamma*'
5413 PROC(30)='f + g -> f + gamma*'
5414 PROC(35)='f + gamma -> f + gamma*'
5415 ELSEIF(MSTP(43).EQ.2) THEN
5416 PROC(1)='f + fbar -> Z0'
5417 PROC(15)='f + fbar -> g + Z0'
5418 PROC(19)='f + fbar -> gamma + Z0'
5419 PROC(30)='f + g -> f + Z0'
5420 PROC(35)='f + gamma -> f + Z0'
5421 ELSEIF(MSTP(43).EQ.3) THEN
5422 PROC(1)='f + fbar -> gamma*/Z0'
5423 PROC(15)='f + fbar -> g + gamma*/Z0'
5424 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5425 PROC(30)='f + g -> f + gamma*/Z0'
5426 PROC(35)='f + gamma -> f + gamma*/Z0'
5429 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5430 IF(MSTP(44).EQ.1) THEN
5431 PROC(141)='f + fbar -> gamma*'
5432 ELSEIF(MSTP(44).EQ.2) THEN
5433 PROC(141)='f + fbar -> Z0'
5434 ELSEIF(MSTP(44).EQ.3) THEN
5435 PROC(141)='f + fbar -> Z''0'
5436 ELSEIF(MSTP(44).EQ.4) THEN
5437 PROC(141)='f + fbar -> gamma*/Z0'
5438 ELSEIF(MSTP(44).EQ.5) THEN
5439 PROC(141)='f + fbar -> gamma*/Z''0'
5440 ELSEIF(MSTP(44).EQ.6) THEN
5441 PROC(141)='f + fbar -> Z0/Z''0'
5442 ELSEIF(MSTP(44).EQ.7) THEN
5443 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5446 C...Special cases in treatment of WW -> WW: redefine process name.
5447 IF(MSTP(45).EQ.1) THEN
5448 PROC(77)='W+ + W+ -> W+ + W+'
5449 ELSEIF(MSTP(45).EQ.2) THEN
5450 PROC(77)='W+ + W- -> W+ + W-'
5451 ELSEIF(MSTP(45).EQ.3) THEN
5452 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5455 C...Initialize Generic Processes
5467 KCI1=PYCOMP(KFDP(IDCY,1))
5468 IF(KFDP(IDCY,1).LT.0) IJ1=2
5469 KCI2=PYCOMP(KFDP(IDCY,2))
5470 IF(KFDP(IDCY,2).LT.0) IJ2=2
5473 IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4)
5477 IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4)
5479 PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2)
5482 IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9)
5484 PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1)
5491 IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8)
5495 IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8)
5497 PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)//
5498 & '+'//CHAF(KCF2,IJ2)(1:ITMP2)
5504 C...Format for error information.
5505 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5506 &'combination'/1X,'Execution stopped!')
5511 C*********************************************************************
5514 C...Identifies the two incoming particles and the choice of frame.
5516 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5518 C...Double precision and integer declarations.
5519 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5520 IMPLICIT INTEGER(I-N)
5521 INTEGER PYK,PYCHGE,PYCOMP
5523 C...User process initialization commonblock.
5525 PARAMETER (MAXPUP=100)
5526 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5527 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5528 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5529 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5534 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5535 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5536 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5537 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5538 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5539 COMMON/PYINT1/MINT(400),VINT(400)
5540 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5542 C...Local arrays, character variables and data.
5543 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5544 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5545 DIMENSION LEN(3),KCDE(39),PM(2)
5546 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5547 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5548 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5549 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5550 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5551 &'nu_taubar ','pi+ ','pi- ','n0 ',
5552 &'nbar0 ','p+ ','pbar- ','gamma ',
5553 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5554 &'xi- ','xi0 ','omega- ','pi0 ',
5555 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5556 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5557 &'k+ ','k- ','ks0 ','kl0 '/
5558 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5559 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5560 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5562 C...Store initial energy. Default frame.
5566 C...Special user process initialization; convert to normal input.
5567 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5569 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5570 CALL PYNAME(IDBMUP(1),CHNAME)
5572 CALL PYNAME(IDBMUP(2),CHNAME)
5576 C...Convert character variables to lowercase and find their length.
5583 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5585 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5591 C...Fix up bar, underscore and charge in particle name (if needed).
5593 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5595 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5598 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5600 CHIDNT(I)='nu_'//CHTEMP(3:7)
5601 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5602 CHIDNT(I)(1:3)='n0 '
5603 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5604 CHIDNT(I)(1:5)='nbar0'
5605 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5606 CHIDNT(I)(1:3)='p+ '
5607 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5608 & CHIDNT(I)(1:2).EQ.'p-') THEN
5609 CHIDNT(I)(1:5)='pbar-'
5610 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5612 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5613 CHIDNT(I)(1:7)='reggeon'
5614 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5615 CHIDNT(I)(1:7)='pomeron'
5619 C...Identify free initialization.
5620 IF(CHCOM(1)(1:2).EQ.'no') THEN
5625 C...Identify incoming beam and target particles.
5628 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5630 PM(I)=PYMASS(MINT(10+I))
5633 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5634 CHTEMP=CHIDNT(I+1)(7:12)//' '
5636 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5638 PM(I)=PYMASS(MINT(140+I))
5642 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5643 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5644 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5646 C...Identify choice of frame and input energies.
5649 C...Events defined in the CM frame.
5650 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5653 IF(MSTP(122).GE.1) THEN
5654 IF(CHCOM(2)(1:1).NE.'e') THEN
5655 LOFFS=(31-(LEN(2)+LEN(3)))/2
5656 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5657 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5660 LOFFS=(30-(LEN(2)+LEN(3)))/2
5661 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5662 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5665 WRITE(MSTU(11),5200) CHINIT
5666 WRITE(MSTU(11),5300) WIN
5669 C...Events defined in fixed target frame.
5670 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5672 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5673 IF(MSTP(122).GE.1) THEN
5674 LOFFS=(29-(LEN(2)+LEN(3)))/2
5675 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5676 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5677 & ' fixed target'//' '
5678 WRITE(MSTU(11),5200) CHINIT
5679 WRITE(MSTU(11),5400) WIN
5680 WRITE(MSTU(11),5500) SQRT(S)
5683 C...Frame defined by user three-vectors.
5684 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5688 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5689 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5690 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5691 & (P(1,3)+P(2,3))**2
5692 IF(MSTP(122).GE.1) THEN
5693 LOFFS=(22-(LEN(2)+LEN(3)))/2
5694 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5695 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5696 & ' user configuration'//' '
5697 WRITE(MSTU(11),5200) CHINIT
5698 WRITE(MSTU(11),5600)
5699 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5700 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5701 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5704 C...Frame defined by user four-vectors.
5705 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5707 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5708 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5709 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5710 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5711 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5712 & (P(1,3)+P(2,3))**2
5713 IF(MSTP(122).GE.1) THEN
5714 LOFFS=(22-(LEN(2)+LEN(3)))/2
5715 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5716 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5717 & ' user configuration'//' '
5718 WRITE(MSTU(11),5200) CHINIT
5719 WRITE(MSTU(11),5600)
5720 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5721 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5722 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5725 C...Frame defined by user five-vectors.
5726 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5728 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5729 & (P(1,3)+P(2,3))**2
5730 IF(MSTP(122).GE.1) THEN
5731 LOFFS=(22-(LEN(2)+LEN(3)))/2
5732 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5733 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5734 & ' user configuration'//' '
5735 WRITE(MSTU(11),5200) CHINIT
5736 WRITE(MSTU(11),5600)
5737 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5738 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5739 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5742 C...Frame defined by HEPRUP common block.
5743 ELSEIF(MINT(111).GE.11) THEN
5744 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5745 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5746 IF(MSTP(122).GE.1) THEN
5747 LOFFS=(22-(LEN(2)+LEN(3)))/2
5748 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5749 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5750 & ' user configuration'//' '
5751 WRITE(MSTU(11),5200) CHINIT
5752 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5753 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5756 C...Unknown frame. Error for too low CM energy.
5758 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5761 IF(S.LT.PARP(2)**2) THEN
5762 WRITE(MSTU(11),5900) SQRT(S)
5766 C...Formats for initialization and error information.
5767 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5768 &1X,'Execution stopped!')
5769 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5770 &1X,'Execution stopped!')
5771 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5772 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5773 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5774 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5775 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5776 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5777 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5778 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5779 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5780 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5781 &1X,'Execution stopped!')
5782 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5783 &'generation.'/1X,'Execution stopped!')
5784 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5785 &'GeV beam energies',13X,'I')
5790 C*********************************************************************
5793 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5795 SUBROUTINE PYINKI(MODKI)
5797 C...Double precision and integer declarations.
5798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5799 IMPLICIT INTEGER(I-N)
5800 INTEGER PYK,PYCHGE,PYCOMP
5802 C...User process initialization commonblock.
5804 PARAMETER (MAXPUP=100)
5805 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5806 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5807 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5808 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5813 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5814 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5815 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5816 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5817 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5818 COMMON/PYINT1/MINT(400),VINT(400)
5819 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5821 C...Set initial flavour state.
5826 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5829 C...Reset boost. Do kinematics for various cases.
5834 C...Set up kinematics for events defined in CM frame.
5835 IF(MINT(111).EQ.1) THEN
5837 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5841 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5842 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5847 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5850 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5851 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5853 C...Set up kinematics for fixed target events.
5854 ELSEIF(MINT(111).EQ.2) THEN
5856 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5859 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5860 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5866 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5869 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5870 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5871 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5873 C...Set up kinematics for events in user-defined frame.
5874 ELSEIF(MINT(111).EQ.3) THEN
5877 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5878 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5879 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5880 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5882 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5884 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5885 VINT(7)=PYANGL(P(1,1),P(1,2))
5886 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5887 VINT(6)=PYANGL(P(1,3),P(1,1))
5888 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5889 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5891 C...Set up kinematics for events with user-defined four-vectors.
5892 ELSEIF(MINT(111).EQ.4) THEN
5893 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5894 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5895 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5896 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5898 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5900 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5901 VINT(7)=PYANGL(P(1,1),P(1,2))
5902 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5903 VINT(6)=PYANGL(P(1,3),P(1,1))
5904 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5905 S=(P(1,4)+P(2,4))**2
5907 C...Set up kinematics for events with user-defined five-vectors.
5908 ELSEIF(MINT(111).EQ.5) THEN
5910 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5912 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5913 VINT(7)=PYANGL(P(1,1),P(1,2))
5914 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5915 VINT(6)=PYANGL(P(1,3),P(1,1))
5916 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5917 S=(P(1,4)+P(2,4))**2
5919 C...Set up kinematics for events with external user processes.
5920 ELSEIF(MINT(111).GE.11) THEN
5923 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5924 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5929 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5930 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5933 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5934 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5935 S=(P(1,4)+P(2,4))**2
5938 C...Return or error for too low CM energy.
5939 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5940 IF(MSTP(172).LE.1) THEN
5942 & '(PYINKI:) too low invariant mass in this event')
5949 C...Save information on incoming particles.
5952 IF(MINT(111).GE.4) THEN
5953 IF(MINT(141).EQ.0) THEN
5955 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5959 IF(MINT(142).EQ.0) THEN
5961 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5967 IF(MODKI.EQ.0) VINT(289)=S
5975 C...Store pT cut-off and related constants to be used in generation.
5976 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5977 IF(MSTP(82).LE.1) THEN
5978 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5980 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5982 VINT(149)=4D0*PTMN**2/S
5988 C*********************************************************************
5991 C...Selects partonic subprocesses to be included in the simulation.
5995 C...Double precision and integer declarations.
5996 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5997 IMPLICIT INTEGER(I-N)
5998 INTEGER PYK,PYCHGE,PYCOMP
6000 C...User process initialization commonblock.
6002 PARAMETER (MAXPUP=100)
6003 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
6004 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
6005 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
6006 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
6010 C...Commonblocks and character variables.
6011 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6012 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6013 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
6014 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6015 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6016 COMMON/PYINT1/MINT(400),VINT(400)
6017 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6018 COMMON/PYINT6/PROC(0:500)
6020 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
6025 C...Reset processes to be included.
6032 C...Set running pTmin scale.
6033 IF(MSTP(82).LE.1) THEN
6034 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6036 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6039 C...Begin by assuming incoming photon to enter subprocess.
6040 IF(MINT(11).EQ.22) MINT(15)=22
6041 IF(MINT(12).EQ.22) MINT(16)=22
6043 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
6044 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
6046 MINT(123)=MINT(122)+1
6048 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
6050 C...Here also set a few parameters otherwise normally not touched.
6051 ELSEIF(MINT(121).GT.1) THEN
6053 C...Parton distributions dampened at small Q2; go to low energies,
6054 C...alpha_s <1; no minimum pT cut-off a priori.
6055 IF(MSTP(18).EQ.2) THEN
6063 C...Define pT cut-off parameters and whether run involves low-pT.
6067 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6069 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6070 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6072 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6073 IF(MSEL.EQ.2) IPTL=1
6075 C...Set up for p/gamma * gamma; real or virtual photons.
6076 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6077 & MSTP(14).EQ.30)) THEN
6079 C...Set up for p/VMD * VMD.
6080 IF(MINT(122).EQ.1) THEN
6088 IF(IPTL.EQ.1) MSUB(95)=1
6095 IF(IPTL.EQ.1) CKIN(3)=0D0
6097 C...Set up for p/VMD * direct gamma.
6098 ELSEIF(MINT(122).EQ.2) THEN
6100 IF(MINT(121).EQ.6) MINT(123)=5
6105 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6107 C...Set up for p/VMD * anomalous gamma.
6108 ELSEIF(MINT(122).EQ.3) THEN
6110 IF(MINT(121).EQ.6) MINT(123)=7
6117 IF(IPTL.EQ.1) MSUB(95)=1
6124 IF(IPTL.EQ.1) CKIN(3)=0D0
6126 C...Set up for DIS * p.
6127 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6128 & IABS(MINT(12)).GT.100)) THEN
6130 IF(IPTL.EQ.1) MSUB(99)=1
6132 C...Set up for direct * direct gamma (switch off leptons).
6133 ELSEIF(MINT(122).EQ.4) THEN
6139 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6140 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6142 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6144 C...Set up for direct * anomalous gamma.
6145 ELSEIF(MINT(122).EQ.5) THEN
6151 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6153 C...Set up for anomalous * anomalous gamma.
6154 ELSEIF(MINT(122).EQ.6) THEN
6162 IF(IPTL.EQ.1) MSUB(95)=1
6169 IF(IPTL.EQ.1) CKIN(3)=0D0
6172 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6173 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6175 C...Set up for direct * direct gamma (switch off leptons).
6176 IF(MINT(122).EQ.1) THEN
6182 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6183 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6185 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6187 C...Set up for direct * VMD and VMD * direct gamma.
6188 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6194 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6196 C...Set up for direct * anomalous and anomalous * direct gamma.
6197 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6203 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6205 C...Set up for VMD*VMD.
6206 ELSEIF(MINT(122).EQ.5) THEN
6214 IF(IPTL.EQ.1) MSUB(95)=1
6221 IF(IPTL.EQ.1) CKIN(3)=0D0
6223 C...Set up for VMD * anomalous and anomalous * VMD gamma.
6224 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6232 IF(IPTL.EQ.1) MSUB(95)=1
6239 IF(IPTL.EQ.1) CKIN(3)=0D0
6241 C...Set up for anomalous * anomalous gamma.
6242 ELSEIF(MINT(122).EQ.9) THEN
6250 IF(IPTL.EQ.1) MSUB(95)=1
6257 IF(IPTL.EQ.1) CKIN(3)=0D0
6259 C...Set up for DIS * VMD and VMD * DIS gamma.
6260 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6262 IF(IPTL.EQ.1) MSUB(99)=1
6264 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6265 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6267 IF(IPTL.EQ.1) MSUB(99)=1
6270 C...Set up for gamma* * p; virtual photons = dir, res.
6271 ELSEIF(MINT(121).EQ.2) THEN
6273 C...Set up for direct * p.
6274 IF(MINT(122).EQ.1) THEN
6280 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6282 C...Set up for resolved * p.
6283 ELSEIF(MINT(122).EQ.2) THEN
6291 IF(IPTL.EQ.1) MSUB(95)=1
6298 IF(IPTL.EQ.1) CKIN(3)=0D0
6301 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6302 ELSEIF(MINT(121).EQ.4) THEN
6304 C...Set up for direct * direct gamma (switch off leptons).
6305 IF(MINT(122).EQ.1) THEN
6311 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6312 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6314 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6316 C...Set up for direct * resolved and resolved * direct gamma.
6317 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6323 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6325 C...Set up for resolved * resolved gamma.
6326 ELSEIF(MINT(122).EQ.4) THEN
6334 IF(IPTL.EQ.1) MSUB(95)=1
6341 IF(IPTL.EQ.1) CKIN(3)=0D0
6344 C...End of special set up for gamma-p and gamma-gamma.
6349 C...Flavour information for individual beams.
6352 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6353 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6354 MINT(44+I)=MINT(40+I)
6355 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6356 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6359 C...If two real gammas, whereof one direct, pick the first.
6360 C...For two virtual photons, keep requested order.
6361 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6362 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6365 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6366 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6369 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6370 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6373 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6374 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6377 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6378 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6381 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6384 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6388 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6389 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6390 IF(MINT(11).EQ.22) THEN
6398 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6399 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6402 C...Flavour information on combination of incoming particles.
6403 MINT(43)=2*MINT(41)+MINT(42)-2
6405 IF(MINT(123).LE.0) THEN
6406 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6407 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6408 ELSEIF(MINT(123).LE.3) THEN
6409 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6410 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6411 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6415 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6416 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6417 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6418 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6420 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6423 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6424 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6426 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6428 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6429 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6430 & MINT(122).EQ.10) MINT(108)=2
6431 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6432 & MINT(122).EQ.11) MINT(108)=3
6433 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6434 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6435 IF(MINT(122).GE.3) MINT(107)=1
6436 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6437 ELSEIF(MINT(121).EQ.2) THEN
6438 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6439 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6441 IF(MINT(11).EQ.22) THEN
6443 IF(MINT(123).GE.4) MINT(107)=0
6444 IF(MINT(123).EQ.7) MINT(107)=2
6445 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6446 IF(MSTP(14).EQ.28) MINT(107)=2
6447 IF(MSTP(14).EQ.29) MINT(107)=3
6448 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6451 IF(MINT(12).EQ.22) THEN
6453 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6454 IF(MINT(123).EQ.7) MINT(108)=3
6455 IF(MSTP(14).EQ.26) MINT(108)=2
6456 IF(MSTP(14).EQ.27) MINT(108)=3
6457 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6458 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6461 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6462 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6468 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6469 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6471 C...Select default processes according to incoming beams
6472 C...(already done for gamma-p and gamma-gamma with
6473 C...MSTP(14) = 10, 20, 25 or 30).
6474 IF(MINT(121).GT.1) THEN
6475 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6477 IF(MINT(43).EQ.1) THEN
6478 C...Lepton + lepton -> gamma/Z0 or W.
6479 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6480 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6482 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6483 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6484 C...Unresolved photon + lepton: Compton scattering.
6488 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6489 & .OR.MINT(12).EQ.22)) THEN
6490 C...DIS as pure gamma* + f -> f process.
6493 ELSEIF(MINT(43).LE.3) THEN
6494 C...Lepton + hadron: deep inelastic scattering.
6497 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6498 & MINT(12).EQ.22) THEN
6499 C...Two unresolved photons: fermion pair production,
6500 C...exclude lepton pairs.
6504 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6505 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6508 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6509 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6510 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6512 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6513 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6514 & MINT(12).EQ.22)) THEN
6515 C...Unresolved photon + hadron: photon-parton scattering.
6520 ELSEIF(MSEL.EQ.1) THEN
6521 C...High-pT QCD processes:
6530 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6531 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6534 C...All QCD processes:
6548 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6549 C...Heavy quark production.
6553 DO 180 J=1,MIN(8,MDCY(21,3))
6554 MDME(MDCY(21,2)+J-1,1)=0
6556 MDME(MDCY(21,2)+MSEL-1,1)=1
6558 DO 190 J=1,MIN(12,MDCY(22,3))
6559 MDME(MDCY(22,2)+J-1,1)=0
6561 MDME(MDCY(22,2)+MSEL-1,1)=1
6563 ELSEIF(MSEL.EQ.10) THEN
6564 C...Prompt photon production:
6569 ELSEIF(MSEL.EQ.11) THEN
6570 C...Z0/gamma* production:
6573 ELSEIF(MSEL.EQ.12) THEN
6574 C...W+/- production:
6577 ELSEIF(MSEL.EQ.13) THEN
6582 ELSEIF(MSEL.EQ.14) THEN
6587 ELSEIF(MSEL.EQ.15) THEN
6588 C...Z0 & W+/- pair production:
6595 ELSEIF(MSEL.EQ.16) THEN
6603 ELSEIF(MSEL.EQ.17) THEN
6604 C...h0 & Z0 or W+/- pair production:
6608 ELSEIF(MSEL.EQ.18) THEN
6609 C...h0 production; interesting processes in e+e-.
6615 ELSEIF(MSEL.EQ.19) THEN
6616 C...h0, H0 and A0 production; interesting processes in e+e-.
6630 ELSEIF(MSEL.EQ.21) THEN
6634 ELSEIF(MSEL.EQ.22) THEN
6635 C...W'+/- production:
6638 ELSEIF(MSEL.EQ.23) THEN
6639 C...H+/- production:
6642 ELSEIF(MSEL.EQ.24) THEN
6646 ELSEIF(MSEL.EQ.25) THEN
6647 C...LQ (leptoquark) production.
6653 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6654 C...Production of one heavy quark (W exchange):
6656 DO 200 J=1,MIN(8,MDCY(21,3))
6657 MDME(MDCY(21,2)+J-1,1)=0
6659 MDME(MDCY(21,2)+MSEL-31,1)=1
6661 CMRENNA++Define SUSY alternatives.
6662 ELSEIF(MSEL.EQ.39) THEN
6663 C...Turn on all SUSY processes.
6664 IF(MINT(43).EQ.4) THEN
6665 C...Hadron-hadron processes.
6667 IF(ISET(I).GE.0) MSUB(I)=1
6669 ELSEIF(MINT(43).EQ.1) THEN
6670 C...Lepton-lepton processes: QED production of squarks.
6687 ELSEIF(MSEL.EQ.40) THEN
6688 C...Gluinos and squarks.
6689 IF(MINT(43).EQ.4) THEN
6701 ELSEIF(MINT(43).EQ.1) THEN
6706 ELSEIF(MSEL.EQ.41) THEN
6707 C...Stop production.
6711 IF(MINT(43).EQ.4) THEN
6716 ELSEIF(MSEL.EQ.42) THEN
6717 C...Slepton production.
6721 IF(MINT(43).NE.4) THEN
6727 ELSEIF(MSEL.EQ.43) THEN
6728 C...Neutralino/Chargino + Gluino/Squark.
6729 IF(MINT(43).EQ.4) THEN
6739 ELSEIF(MSEL.EQ.44) THEN
6740 C...Neutralino/Chargino pair production.
6741 IF(MINT(43).EQ.4) THEN
6745 ELSEIF(MINT(43).EQ.1) THEN
6751 ELSEIF(MSEL.EQ.45) THEN
6752 C...Sbottom production.
6755 IF(MINT(43).EQ.4) THEN
6761 ELSEIF(MSEL.EQ.50) THEN
6762 C...Pair production of technipions and gauge bosons.
6766 IF(MINT(43).EQ.4) THEN
6772 ELSEIF(MSEL.EQ.51) THEN
6773 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6778 ELSEIF(MSEL.EQ.61) THEN
6779 C...Charmonium production in colour octet model, with recoiling parton.
6784 ELSEIF(MSEL.EQ.62) THEN
6785 C...Bottomonium production in colour octet model, with recoiling parton.
6790 ELSEIF(MSEL.EQ.63) THEN
6791 C...Charmonium and bottomonium production in colour octet model.
6798 C...Find heaviest new quark flavour allowed in processes 81-84.
6800 DO 350 I=1,MIN(8,MDCY(21,3))
6802 IF(MDME(IDC,1).LE.0) GOTO 350
6805 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6816 C...Find heaviest new fermion flavour allowed in process 85.
6818 DO 360 I=1,MIN(12,MDCY(22,3))
6820 IF(MDME(IDC,1).LE.0) GOTO 360
6823 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6824 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6829 C...Initialize Generic Processes
6839 JCOL1=IABS(KCHG(KCF1,2))
6852 IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN
6858 C...Import relevant information on external user processes.
6859 IF(MINT(111).GE.11) THEN
6862 C...Find next empty PYTHIA process number slot and enable it.
6864 IF(IPYPR.GT.500) CALL PYERRM(26,
6865 & '(PYINPR.) no more empty slots for user processes')
6866 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6867 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6869 C...Overwrite KFPR with references back to process number and ID.
6871 KFPR(IPYPR,2)=LPRUP(IUP)
6873 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6876 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6878 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6879 C...Switch on process.
6887 C*********************************************************************
6890 C...Parametrizes total, elastic and diffractive cross-sections
6891 C...for different energies and beams. Donnachie-Landshoff for
6892 C...total and Schuler-Sjostrand for elastic and diffractive.
6893 C...Process code IPROC:
6900 C...= 7 : J/psi + p;
6901 C...= 11 : rho + rho;
6902 C...= 12 : rho + phi;
6903 C...= 13 : rho + J/psi;
6904 C...= 14 : phi + phi;
6905 C...= 15 : phi + J/psi;
6906 C...= 16 : J/psi + J/psi;
6907 C...= 21 : gamma + p (DL);
6908 C...= 22 : gamma + p (VDM).
6909 C...= 23 : gamma + pi (DL);
6910 C...= 24 : gamma + pi (VDM);
6911 C...= 25 : gamma + gamma (DL);
6912 C...= 26 : gamma + gamma (VDM).
6916 C...Double precision and integer declarations.
6917 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6918 IMPLICIT INTEGER(I-N)
6919 INTEGER PYK,PYCHGE,PYCOMP
6921 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6922 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6923 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6924 COMMON/PYINT1/MINT(400),VINT(400)
6925 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6926 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6927 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6929 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6930 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6931 &CEFFD(10,9),SIGTMP(6,0:5)
6933 C...Common constants.
6934 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6935 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6938 C...Number of multiple processes to be evaluated (= 0 : undefined).
6939 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6940 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6941 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6942 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6943 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6945 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6946 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6947 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6949 C...Beam and target hadron class:
6950 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6951 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6952 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6953 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6954 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6955 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6956 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6958 C...Fitting constants used in parametrizations of diffractive results.
6959 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6960 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6961 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6962 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6963 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6964 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6965 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6966 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6967 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6968 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6969 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6970 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6971 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6972 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6973 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6974 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6975 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6976 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6977 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6978 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6979 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6980 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6981 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6982 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6983 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6984 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6985 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6986 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6987 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6989 C...Parameters. Combinations of the energy.
6998 C...Ratio of gamma/pi (for rescaling in parton distributions).
6999 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
7000 &(XPAR(5)*SEPS+YPAR(5)*SETA)
7002 IF(MINT(50).NE.1) RETURN
7004 C...Order flavours of incoming particles: KF1 < KF2.
7005 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
7014 ISGN12=ISIGN(1,MINT(11)*MINT(12))
7016 C...Find process number (for lookup tables).
7017 IF(KF1.GT.1000) THEN
7019 IF(ISGN12.LT.0) IPROC=2
7020 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
7022 IF(ISGN12.LT.0) IPROC=4
7023 IF(KF1.EQ.111) IPROC=5
7024 ELSEIF(KF1.GT.100) THEN
7026 ELSEIF(KF2.GT.1000) THEN
7028 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
7029 ELSEIF(KF2.GT.100) THEN
7031 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
7034 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
7037 C... Number of multiple processes to be stored; beam/target side.
7043 ELSEIF(NPR.EQ.6) THEN
7048 IF(MINT(101).EQ.4) N1=4
7050 IF(MINT(102).EQ.4) N2=4
7052 C...Do not do any more for user-set or undefined cross-sections.
7053 IF(MSTP(31).LE.0) RETURN
7054 IF(NPR.EQ.0) CALL PYERRM(26,
7055 &'(PYXTOT:) cross section for this process not yet implemented')
7057 C...Parameters. Combinations of the energy.
7066 C...Loop over multiple processes (for VDM).
7070 ELSEIF(NPR.EQ.3) THEN
7072 IF(KF2.LT.1000) IPR=I+10
7073 ELSEIF(NPR.EQ.6) THEN
7077 C...Evaluate hadron species, mass, slope contribution and fit number.
7087 C...Skip if energy too low relative to masses.
7091 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7093 C...Total cross-section. Elastic slope parameter and cross-section.
7094 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7095 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7096 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7098 C...Diffractive scattering A + B -> X + B.
7101 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7102 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7103 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7104 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7105 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7106 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7107 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7109 C...Diffractive scattering A + B -> A + X.
7112 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7113 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7114 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7115 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7116 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7117 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7118 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7120 C...Order single diffractive correctly.
7123 SIGTMP(I,2)=SIGTMP(I,3)
7127 C...Double diffractive scattering A + B -> X1 + X2.
7128 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7129 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7130 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7131 IF(YEFF.LE.0) SUM1=0D0
7132 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7133 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7134 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7135 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7137 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7138 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7139 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7141 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7142 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7143 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7144 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7145 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7147 C...Non-diffractive by unitarity.
7148 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7152 C...Put temporary results in output array: only one process.
7153 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7155 SIGT(0,0,J)=SIGTMP(1,J)
7158 C...Beam multiple processes.
7159 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7160 IF(MINT(107).EQ.2) THEN
7161 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7163 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7164 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7166 IF(MSTP(20).GT.0) THEN
7167 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7170 IF(MINT(107).EQ.2) THEN
7171 CONV=(AEM/PARP(160+I))*VINT(317)
7172 ELSEIF(VINT(154).GT.PARP(15)) THEN
7173 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7174 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7180 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7184 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7187 C...Target multiple processes.
7188 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7189 IF(MINT(108).EQ.2) THEN
7190 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7192 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7193 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7195 IF(MSTP(20).GT.0) THEN
7196 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7199 IF(MINT(108).EQ.2) THEN
7200 CONV=(AEM/PARP(160+I))*VINT(317)
7201 ELSEIF(VINT(154).GT.PARP(15)) THEN
7202 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7203 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7209 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7213 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7216 C...Both beam and target multiple processes.
7218 IF(MINT(107).EQ.2) THEN
7219 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7221 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7222 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7224 IF(MINT(108).EQ.2) THEN
7225 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7227 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7228 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7230 IF(MSTP(20).GT.0) THEN
7231 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7232 & VINT(308)))**MSTP(20)
7236 IF(MINT(107).EQ.2) THEN
7237 CONV=(AEM/PARP(160+I1))*VINT(317)
7238 ELSEIF(VINT(154).GT.PARP(15)) THEN
7239 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7240 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7244 IF(MINT(108).EQ.2) THEN
7245 CONV=CONV*(AEM/PARP(160+I2))
7246 ELSEIF(VINT(154).GT.PARP(15)) THEN
7247 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7248 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7254 ELSEIF(I2.LE.2) THEN
7256 ELSEIF(I1.EQ.I2) THEN
7263 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7264 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7270 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7271 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7273 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7277 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7278 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7279 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7283 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7292 C*********************************************************************
7295 C...Finds optimal set of coefficients for kinematical variable selection
7296 C...and the maximum of the part of the differential cross-section used
7297 C...in the event weighting.
7301 C...Double precision and integer declarations.
7302 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7303 IMPLICIT INTEGER(I-N)
7304 INTEGER PYK,PYCHGE,PYCOMP
7305 C...Parameter statement to help give large particle numbers.
7306 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7307 &KEXCIT=4000000,KDIMEN=5000000)
7309 C...User process initialization commonblock.
7311 PARAMETER (MAXPUP=100)
7312 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7313 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7314 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7315 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7320 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7321 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7322 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7323 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7324 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7325 COMMON/PYINT1/MINT(400),VINT(400)
7326 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7327 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7328 COMMON/PYINT4/MWID(500),WIDS(500,5)
7329 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7330 COMMON/PYINT6/PROC(0:500)
7332 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7333 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7334 COMMON/PYTCCO/COEFX(194:380,2)
7335 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7336 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7337 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7339 C...Local arrays, character variables and data.
7342 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7343 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7344 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7346 DATA CVAR/'tau ','tau''','y* ','cth '/
7349 C...Initial values and loop over subprocesses.
7359 C...Find maximum weight factors for photon flux.
7360 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7361 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7364 C...Select subprocess to study: skip cases not applicable.
7365 IF(ISET(ISUB).EQ.11) THEN
7366 IF(MSUB(ISUB).NE.1) GOTO 460
7367 C...User process intialization: cross section model dependent.
7368 IF(IABS(IDWTUP).EQ.1) THEN
7369 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7370 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7371 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7373 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7374 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7375 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7376 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7377 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7378 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7380 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7381 & WTGAGA*XSEC(ISUB,1)
7384 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7385 CALL PYSIGH(NCHN,SIGS)
7387 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7388 & WTGAGA*XSEC(ISUB,1)
7389 IF(MSUB(ISUB).NE.1) GOTO 460
7392 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7393 CALL PYSIGH(NCHN,SIGS)
7395 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7396 & WTGAGA*XSEC(ISUB,1)
7397 IF(XSEC(ISUB,1).EQ.0D0) THEN
7403 ELSEIF(ISUB.EQ.96) THEN
7404 IF(MINT(50).EQ.0) GOTO 460
7405 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7407 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7408 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7409 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7410 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7411 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7412 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7414 IF(MSUB(ISUB).NE.1) GOTO 460
7417 IF(ISUB.EQ.96) ISTSB=2
7418 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7420 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7421 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7423 C...Find resonances (explicit or implicit in cross-section).
7426 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7428 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7429 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7431 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7432 & .OR.ISUB.EQ.177) THEN
7434 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7436 IF(MSTP(46).EQ.5) THEN
7439 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7441 ELSEIF(ISUB.EQ.481) THEN
7445 IF(CKMX.LE.0D0) CKMX=VINT(1)
7447 IF(KCR1.EQ.0) KFR1=0
7449 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7450 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7453 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7454 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7462 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7463 $ (ISUB.GE.361.AND.ISUB.LE.380))
7466 IF(ISUB.EQ.141) THEN
7468 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7469 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7472 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7473 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7479 ELSEIF(ITECH.EQ.0) THEN
7480 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7489 C...Order the resonances
7490 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7495 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7500 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7507 SHN0=PMAS(KCR1,1)**2
7509 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7510 SHN0=PMAS(KCR2,1)**2
7512 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7513 SHN0=PMAS(KCR3,1)**2
7516 FAR=SQRT(AEM/ALPRHT)
7518 CALL PYTECM(SHN,S1,WIDO,1)
7523 CALL PYTECM(SHN,S1,WIDO,1)
7524 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7527 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7528 ELSEIF(IRES.EQ.0) THEN
7538 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7545 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7552 SHN0=PMAS(KCR1,1)**2
7554 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7555 SHN0=PMAS(KCR2,1)**2
7558 FAR=SQRT(AEM/ALPRHT)
7560 CALL PYTECM(SHN,S1,WIDO,2)
7565 CALL PYTECM(SHN,S1,WIDO,2)
7566 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7569 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7570 ELSEIF(JRES.EQ.0) THEN
7580 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7583 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7584 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7587 VINT(73)=XMAS(1)**2/VINT(2)
7588 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7596 VINT(75)=XMAS(2)**2/VINT(2)
7597 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7605 VINT(77)=XMAS(3)**2/VINT(2)
7606 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7613 C...Charged current: rho+- and a+-
7614 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7617 VINT(73)=YMAS(1)**2/VINT(2)
7618 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7626 VINT(75)=YMAS(2)**2/VINT(2)
7627 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7636 IF(ISUB.NE.141) THEN
7637 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7638 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7639 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7640 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7641 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7642 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7643 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7645 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7647 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7652 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7660 ELSEIF(KFR1.NE.0) THEN
7662 ELSEIF(KFR2.NE.0) THEN
7667 ELSEIF(KFR3.NE.0) THEN
7676 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7678 ELSEIF(KFR2.NE.0) THEN
7693 C...Find product masses and minimum pT of process.
7699 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7703 IF(KFPR(ISUB,I).EQ.0) THEN
7704 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7706 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7707 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7710 C...This prevents SUSY/t particles from becoming too light.
7712 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7715 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7716 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7717 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7718 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7719 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7720 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7721 PMMN(I)=MIN(PMMN(I),PMSUM)
7724 ELSEIF(KFLW.EQ.6) THEN
7725 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7732 CKIN(41)=MAX(PMMN(1),CKIN(41))
7733 CKIN(43)=MAX(PMMN(2),CKIN(43))
7734 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7737 IF(MINT(51).EQ.1) THEN
7738 WRITE(MSTU(11),5100) ISUB
7745 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7746 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7747 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7748 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7749 ELSEIF(ISUB.EQ.96) THEN
7750 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7756 C...Prepare for additional variable choices in 2 -> 3.
7759 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7761 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7762 VINT(204)=PMAS(23,1)
7763 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7764 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7765 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7766 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7767 & VINT(204)=VINT(201)
7769 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7772 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7774 NPTS(1)=2+2*MINT(72)
7775 IF(MINT(47).EQ.1) THEN
7776 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7777 ELSEIF(MINT(47).GE.5) THEN
7778 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7784 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7785 IF(MINT(47).GE.2) NPTS(2)=2
7786 IF(MINT(47).GE.5) NPTS(2)=3
7789 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7791 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7792 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7795 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7796 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7798 C...Reset coefficients of cross-section weighting.
7802 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7803 & .AND.ISUB.LE.380)) THEN
7820 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7821 C...in grid of phase space points.
7827 IF(METAU.EQ.1) GOTO 150
7828 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7829 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7830 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7832 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7836 C...Special case when both resonances have same mass,
7837 C...as is often the case in process 194.
7838 c IF(MINT(72).GE.2) THEN
7839 c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7840 c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7841 c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7843 c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7848 CALL PYKMAP(1,MTAU,RTAU)
7849 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7852 IF(METAUP.EQ.1) GOTO 150
7853 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7855 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7856 CALL PYKMAP(4,MTAUP,0.5D0)
7858 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7862 IF(MEYST.EQ.1) GOTO 150
7863 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7864 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7865 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7866 CALL PYKMAP(2,MYST,0.5D0)
7870 IF(MECTH.EQ.1) GOTO 150
7871 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7872 MCTH=1+MOD(ITRY-1,NPTS(4))
7873 CALL PYKMAP(3,MCTH,0.5D0)
7875 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7877 C...Store position and limits.
7880 IF(MINT(51).EQ.1) GOTO 150
7883 MVARPT(NACC,2)=MTAUP
7887 VINTPT(NACC,J)=VINT(10+J)
7890 C...Normal case: calculate cross-section.
7892 CALL PYSIGH(NCHN,SIGS)
7898 C..2 -> 3: find highest value out of a number of tries.
7901 DO 140 IKIN3=1,MSTP(129)
7902 CALL PYKMAP(5,0,0D0)
7903 IF(MINT(51).EQ.1) GOTO 140
7904 CALL PYSIGH(NCHN,SIGTMP)
7909 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7913 C...Store cross-section.
7915 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7916 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7917 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7920 WRITE(MSTU(11),5100) ISUB
7923 ELSEIF(SIGSAM.EQ.0D0) THEN
7924 WRITE(MSTU(11),5300) ISUB
7928 IF(ISUB.NE.96) NPOSI=NPOSI+1
7930 C...Calculate integrals in tau over maximal phase space limits.
7933 ATAU1=LOG(TAUMAX/TAUMIN)
7934 IF(NPTS(1).GE.2) THEN
7935 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7937 IF(NPTS(1).GE.4) THEN
7938 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7939 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7942 IF(NPTS(1).GE.6) THEN
7943 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7944 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7947 IF(NPTS(1).GE.8) THEN
7948 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7949 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7952 IF(IPEAK7.EQ.1) THEN
7953 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7956 C...Reset. Sum up cross-sections in points calculated.
7958 IF(NPTS(IVAR).EQ.1) GOTO 320
7959 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7970 IBIN=MVARPT(IACC,IVAR)
7972 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7974 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7978 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7979 NAREL(IBIN)=NAREL(IBIN)+1
7980 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7982 C...Sum up tau cross-section pieces in points used.
7985 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7986 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7988 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7989 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7990 & ((TAU-TAUR1)**2+GAMR1**2)
7993 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7994 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7995 & ((TAU-TAUR2)**2+GAMR2**2)
7997 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7998 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7999 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
8000 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
8001 WTMAT(IBIN,7)=WTMAT(IBIN,7)
8002 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
8004 IF(MINT(72).EQ.3) THEN
8005 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
8006 & +(ATAU1/ATAU8)/(TAU+TAUR3)
8007 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
8008 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
8010 C...Sum up tau' cross-section pieces in points used.
8011 ELSEIF(IVAR.EQ.2) THEN
8013 TAUP=VINTPT(IACC,16)
8014 TAUPMN=VINTPT(IACC,6)
8015 TAUPMX=VINTPT(IACC,26)
8016 ATAUP1=LOG(TAUPMX/TAUPMN)
8017 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
8018 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8019 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
8020 & (1D0-TAU/TAUP)**3/TAUP
8022 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
8023 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
8024 & TAUP/MAX(2D-10,1D0-TAUP)
8027 C...Sum up y* cross-section pieces in points used.
8028 ELSEIF(IVAR.EQ.3) THEN
8030 YSTMIN=VINTPT(IACC,2)
8031 YSTMAX=VINTPT(IACC,22)
8033 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
8035 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
8036 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
8037 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
8038 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
8039 IF(MINT(45).EQ.3) THEN
8040 TAUE=VINTPT(IACC,11)
8041 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
8042 YST0=-0.5D0*LOG(TAUE)
8043 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
8044 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
8045 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
8046 & MAX(1D-10,1D0-EXP(YST-YST0))
8048 IF(MINT(46).EQ.3) THEN
8049 TAUE=VINTPT(IACC,11)
8050 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
8051 YST0=-0.5D0*LOG(TAUE)
8052 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
8053 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
8054 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
8055 & MAX(1D-10,1D0-EXP(-YST-YST0))
8058 C...Sum up cos(theta-hat) cross-section pieces in points used.
8060 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
8062 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
8064 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
8067 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
8068 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
8069 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
8070 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
8072 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8073 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
8074 & MAX(RM34,RSQM-CTH)
8075 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
8076 & MAX(RM34,RSQM+CTH)
8077 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
8078 & MAX(RM34,RSQM-CTH)**2
8079 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
8080 & MAX(RM34,RSQM+CTH)**2
8084 C...Check that equation system solvable.
8085 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
8089 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
8090 & IRED=1,NBIN),WTREL(IBIN)
8091 IF(NAREL(IBIN).EQ.0) MSOLV=0
8092 WTRELS=WTRELS+WTREL(IBIN)
8094 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8096 C...Solve to find relative importance of cross-section pieces.
8099 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8100 WTRSAV(IBIN)=WTREL(IBIN)
8102 C...Auxiliary vectors to record order of permutations
8107 DO 230 IRED=1,NBIN-1
8109 RESMAX=ABS(WTREL(MROW))
8110 C...Find row with largest residual
8112 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8114 RESMAX=ABS(WTREL(MROW))
8117 IF(RESMAX.LT.1D-20) THEN
8122 AMAX = ABS(WTMAT(MROW,MCOL))
8123 C...Find column with largest entry
8125 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8127 AMAX = ABS(WTMAT(MROW,MCOL))
8130 C...Swap rows if necessary
8131 IF(MROW.NE.IRED) THEN
8133 TMPE=WTMAT(IRED,JBIN)
8134 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8135 WTMAT(MROW,JBIN)=TMPE
8138 WTREL(IRED)=WTREL(MROW)
8144 C...Swap columns if necessary
8145 IF(MCOL.NE.IRED) THEN
8147 TMPE=WTMAT(JBIN,IRED)
8148 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8149 WTMAT(JBIN,MCOL)=TMPE
8155 C...Begin eliminating equations
8156 DO 220 IBIN=IRED+1,NBIN
8157 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8161 C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8162 RQTU=WTMAT(IBIN,IRED)
8163 RQTL=WTMAT(IRED,IRED)
8164 C...Switch order of operations
8165 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8166 $ (WTREL(IRED)/RQTL)
8167 DO 210 ICOE=IRED,NBIN
8168 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8169 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8173 DO 250 IRED=NBIN,1,-1
8174 DO 240 ICOE=IRED+1,NBIN
8175 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8177 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8181 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8182 TEMPC(IRED)=COEFU(IRED)
8184 C...Return to original order
8187 COEFU(MTMP)=TEMPC(IBIN)
8191 C...Share evenly if failure.
8192 260 IF(MSOLV.EQ.0) THEN
8196 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8197 & WTRSAV(IBIN)/WTRELS)
8201 C...Normalize coefficients, with piece shared democratically.
8205 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8206 COEFSU=COEFSU+COEFU(IBIN)
8207 WTRELS=WTRELS+WTRELN(IBIN)
8209 IF(COEFSU.GT.0D0) THEN
8211 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8212 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8216 COEFO(IBIN)=1D0/NBIN
8219 IF(IVAR.EQ.1) IOFF=0
8220 IF(IVAR.EQ.2) IOFF=17
8221 IF(IVAR.EQ.3) IOFF=7
8222 IF(IVAR.EQ.4) IOFF=12
8226 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8230 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8231 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8232 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8234 COEF(ISUB,ICOF)=COEFO(IBIN)
8238 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8239 & (COEFO(IBIN),IBIN=1,NBIN)
8243 C...Find two most promising maxima among points previously determined.
8251 VINT(10+J)=VINTPT(IACC,J)
8254 CALL PYSIGH(NCHN,SIGS)
8261 DO 350 IKIN3=1,MSTP(129)
8262 CALL PYKMAP(5,0,0D0)
8263 IF(MINT(51).EQ.1) GOTO 350
8264 CALL PYSIGH(NCHN,SIGTMP)
8269 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8274 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8277 DO 370 IMV=NMAX,1,-1
8279 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8280 IACCMX(IMV+1)=IACCMX(IMV)
8281 SIGSMX(IMV+1)=SIGSMX(IMV)
8284 380 IACCMX(IIN)=IACC
8286 IF(NMAX.LE.1) NMAX=NMAX+1
8290 C...Read out starting position for search.
8291 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8296 MTAUP=MVARPT(IACC,2)
8304 C...Starting point and step size in parameter space.
8307 IF(NPTS(IVAR).EQ.1) GOTO 420
8308 IF(IVAR.EQ.1) VVAR=VTAU
8309 IF(IVAR.EQ.2) VVAR=VTAUP
8310 IF(IVAR.EQ.3) VVAR=VYST
8311 IF(IVAR.EQ.4) VVAR=VCTH
8312 IF(IVAR.EQ.1) MVAR=MTAU
8313 IF(IVAR.EQ.2) MVAR=MTAUP
8314 IF(IVAR.EQ.3) MVAR=MYST
8315 IF(IVAR.EQ.4) MVAR=MCTH
8316 IF(IRPT.EQ.1) VDEL=0.1D0
8317 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8319 IF(IRPT.EQ.1) VMAR=0.02D0
8320 IF(IRPT.EQ.2) VMAR=0.002D0
8322 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8325 C...Define new point in parameter space.
8329 ELSEIF(IMOV.EQ.1) THEN
8332 ELSEIF(IMOV.EQ.2) THEN
8335 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8336 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8342 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8343 & VVAR-2D0*VDEL.GT.VMAR) THEN
8349 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8363 C...Convert to relevant variables and find derived new limits.
8367 CALL PYKMAP(1,MTAU,VTAU)
8368 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8370 IF(MINT(51).EQ.1) ILERR=1
8373 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8375 IF(IVAR.EQ.2) VTAUP=VNEW
8376 CALL PYKMAP(4,MTAUP,VTAUP)
8378 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8380 IF(MINT(51).EQ.1) ILERR=1
8382 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8383 IF(IVAR.EQ.3) VYST=VNEW
8384 CALL PYKMAP(2,MYST,VYST)
8386 IF(MINT(51).EQ.1) ILERR=1
8388 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8390 IF(IVAR.EQ.4) VCTH=VNEW
8391 CALL PYKMAP(3,MCTH,VCTH)
8393 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8395 C...Evaluate cross-section. Save new maximum. Final maximum.
8398 ELSEIF(ISTSB.NE.5) THEN
8399 CALL PYSIGH(NCHN,SIGS)
8406 DO 400 IKIN3=1,MSTP(129)
8407 CALL PYKMAP(5,0,0D0)
8408 IF(MINT(51).EQ.1) GOTO 400
8409 CALL PYSIGH(NCHN,SIGTMP)
8414 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8418 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8419 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8420 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8425 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8426 XSEC(ISUB,1)=1.05D0*SIGSAM
8427 C...Add extra headroom for UED
8428 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8429 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8430 & WTGAGA*XSEC(ISUB,1)
8432 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8433 & PARP(174)*XSEC(ISUB,1)
8434 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8438 C...Print summary table.
8439 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8440 IF(MSTP(127).NE.1) THEN
8441 WRITE(MSTU(11),5900)
8444 WRITE(MSTU(11),6400)
8448 IF(MSTP(122).GE.1) THEN
8449 WRITE(MSTU(11),6000)
8450 WRITE(MSTU(11),6100)
8452 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8453 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8454 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8456 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8457 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8458 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8459 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8460 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8462 WRITE(MSTU(11),6300)
8465 C...Format statements for maximization results.
8466 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8467 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8468 &'cth',9X,'tau''',7X,'sigma')
8469 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8470 &'phase space.'/1X,'Process switched off!')
8471 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8472 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8473 &'cross-section.'/1X,'Process switched off!')
8474 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8475 5500 FORMAT(1X,1P,10D11.3)
8476 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8477 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8478 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8479 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8480 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8481 &'cross-section.'/1X,'Execution stopped!')
8482 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8483 &'cross-section maximum search',1X,8('*'))
8484 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8485 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8486 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8487 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8488 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8489 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8491 &1X,'Execution will stop if you try to generate events.')
8496 C*********************************************************************
8499 C...Initializes multiplicity distribution and selects mutliplicity
8500 C...of pileup events, i.e. several events occuring at the same
8503 SUBROUTINE PYPILE(MPILE)
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/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8512 COMMON/PYINT1/MINT(400),VINT(400)
8513 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8514 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8515 C...Local arrays and saved variables.
8516 DIMENSION WTI(0:200)
8517 SAVE IMIN,IMAX,WTI,WTS
8519 C...Sum of allowed cross-sections for pileup events.
8521 VINT(131)=SIGT(0,0,5)
8522 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8523 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8524 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8525 IF(MSTP(133).LE.0) RETURN
8527 C...Initialize multiplicity distribution at maximum.
8528 XNAVE=VINT(131)*PARP(131)
8529 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8530 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8533 WTN=WTI(INAVE)*INAVE
8535 C...Find shape of multiplicity distribution below maximum.
8537 DO 100 I=INAVE-1,1,-1
8538 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8539 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8540 IF(WTI(I).LT.1D-6) GOTO 110
8546 C...Find shape of multiplicity distribution above maximum.
8548 DO 120 I=INAVE+1,200
8549 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8550 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8551 IF(WTI(I).LT.1D-6) GOTO 130
8558 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8559 & WTS/(WTS+WTI(1)/XNAVE)
8560 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8561 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8563 C...Pick multiplicity of pileup events.
8565 IF(MSTP(133).LE.0) THEN
8566 MINT(81)=MAX(1,MSTP(134))
8572 IF(WTR.LE.0D0) GOTO 150
8578 C...Format statement for error message.
8579 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8580 &'crossing too large, ',1P,D12.4)
8585 C*********************************************************************
8588 C...Saves and restores parameter and cross section values for the
8589 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8590 C...Also makes random choice between alternatives.
8592 SUBROUTINE PYSAVE(ISAVE,IGA)
8594 C...Double precision and integer declarations.
8595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8596 IMPLICIT INTEGER(I-N)
8597 INTEGER PYK,PYCHGE,PYCOMP
8599 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8600 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8601 COMMON/PYINT1/MINT(400),VINT(400)
8602 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8603 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8604 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8605 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8606 C...Local arrays and saved variables.
8607 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8608 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8609 &INTCP(15,20),RECP(15,20)
8610 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8612 C...Save list of subprocesses and cross-section information.
8616 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8619 MSUBCP(IGA,ICP)=MSUB(I)
8621 COEFCP(IGA,ICP,J)=COEF(I,J)
8624 NGENCP(IGA,ICP,J)=NGEN(I,J)
8625 XSECCP(IGA,ICP,J)=XSEC(I,J)
8630 NGENCP(IGA,0,J)=NGEN(0,J)
8631 XSECCP(IGA,0,J)=XSEC(0,J)
8636 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8641 C...Save various common process variables.
8643 INTCP(IGA,J)=MINT(40+J)
8645 INTCP(IGA,11)=MINT(101)
8646 INTCP(IGA,12)=MINT(102)
8647 INTCP(IGA,13)=MINT(107)
8648 INTCP(IGA,14)=MINT(108)
8649 INTCP(IGA,15)=MINT(123)
8651 RECP(IGA,2)=VINT(318)
8653 C...Save cross-section information only.
8654 ELSEIF(ISAVE.EQ.2) THEN
8655 DO 190 ICP=1,NCP(IGA)
8658 NGENCP(IGA,ICP,J)=NGEN(I,J)
8659 XSECCP(IGA,ICP,J)=XSEC(I,J)
8663 NGENCP(IGA,0,J)=NGEN(0,J)
8664 XSECCP(IGA,0,J)=XSEC(0,J)
8667 C...Choose between allowed alternatives.
8668 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8671 DO 210 IG=1,MINT(121)
8672 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8674 XSUMCP=XSUMCP*PYR(0)
8675 DO 220 IG=1,MINT(121)
8677 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8678 IF(XSUMCP.LE.0D0) GOTO 230
8683 C...Restore cross-section information.
8687 DO 270 ICP=1,NCP(IGA)
8689 MSUB(I)=MSUBCP(IGA,ICP)
8691 COEF(I,J)=COEFCP(IGA,ICP,J)
8694 NGEN(I,J)=NGENCP(IGA,ICP,J)
8695 XSEC(I,J)=XSECCP(IGA,ICP,J)
8699 NGEN(0,J)=NGENCP(IGA,0,J)
8700 XSEC(0,J)=XSECCP(IGA,0,J)
8705 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8710 C...Restore various common process variables.
8712 MINT(40+J)=INTCP(IGA,J)
8714 MINT(101)=INTCP(IGA,11)
8715 MINT(102)=INTCP(IGA,12)
8716 MINT(107)=INTCP(IGA,13)
8717 MINT(108)=INTCP(IGA,14)
8718 MINT(123)=INTCP(IGA,15)
8721 VINT(318)=RECP(IGA,2)
8723 C...Sum up cross-section info (for PYSTAT).
8724 ELSEIF(ISAVE.EQ.5) THEN
8735 DO 350 IG=1,MINT(121)
8736 DO 340 ICP=1,NCP(IG)
8738 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8739 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8740 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8741 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8743 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8744 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8745 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8746 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8753 C*********************************************************************
8756 C...For lepton beams it gives photon-hadron or photon-photon systems
8757 C...to be treated with the ordinary machinery and combines this with a
8758 C...description of the lepton -> lepton + photon branching.
8760 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8762 C...Double precision and integer declarations.
8763 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8764 IMPLICIT INTEGER(I-N)
8765 INTEGER PYK,PYCHGE,PYCOMP
8767 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8768 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8769 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8770 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8771 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8772 COMMON/PYINT1/MINT(400),VINT(400)
8773 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8774 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8776 C...Local variables and data statement.
8777 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8778 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8779 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8782 C...Initialize generation of photons inside leptons.
8785 C...Save quantities on incoming lepton system.
8789 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8791 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8792 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8793 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8795 C...Calculate range of x and Q2 values allowed in generation.
8797 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8798 IF(MINT(140+I).NE.0) THEN
8799 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8800 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8802 YMIN=MAX(CKIN(71+2*I),EPS)
8803 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8804 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8805 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8806 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8807 THEMIN=MAX(CKIN(67+2*I),0D0)
8808 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8809 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8810 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8811 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8812 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8813 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8814 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8815 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8816 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8817 C...W limits when lepton on one side only.
8818 IF(MINT(143-I).EQ.0) THEN
8819 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8820 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8821 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8826 C...W limits when lepton on both sides.
8827 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8828 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8829 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8830 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8831 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8832 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8833 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8834 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8835 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8836 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8838 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8839 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8843 C...Q2 and W values and photon flux weight factors for initialization.
8844 ELSEIF(IGAGA.EQ.2) THEN
8849 C...W value for photon on one or both sides, and for processes
8850 C...with gamma-gamma cross section peaked at small shat.
8851 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8852 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8853 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8854 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8855 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8856 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8857 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8859 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8860 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8862 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8864 C...Upper estimate of photon flux weight factor.
8865 C...Initialization Q2 scale. Flag incoming unresolved photon.
8868 IF(MINT(140+I).NE.0) THEN
8869 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8870 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8871 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8873 Q2INIT=5D0+Q2MIN(3-I)
8874 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8875 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8876 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8877 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8878 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8879 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8881 ELSEIF(ISUB.EQ.140) THEN
8886 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8887 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8889 VINT(306+I)=VINT(2+I)**2
8894 C...Update pTmin and cross section information.
8895 IF(MSTP(82).LE.1) THEN
8896 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8898 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8900 VINT(149)=4D0*PTMN**2/VINT(2)
8905 C...Generate photons inside leptons and
8906 C...calculate photon flux weight factors.
8907 ELSEIF(IGAGA.EQ.3) THEN
8912 C...Generate phase space point and check against cuts.
8916 IF(MINT(140+I).NE.0) THEN
8918 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8919 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8920 C...Cuts on internal consistency in x and Q2.
8921 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8922 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8923 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8924 C...Cuts on y and theta.
8925 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8926 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8927 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8928 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8929 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8930 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8931 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8934 C...Phi angle isotropic. Reconstruct pT.
8935 PHI(I)=PARU(2)*PYR(0)
8936 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8937 & PMS(I))*SIN(THETA(I))
8939 C...Store info on variables selected, for documentation purposes.
8940 VINT(2+I)=-SQRT(Q2(I))
8944 VINT(310+I)=THETA(I)
8955 C...Cut on W combines info from two sides.
8956 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8957 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8958 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8959 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8960 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8961 IF(W2.LT.W2MIN) GOTO 120
8962 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8965 ELSEIF(MINT(141).NE.0) THEN
8966 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8969 ELSEIF(MINT(142).NE.0) THEN
8970 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8975 C...Store kinematics info for photon(s) in subsystem cm frame.
8980 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8981 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8982 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8985 VINT(298)=-VINT(293)
8986 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8987 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8989 C...Assign weight for photon flux; different for transverse and
8990 C...longitudinal photons. Flag incoming unresolved photon.
8993 IF(MINT(140+I).NE.0) THEN
8994 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8995 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8996 IF(MSTP(16).EQ.0) THEN
8999 WTGAGA=WTGAGA*X(I)/Y(I)
9002 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
9003 WTGAGA=WTGAGA*(1D0-XY)
9004 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
9005 WTGAGA=WTGAGA*(1D0-XY)
9006 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
9007 WTGAGA=WTGAGA*(1D0-XY)
9009 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
9010 & PMS(I)*XY**2/Q2(I))
9012 IF(MINT(106+I).EQ.0) MINT(14+I)=22
9018 C...Update pTmin and cross section information.
9019 IF(MSTP(82).LE.1) THEN
9020 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
9022 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
9024 VINT(149)=4D0*PTMN**2/VINT(2)
9028 C...Reconstruct kinematics of photons inside leptons.
9029 ELSEIF(IGAGA.EQ.4) THEN
9031 C...Make place for incoming particles and scattered leptons.
9033 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
9034 MINT(4)=MINT(4)+MOVE
9035 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
9036 IF(K(I,1).EQ.21) THEN
9042 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
9043 & K(I+MOVE,3)=K(I,3)+MOVE
9044 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
9045 & K(I+MOVE,4)=K(I,4)+MOVE
9046 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
9047 & K(I+MOVE,5)=K(I,5)+MOVE
9050 DO 170 I=MINT(84)+1,N
9051 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
9052 & K(I,3)=K(I,3)+MOVE
9055 C...Fill in incoming particles.
9056 DO 190 I=MINT(83)+1,MINT(83)+MOVE
9065 IF(MINT(140+I).NE.0) THEN
9066 K(MINT(83)+I,2)=MINT(140+I)
9067 P(MINT(83)+I,5)=VINT(302+I)
9069 K(MINT(83)+I,2)=MINT(10+I)
9070 P(MINT(83)+I,5)=VINT(2+I)
9072 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
9073 & VINT(302))*(-1D0)**(I+1)
9074 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
9077 C...New mother-daughter relations in documentation section.
9078 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
9079 K(MINT(83)+1,4)=MINT(83)+3
9080 K(MINT(83)+1,5)=MINT(83)+5
9081 K(MINT(83)+2,4)=MINT(83)+4
9082 K(MINT(83)+2,5)=MINT(83)+6
9083 K(MINT(83)+3,3)=MINT(83)+1
9084 K(MINT(83)+5,3)=MINT(83)+1
9085 K(MINT(83)+4,3)=MINT(83)+2
9086 K(MINT(83)+6,3)=MINT(83)+2
9087 ELSEIF(MINT(141).NE.0) THEN
9088 K(MINT(83)+1,4)=MINT(83)+3
9089 K(MINT(83)+1,5)=MINT(83)+4
9090 K(MINT(83)+2,4)=MINT(83)+5
9091 K(MINT(83)+3,3)=MINT(83)+1
9092 K(MINT(83)+4,3)=MINT(83)+1
9093 K(MINT(83)+5,3)=MINT(83)+2
9094 ELSEIF(MINT(142).NE.0) THEN
9095 K(MINT(83)+1,4)=MINT(83)+4
9096 K(MINT(83)+2,4)=MINT(83)+3
9097 K(MINT(83)+2,5)=MINT(83)+5
9098 K(MINT(83)+3,3)=MINT(83)+2
9099 K(MINT(83)+4,3)=MINT(83)+1
9100 K(MINT(83)+5,3)=MINT(83)+2
9103 C...Fill scattered lepton(s).
9105 IF(MINT(140+I).NE.0) THEN
9106 LSC=MINT(83)+MIN(I+2,MOVE)
9108 K(LSC,2)=MINT(140+I)
9109 P(LSC,1)=PT(I)*COS(PHI(I))
9110 P(LSC,2)=PT(I)*SIN(PHI(I))
9111 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9112 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9114 P(LSC,5)=VINT(302+I)
9118 C...Find incoming four-vectors to subprocess.
9120 IF(MINT(141).NE.0) THEN
9122 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9126 P(N+1,J)=P(MINT(83)+1,J)
9130 IF(MINT(142).NE.0) THEN
9132 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9136 P(N+2,J)=P(MINT(83)+2,J)
9140 C...Define boost and rotation between hadronic subsystem and
9141 C...collision rest frame; boost hadronic subsystem to this frame.
9143 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9145 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9146 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9147 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9148 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9149 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9152 C...Add on scattered leptons to final state.
9154 IF(MINT(140+I).NE.0) THEN
9155 LSC=MINT(83)+MIN(I+2,MOVE)
9171 C*********************************************************************
9174 C...Generates quantities characterizing the high-pT scattering at the
9175 C...parton level according to the matrix elements. Chooses incoming,
9176 C...reacting partons, their momentum fractions and one of the possible
9181 C...Double precision and integer declarations.
9182 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9183 IMPLICIT INTEGER(I-N)
9184 INTEGER PYK,PYCHGE,PYCOMP
9185 C...Parameter statement to help give large particle numbers.
9186 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9187 &KEXCIT=4000000,KDIMEN=5000000)
9189 C...User process initialization and event commonblocks.
9191 PARAMETER (MAXPUP=100)
9192 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9193 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9194 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9195 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9198 PARAMETER (MAXNUP=500)
9199 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9200 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9201 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9202 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9203 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9204 SAVE /HEPRUP/,/HEPEUP/
9207 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9208 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9209 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9210 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9211 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9212 COMMON/PYINT1/MINT(400),VINT(400)
9213 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9214 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9215 COMMON/PYINT4/MWID(500),WIDS(500,5)
9216 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9217 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9218 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9219 COMMON/PYTCCO/COEFX(194:380,2)
9220 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9221 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9222 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9225 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9227 C...Parameters and data used in elastic/diffractive treatment.
9228 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9229 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9231 C...Initial values, specifically for (first) semihard interaction.
9240 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9249 C...Start by assuming incoming photon is entering subprocess.
9250 IF(MINT(11).EQ.22) THEN
9252 VINT(307)=VINT(3)**2
9254 IF(MINT(12).EQ.22) THEN
9256 VINT(308)=VINT(4)**2
9261 C...Choice of process type - first event of pileup.
9263 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9264 ELSEIF(MINT(82).EQ.1) THEN
9266 C...For gamma-p or gamma-gamma first pick between alternatives.
9268 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9271 C...For real gamma + gamma with different nature, flip at random.
9272 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9273 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9283 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9286 C...Pick process type, possibly by user process machinery.
9287 C...(If the latter, also event will be picked here.)
9288 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9291 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9296 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9297 & ISUB.LT.500) GOTO 110
9299 RSUB=XSEC(0,1)*PYR(0)
9301 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9304 IF(RSUB.LE.0D0) GOTO 130
9306 130 IF(ISUB.EQ.95) ISUB=96
9307 IF(ISUB.EQ.96) INMULT=1
9308 IF(ISET(ISUB).EQ.11) THEN
9315 C...Choice of inclusive process type - pileup events.
9316 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9317 RSUB=VINT(131)*PYR(0)
9319 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9320 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9321 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9322 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9324 IF(ISUB.EQ.96) INMULT=1
9327 C...Choice of photon energy and flux factor inside lepton.
9328 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9329 CALL PYGAGA(3,WTGAGA)
9330 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9331 CKIN(3)=MAX(VINT(285),VINT(154))
9334 C...When necessary set direct/resolved photon by hand.
9335 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9336 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9337 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9340 C...Restrict direct*resolved processes to pTmin >= Q,
9341 C...to avoid doublecounting with DIS.
9342 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9343 IF(MINT(15).EQ.22) THEN
9344 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9346 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9351 C...Set up for multiple interactions (may include impact parameter).
9352 IF(INMULT.EQ.1) THEN
9353 IF(MINT(35).LE.1) CALL PYMULT(2)
9354 IF(MINT(35).GE.2) CALL PYMIGN(2)
9357 C...Loopback point for minimum bias in photon physics.
9360 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9361 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9362 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9363 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9367 C...Random choice of flavour for some SUSY processes.
9368 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9369 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9370 IF(ISUB.EQ.210) THEN
9371 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9372 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9373 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9374 ELSEIF(ISUB.EQ.213) THEN
9375 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9376 KFPR(ISUB,2)=KFPR(ISUB,1)
9377 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9378 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9380 IF(ISUB.GE.258) THEN
9385 IF(MOD(ISUB,2).EQ.0) THEN
9386 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9388 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9390 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9391 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9392 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9395 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9398 ELSEIF(PYR(0).LT.0.5D0) THEN
9405 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9406 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9407 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9408 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9409 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9410 KFPR(ISUB,2)=KFPR(ISUB,1)
9411 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9412 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9413 KFPR(ISUB,2)=KFPR(ISUB,1)
9414 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9415 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9416 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9419 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9422 ELSEIF(PYR(0).LT.0.5D0) THEN
9429 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9434 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9438 C...Random choice of flavours for some UED processes
9439 c...The production processes can generate a doublet pair,
9440 c...a singlet pair, or a doublet + singlet.
9442 C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9443 IF(PYR(0).LE.0.1)THEN
9444 KFPR(ISUB,1)=5100001
9446 KFPR(ISUB,1)=5100002
9448 KFPR(ISUB,2)=KFPR(ISUB,1)
9449 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9450 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9451 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9452 IF(PYR(0).LE.0.1)THEN
9453 KFPR(ISUB,1)=5100001
9455 KFPR(ISUB,1)=5100002
9457 KFPR(ISUB,2)=-KFPR(ISUB,1)
9458 ELSEIF(ISUB.EQ.316)THEN
9459 C...qi + qbarj -> q*_Di + q*_Sbarj
9460 IF(PYR(0).LE.0.5)THEN
9461 KFPR(ISUB,1)=5100001
9462 c Changed from private pythia6410_ued code
9463 c KFPR(ISUB,2)=-5010001
9464 KFPR(ISUB,2)=-6100002
9466 KFPR(ISUB,1)=5100002
9467 c Changed from private pythia6410_ued code
9468 c KFPR(ISUB,2)=-5010002
9469 KFPR(ISUB,2)=-6100001
9471 ELSEIF(ISUB.EQ.317)THEN
9472 C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9473 IF(PYR(0).LE.0.5)THEN
9474 KFPR(ISUB,1)=5100001
9475 KFPR(ISUB,2)=-5100002
9477 KFPR(ISUB,1)=5100002
9478 KFPR(ISUB,2)=-5100001
9480 ELSEIF(ISUB.EQ.318)THEN
9481 C...qi + qj -> q*_Di + q*_Sj
9482 IF(PYR(0).LE.0.5)THEN
9483 KFPR(ISUB,1)=5100001
9484 KFPR(ISUB,2)=6100002
9486 KFPR(ISUB,1)=5100002
9487 KFPR(ISUB,2)=6100001
9491 C...Find resonances (explicit or implicit in cross-section).
9494 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9496 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9497 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9499 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9502 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9504 IF(MSTP(46).EQ.5) THEN
9507 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9509 ELSEIF(ISUB.EQ.481) THEN
9513 IF(CKMX.LE.0D0) CKMX=VINT(1)
9515 IF(KCR1.EQ.0) KFR1=0
9517 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9518 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9521 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9522 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9530 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9531 $(ISUB.GE.361.AND.ISUB.LE.380))
9534 IF(ISUB.EQ.141) THEN
9536 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9537 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9540 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9541 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9547 C...3 resonances at work: rho, omega, a
9548 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9549 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9552 VINT(73)=XMAS(1)**2/VINT(2)
9553 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9559 VINT(75)=XMAS(2)**2/VINT(2)
9560 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9566 VINT(77)=XMAS(3)**2/VINT(2)
9567 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9572 C...Charged current: rho+- and a+-
9573 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9576 VINT(73)=YMAS(1)**2/VINT(2)
9577 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9583 VINT(75)=YMAS(2)**2/VINT(2)
9584 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9591 IF(ISUB.NE.141) THEN
9592 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9594 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9596 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9601 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9609 ELSEIF(KFR1.NE.0) THEN
9611 ELSEIF(KFR2.NE.0) THEN
9616 ELSEIF(KFR3.NE.0) THEN
9625 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9627 ELSEIF(KFR2.NE.0) THEN
9642 C...Find product masses and minimum pT of process,
9643 C...optionally with broadening according to a truncated Breit-Wigner.
9648 IF(MINT(82).GE.2) VINT(71)=0D0
9650 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9654 IF(KFPR(ISUB,I).EQ.0) THEN
9655 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9657 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9660 C...This prevents SUSY/t particles from becoming too light.
9662 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9665 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9666 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9667 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9668 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9669 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9670 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9671 PMMN(I)=MIN(PMMN(I),PMSUM)
9674 ELSEIF(KFLW.EQ.6) THEN
9675 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9682 CKIN(41)=MAX(PMMN(1),CKIN(41))
9683 CKIN(43)=MAX(PMMN(2),CKIN(43))
9684 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9687 IF(MINT(51).EQ.1) THEN
9688 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9698 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9699 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9702 C...Prepare for additional variable choices in 2 -> 3.
9705 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9707 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9708 VINT(204)=PMAS(23,1)
9709 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9710 & VINT(204)=PMAS(24,1)
9711 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9712 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9713 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9714 & VINT(204)=VINT(201)
9716 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9719 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9720 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9721 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9722 VRN=PYR(0)*SIGT(0,0,5)
9723 IF(MINT(101).LE.1) THEN
9730 IF(MINT(102).LE.1) THEN
9741 VRN=VRN-SIGT(I1,I2,5)
9742 IF(VRN.LE.0D0) GOTO 190
9745 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9746 IF(MINT(102).GE.2) MINT(104)=KFV2
9750 C...Elastic scattering or single or double diffractive scattering.
9752 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9757 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9759 VRN=PYR(0)*SIGT(0,0,JJ)
9760 IF(MINT(101).LE.1) THEN
9767 IF(MINT(102).LE.1) THEN
9778 VRN=VRN-SIGT(I1,I2,JJ)
9779 IF(VRN.LE.0D0) GOTO 220
9782 220 IF(MINT(101).GE.2) THEN
9786 IF(MINT(102).GE.2) THEN
9794 C...Select mass for GVMD states (rejecting previous assignment).
9796 Q1S=4D0*VINT(154)**2
9800 IF(MINT(106+JT).EQ.3) THEN
9802 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9803 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9804 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9805 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9808 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9809 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9814 C...Side/sides of diffractive system.
9817 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9818 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9820 C...Find masses of particles and minimal masses of diffractive states.
9823 VINT(68+JT)=PDIF(JT)
9824 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9831 SMRES1=(PMM(1)+PMRC)**2
9832 SMRES2=(PMM(2)+PMRC)**2
9834 C...Find elastic slope and lower limit diffractive slope.
9835 IHA=MAX(2,IABS(MINT(103))/110)
9837 IHB=MAX(2,IABS(MINT(104))/110)
9840 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9841 ELSEIF(ISUB.EQ.92) THEN
9842 BMN=MAX(2D0,2D0*BHAD(IHB))
9843 ELSEIF(ISUB.EQ.93) THEN
9844 BMN=MAX(2D0,2D0*BHAD(IHA))
9845 ELSEIF(ISUB.EQ.94) THEN
9849 C...Determine maximum possible t range and coefficient of generation.
9850 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9851 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9852 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9853 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9854 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9855 & (SQM1*SQM4-SQM2*SQM3)/SH
9856 THL=-0.5D0*(THA+THB)
9858 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9860 C...Select diffractive mass/masses according to dm^2/m^2.
9864 IF(MINT(16+JT).EQ.0) THEN
9868 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9869 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9875 C..Additional mass factors, including resonance enhancement.
9876 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9877 IF(LOOP3.LT.100) GOTO 260
9881 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9882 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9883 ELSEIF(ISUB.EQ.93) THEN
9884 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9885 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9886 ELSEIF(ISUB.EQ.94) THEN
9887 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9888 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9889 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9890 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9893 C...Select t according to exp(Bmn*t) and correct to right slope.
9894 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9897 BADD=2D0*ALP*LOG(SH/SQM3)
9898 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9899 ELSEIF(ISUB.EQ.93) THEN
9900 BADD=2D0*ALP*LOG(SH/SQM4)
9901 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9902 ELSEIF(ISUB.EQ.94) THEN
9903 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9905 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9908 C...Check whether m^2 and t choices are consistent.
9909 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9910 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9911 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9912 IF(THB.LE.1D-8) GOTO 260
9913 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9914 & (SQM1*SQM4-SQM2*SQM3)/SH
9915 THLM=-0.5D0*(THA+THB)
9917 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9919 C...Information to output.
9922 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9924 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9927 VINT(283)=PMM(1)**2/4D0
9928 VINT(284)=PMM(2)**2/4D0
9930 C...Note: in the following, by In is meant the integral over the
9931 C...quantity multiplying coefficient cn.
9932 C...Choose tau according to h1(tau)/tau, where
9933 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9934 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9935 C...I1/I5*c5*1/(tau+tau_R') +
9936 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9937 C...I1/I7*c7*tau/(1.-tau), and
9938 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9939 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9941 IF(MINT(51).NE.0) THEN
9942 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9951 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9952 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9953 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9954 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9956 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9957 & COEF(ISUB,5)) MTAU=6
9958 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9959 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9960 C...Additional check to handle techni-processes with extra resonance
9961 C....Only modify tau treatment
9962 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9964 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9965 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9966 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9967 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9968 & +COEFX(ISUB,1)) MTAU=9
9970 CALL PYKMAP(1,MTAU,PYR(0))
9972 C...2 -> 3, 4 processes:
9973 C...Choose tau' according to h4(tau,tau')/tau', where
9974 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9975 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9976 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9978 IF(MINT(51).NE.0) THEN
9979 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9988 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9989 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9990 CALL PYKMAP(4,MTAUP,PYR(0))
9993 C...Choose y* according to h2(y*), where
9994 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9995 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9996 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9997 C...and c1 + c2 + c3 + c4 + c5 = 1.
9999 IF(MINT(51).NE.0) THEN
10000 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10001 IF(MFAIL.EQ.1) THEN
10009 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10010 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10011 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
10012 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
10013 & COEF(ISUB,11)) MYST=5
10014 CALL PYKMAP(2,MYST,PYR(0))
10016 C...2 -> 2 processes:
10017 C...Choose cos(theta-hat) (cth) according to h3(cth), where
10018 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
10019 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
10020 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
10021 C...and c0 + c1 + c2 + c3 + c4 = 1.
10023 IF(MINT(51).NE.0) THEN
10024 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10025 IF(MFAIL.EQ.1) THEN
10031 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
10034 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
10035 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
10036 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
10037 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
10038 & COEF(ISUB,16)) MCTH=5
10039 CALL PYKMAP(3,MCTH,PYR(0))
10042 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
10043 IF(ISTSB.EQ.5) THEN
10044 CALL PYKMAP(5,0,0D0)
10045 IF(MINT(51).NE.0) THEN
10046 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10047 IF(MFAIL.EQ.1) THEN
10055 C...DIS as f + gamma* -> f process: set dummy values.
10056 ELSEIF(ISTSB.EQ.8) THEN
10063 C...Low-pT or multiple interactions (first semihard interaction).
10064 ELSEIF(ISTSB.EQ.9) THEN
10065 IF(MINT(35).LE.1) CALL PYMULT(3)
10066 IF(MINT(35).GE.2) CALL PYMIGN(3)
10069 C...Study user-defined process: kinematics plus weight.
10070 ELSEIF(ISTSB.EQ.11) THEN
10071 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
10072 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
10077 IF(MINT(82).EQ.1) THEN
10078 NGEN(0,1)=NGEN(0,1)-1
10079 NGEN(ISUB,1)=NGEN(ISUB,1)-1
10081 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10085 C...Extract cross section event weight.
10086 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
10089 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
10091 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
10092 VINT(97)=SIGN(1D0,XWGTUP)
10094 VINT(97)=1D-9*XWGTUP
10097 C...Construct 'trivial' kinematical variables needed.
10100 VINT(41)=PUP(4,1)/EBMUP(1)
10101 VINT(42)=PUP(4,2)/EBMUP(2)
10102 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10103 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10104 & '(listing follows):')
10107 VINT(21)=VINT(41)*VINT(42)
10108 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10109 VINT(44)=VINT(21)*VINT(2)
10110 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10112 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10113 VINT(56)=VINT(55)**2
10117 C...Construct other kinematical variables needed (approximately).
10120 VINT(45)=-0.5D0*VINT(44)
10121 VINT(46)=-0.5D0*VINT(44)
10130 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10131 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10133 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10134 & '(PYRAND:) unacceptable ISTUP code for particles')
10135 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10136 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10137 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10140 VINT(47)=SQRT(VINT(48))
10143 C...Choose azimuthal angle.
10145 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10147 C...Check against user cuts on kinematics at parton level.
10149 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10150 IF(MINT(51).NE.0) THEN
10151 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10152 IF(MFAIL.EQ.1) THEN
10158 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10160 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10161 & CALL PYKCUT(MCUT)
10163 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10164 IF(MFAIL.EQ.1) THEN
10172 IF(ISTSB.LE.10) THEN
10173 C... If internal process, call PYSIGH
10174 CALL PYSIGH(NCHN,SIGS)
10176 C... If external process, still have to set MI starting scale
10177 IF (MSTP(86).EQ.1) THEN
10178 C... Limit phase space by xT2 of hard interaction
10179 C... (gives undercounting of MI when ext proc != dijets)
10182 C... All accessible phase space allowed
10183 C... (gives double counting of MI when ext proc = dijets)
10184 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10186 VINT(62)=0.25D0*XT2GMX*VINT(2)
10187 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10191 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10193 C...Multiply cross section by lepton -> photon flux factor.
10194 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10197 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10199 SIGLPT=WTGAGA*SIGLPT
10202 C...Multiply cross-section by user-defined weights.
10203 IF(MSTP(173).EQ.1) THEN
10204 SIGS=PARP(173)*SIGS
10206 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10208 SIGLPT=PARP(173)*SIGLPT
10214 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10215 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10216 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10219 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10222 C...Calculations for Monte Carlo estimate of all cross-sections.
10223 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10224 IF(MSTP(142).LE.1) THEN
10225 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10227 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10229 ELSEIF(MINT(82).EQ.1) THEN
10230 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10232 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10233 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10235 C...Multiple interactions: store results of cross-section calculation.
10236 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10238 IF(MINT(35).LE.1) CALL PYMULT(4)
10239 IF(MINT(35).GE.2) CALL PYMIGN(4)
10242 C...Ratio of actual to maximum cross section.
10243 IF(ISTSB.NE.11) THEN
10244 VIOL=SIGSWT/XSEC(ISUB,1)
10245 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10246 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10247 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10248 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10249 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10254 C...Check that weight not negative.
10255 IF(MSTP(123).LE.0) THEN
10256 IF(VIOL.LT.-1D-3) THEN
10257 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10258 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10259 & VINT(22),VINT(23),VINT(26)
10263 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10265 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10266 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10267 & VINT(22),VINT(23),VINT(26)
10271 C...Weighting using estimate of maximum of differential cross-section.
10273 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10274 IF(VIOL.LT.PYR(0)) THEN
10275 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10276 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10279 ELSEIF(MFAIL.EQ.0) THEN
10280 RATND=SIGLPT/XSEC(95,1)
10282 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10283 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10284 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10285 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10289 IF(VIOL.LT.PYR(0)) THEN
10292 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10293 IF(VIOL.LT.PYR(0)) THEN
10295 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10299 RATND=SIGLPT/XSEC(95,1)
10300 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10302 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10306 IF(VIOL.LT.PYR(0)) THEN
10307 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10312 C...Check for possible violation of estimated maximum of differential
10313 C...cross-section used in weighting.
10314 IF(MSTP(123).LE.0) THEN
10315 IF(VIOL.GT.1D0) THEN
10316 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10317 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10318 & VINT(22),VINT(23),VINT(26)
10321 ELSEIF(MSTP(123).EQ.1) THEN
10322 IF(VIOL.GT.VINT(108)) THEN
10324 IF(VIOL.GT.1.0001D0) THEN
10326 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10327 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10328 & VINT(22),VINT(23),VINT(26)
10331 ELSEIF(VIOL.GT.VINT(108)) THEN
10333 IF(VIOL.GT.1D0) THEN
10335 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10336 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10338 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10339 IF(KFPR(ISUB,1).LE.9) THEN
10340 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10341 & XMAXUP(KFPR(ISUB,1))
10342 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10343 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10344 & XMAXUP(KFPR(ISUB,1))
10346 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10347 & XMAXUP(KFPR(ISUB,1))
10350 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10351 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10352 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10353 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10354 & XSEC(0,1)=XSEC(0,1)+XDIF
10355 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10356 & VINT(22),VINT(23),VINT(26)
10358 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10359 ELSEIF(ISUB.LE.99) THEN
10360 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10362 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10369 C...Multiple interactions: choose impact parameter (if not already done).
10370 IF(MINT(39).EQ.0) VINT(148)=1D0
10371 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10372 &MSTP(82).GE.3) THEN
10373 IF(MINT(35).LE.1) CALL PYMULT(5)
10374 IF(MINT(35).GE.2) CALL PYMIGN(5)
10375 IF(VINT(150).LT.PYR(0)) THEN
10376 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10377 IF(MFAIL.EQ.1) THEN
10384 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10385 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10386 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10387 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10389 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10391 C...Choose flavour of reacting partons (and subprocess).
10392 IF(ISTSB.GE.11) GOTO 320
10395 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10396 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10397 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10398 &PYR(0).GT.RQQBAR)) THEN
10402 MINT(2)=ISIG(ICHN,3)
10403 RSIGS=RSIGS-SIGH(ICHN)
10404 IF(RSIGS.LE.0D0) GOTO 320
10407 C...Multiple interactions: choose qqbar preferentially at small pT.
10408 ELSEIF(ISUB.EQ.96) THEN
10409 MINT(105)=MINT(103)
10410 MINT(109)=MINT(107)
10411 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10412 MINT(105)=MINT(104)
10413 MINT(109)=MINT(108)
10414 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10417 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10419 C...Low-pT: choose string drawing configuration.
10425 IF(RSIGS.GT.1D0) MINT(2)=2
10426 IF(RSIGS.GT.2D0) MINT(2)=3
10429 C...Reassign QCD process. Partons before initial state radiation.
10430 320 IF(MINT(2).GT.10) THEN
10432 MINT(2)=MOD(MINT(2),10)
10434 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10445 C...Calculate x value of photon for parton inside photon inside e.
10450 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10451 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10452 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10453 IF(MSPLI.EQ.2) THEN
10457 MINT(105)=MINT(102+JT)
10458 MINT(109)=MINT(106+JT)
10459 VINT(120)=VINT(2+JT)
10461 C.... Store side in MINT(124)
10464 IF(MSTP(57).LE.1) THEN
10465 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10467 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10470 IF(MSTP(13).EQ.2) THEN
10471 Q2PMS=Q2HRD/PMAS(11,1)**2
10472 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10474 330 XE=XHRD**PYR(0)
10475 XG=MIN(1D0-1D-10,XHRD/XE)
10476 IF(MSTP(57).LE.1) THEN
10477 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10479 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10481 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10482 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10483 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10487 XSFX(JT,KFLS)=XPQ(KFLS)
10492 C...Pick scale where photon is resolved.
10496 IF(MINT(107).EQ.3) THEN
10497 IF(MSTP(66).EQ.1) THEN
10498 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10499 ELSEIF(MSTP(66).EQ.2) THEN
10501 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10502 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10503 Q2INT=SQRT(Q0S*Q2EFF)
10504 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10505 ELSEIF(MSTP(66).EQ.3) THEN
10506 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10507 ELSEIF(MSTP(66).GE.4) THEN
10508 PS=0.25D0*VINT(3)**2
10509 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10510 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10514 IF(MINT(108).EQ.3) THEN
10515 IF(MSTP(66).EQ.1) THEN
10516 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10517 ELSEIF(MSTP(66).EQ.2) THEN
10519 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10520 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10521 Q2INT=SQRT(Q0S*Q2EFF)
10522 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10523 ELSEIF(MSTP(66).EQ.3) THEN
10524 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10525 ELSEIF(MSTP(66).GE.4) THEN
10526 PS=0.25D0*VINT(4)**2
10527 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10528 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10531 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10533 C...Format statements for differential cross-section maximum violations.
10534 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10535 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10536 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10537 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10538 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10540 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10541 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10542 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10544 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10545 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10546 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10547 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10548 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10549 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10554 C*********************************************************************
10557 C...Finds outgoing flavours and event type; sets up the kinematics
10558 C...and colour flow of the hard scattering
10562 C...Double precision and integer declarations
10563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10564 IMPLICIT INTEGER(I-N)
10565 INTEGER PYK,PYCHGE,PYCOMP
10566 C...Parameter statement to help give large particle numbers.
10567 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10568 &KEXCIT=4000000,KDIMEN=5000000)
10569 C...Parameter statement for maximum size of showers.
10570 PARAMETER (MAXNUR=1000)
10572 C...User process event common block.
10574 PARAMETER (MAXNUP=500)
10575 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10576 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10577 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10578 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10579 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10583 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10584 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10585 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10586 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10587 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10588 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10589 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10590 COMMON/PYINT1/MINT(400),VINT(400)
10591 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10592 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10593 COMMON/PYINT4/MWID(500),WIDS(500,5)
10594 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10595 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10596 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10597 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10598 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10599 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10600 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10602 C...Local arrays and saved variables
10603 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10604 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10605 INTEGER IOKFLA(6),IIFLAV
10606 C...UED related declarations:
10607 C...equivalences between ordered particles (451->475)
10608 C...and UED particle code (5 000 000 + id)
10609 DIMENSION IUEDEQ(475),MUED(2)
10610 DATA (IUEDEQ(I),I=451,475)/
10611 & 6100001,6100002,6100003,6100004,6100005,6100006,
10612 & 5100001,5100002,5100003,5100004,5100005,5100006,
10613 & 6100011,6100013,6100015,
10614 & 5100012,5100011,5100014,5100013,5100016,5100015,
10615 & 5100021,5100022,5100023,5100024/
10618 C...Read out process
10622 C...Restore information for low-pT processes
10623 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10625 100 VINT(J)=VINTSV(J)
10628 C...Convert H' or A process into equivalent H one
10631 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10632 &ISUB.LE.190)) THEN
10634 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10636 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10637 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10638 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10639 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10640 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10641 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10642 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10643 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10644 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10645 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10646 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10647 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10650 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10652 C...Convert bottomonium process into equivalent charmonium ones.
10653 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10655 C...Choice of subprocess, number of documentation lines
10657 IF(ISUB.EQ.95) IDOC=8
10658 IF(ISET(ISUB).EQ.5) IDOC=9
10659 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10661 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10670 C...Reset K, P and V vectors. Store incoming particles
10671 DO 120 JT=1,MSTP(126)+100
10673 IF(I.GT.MSTU(4)) GOTO 120
10685 P(I,J)=VINT(285+5*JT+J)
10691 C...Store incoming partons in their CM-frame. Save pdf value.
10694 SHP=VINT(26)*VINT(2)
10697 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10702 K(I,3)=MINT(83)+2+JT
10703 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10704 P(I,4)=0.5D0*SHUSER
10705 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10706 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10712 C...Copy incoming partons to documentation lines
10724 C...Choose new quark/lepton flavour for relevant annihilation graphs
10725 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10726 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10727 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10729 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10730 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10731 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10732 DO 190 I=1,MDCY(IGLGA,3)
10733 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10734 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10735 IF(RKFL.LE.0D0) GOTO 200
10738 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10739 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10740 IF(KFLF.GE.4) GOTO 180
10741 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10742 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10745 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10746 & OR.ISUB.EQ.316) THEN
10749 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10750 & .AND.IABS(KFLF).GE.3) THEN
10751 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10753 FACCIB=VINT(46)**2/RTCM(41)**4
10754 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10755 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10758 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10759 IF(KFLF.EQ.5) GOTO 180
10760 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10761 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10762 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10763 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10767 C...Final state flavours and colour flow: default values
10774 KCS=ISIGN(1,MINT(15))
10776 IF(ISET(ISUB).EQ.11) THEN
10777 C...User-defined processes: find products
10780 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10781 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10782 MINT(21+IUP)=IDUP(IUP)
10783 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10784 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10785 ELSEIF(IDUP(IUP).EQ.0) THEN
10788 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10792 ELSEIF(ISUB.LE.10) THEN
10794 C...f + fbar -> gamma*/Z0
10797 ELSEIF(ISUB.EQ.2) THEN
10798 C...f + fbar' -> W+/-
10799 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10800 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10801 KFRES=ISIGN(24,KCH1+KCH2)
10803 ELSEIF(ISUB.EQ.3) THEN
10804 C...f + fbar -> h0 (or H0, or A0)
10807 ELSEIF(ISUB.EQ.4) THEN
10808 C...gamma + W+/- -> W+/-
10810 ELSEIF(ISUB.EQ.5) THEN
10815 PMQ(1)=PYMASS(MINT(21))
10816 PMQ(2)=PYMASS(MINT(22))
10817 220 JT=INT(1.5D0+PYR(0))
10818 ZMIN=2D0*PMQ(JT)/SHPR
10819 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10820 & (SHPR*(SHPR-PMQ(3-JT)))
10821 ZMAX=MIN(1D0-XH,ZMAX)
10822 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10823 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10824 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10825 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10826 IF(SQC1.LT.1D-8) GOTO 220
10828 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10829 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10830 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10831 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10832 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10833 IF(SQC1.LT.1D-8) GOTO 220
10835 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10836 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10837 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10838 PHIR=PARU(2)*PYR(0)
10840 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10841 & SQRT(1D0-CTHE(2)**2)*CPHI
10843 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10844 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10845 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10846 & PMQ(3-JT)**2/SHP))
10847 ZMIN=2D0*PMQ(3-JT)/SHPR
10848 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10849 ZMAX=MIN(1D0-XH,ZMAX)
10850 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10854 ELSEIF(ISUB.EQ.6) THEN
10855 C...Z0 + W+/- -> W+/-
10857 ELSEIF(ISUB.EQ.7) THEN
10860 ELSEIF(ISUB.EQ.8) THEN
10867 RVCKM=VINT(180+I)*PYR(0)
10870 IPM=(5-ISIGN(1,I))/2
10872 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10873 MINT(20+JT)=ISIGN(IB,I)
10874 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10875 IF(RVCKM.LE.0D0) GOTO 250
10878 IB=2*((IA+1)/2)-1+MOD(IA,2)
10879 MINT(20+JT)=ISIGN(IB,I)
10881 250 PMQ(JT)=PYMASS(MINT(20+JT))
10883 JT=INT(1.5D0+PYR(0))
10884 ZMIN=2D0*PMQ(JT)/SHPR
10885 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10886 & (SHPR*(SHPR-PMQ(3-JT)))
10887 ZMAX=MIN(1D0-XH,ZMAX)
10888 IF(ZMIN.GE.ZMAX) GOTO 230
10889 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10890 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10891 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10892 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10893 IF(SQC1.LT.1D-8) GOTO 230
10895 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10896 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10897 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10898 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10899 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10900 IF(SQC1.LT.1D-8) GOTO 230
10902 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10903 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10904 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10905 PHIR=PARU(2)*PYR(0)
10907 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10908 & SQRT(1D0-CTHE(2)**2)*CPHI
10910 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10911 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10912 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10913 & PMQ(3-JT)**2/SHP))
10914 ZMIN=2D0*PMQ(3-JT)/SHPR
10915 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10916 ZMAX=MIN(1D0-XH,ZMAX)
10917 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10921 ELSEIF(ISUB.EQ.10) THEN
10922 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10923 IF(MINT(2).EQ.1) THEN
10926 C...W exchange: need to mix flavours according to CKM matrix
10931 RVCKM=VINT(180+I)*PYR(0)
10934 IPM=(5-ISIGN(1,I))/2
10936 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10937 MINT(20+JT)=ISIGN(IB,I)
10938 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10939 IF(RVCKM.LE.0D0) GOTO 280
10942 IB=2*((IA+1)/2)-1+MOD(IA,2)
10943 MINT(20+JT)=ISIGN(IB,I)
10950 ELSEIF(ISUB.LE.20) THEN
10951 IF(ISUB.EQ.11) THEN
10952 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10954 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10956 ELSEIF(ISUB.EQ.12) THEN
10957 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10958 MINT(21)=ISIGN(KFLF,MINT(15))
10962 ELSEIF(ISUB.EQ.13) THEN
10963 C...f + fbar -> g + g; th arbitrary
10968 ELSEIF(ISUB.EQ.14) THEN
10969 C...f + fbar -> g + gamma; th arbitrary
10970 IF(PYR(0).GT.0.5D0) JS=2
10975 ELSEIF(ISUB.EQ.15) THEN
10976 C...f + fbar -> g + Z0; th arbitrary
10977 IF(PYR(0).GT.0.5D0) JS=2
10982 ELSEIF(ISUB.EQ.16) THEN
10983 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10984 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10985 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10986 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10988 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10991 ELSEIF(ISUB.EQ.17) THEN
10992 C...f + fbar -> g + h0; th arbitrary
10993 IF(PYR(0).GT.0.5D0) JS=2
10998 ELSEIF(ISUB.EQ.18) THEN
10999 C...f + fbar -> gamma + gamma; th arbitrary
11003 ELSEIF(ISUB.EQ.19) THEN
11004 C...f + fbar -> gamma + Z0; th arbitrary
11005 IF(PYR(0).GT.0.5D0) JS=2
11009 ELSEIF(ISUB.EQ.20) THEN
11010 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
11011 C...(p(fbar')-p(W+))**2
11012 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11013 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11014 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11016 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11019 ELSEIF(ISUB.LE.30) THEN
11020 IF(ISUB.EQ.21) THEN
11021 C...f + fbar -> gamma + h0; th arbitrary
11022 IF(PYR(0).GT.0.5D0) JS=2
11026 ELSEIF(ISUB.EQ.22) THEN
11027 C...f + fbar -> Z0 + Z0; th arbitrary
11031 ELSEIF(ISUB.EQ.23) THEN
11032 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11033 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11034 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11035 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11037 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11039 ELSEIF(ISUB.EQ.24) THEN
11040 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
11041 IF(PYR(0).GT.0.5D0) JS=2
11045 ELSEIF(ISUB.EQ.25) THEN
11046 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
11047 MINT(21)=-ISIGN(24,MINT(15))
11050 ELSEIF(ISUB.EQ.26) THEN
11051 C...f + fbar' -> W+/- + h0 (or H0, or A0);
11052 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11053 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11054 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11055 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11056 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
11059 ELSEIF(ISUB.EQ.27) THEN
11060 C...f + fbar -> h0 + h0
11062 ELSEIF(ISUB.EQ.28) THEN
11063 C...f + g -> f + g; th = (p(f)-p(f))**2
11064 IF(MINT(15).EQ.21) JS=2
11066 IF(MINT(15).EQ.21) KCC=KCC+2
11067 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
11068 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
11070 ELSEIF(ISUB.EQ.29) THEN
11071 C...f + g -> f + gamma; th = (p(f)-p(f))**2
11072 IF(MINT(15).EQ.21) JS=2
11075 KCS=ISIGN(1,MINT(14+JS))
11077 ELSEIF(ISUB.EQ.30) THEN
11078 C...f + g -> f + Z0; th = (p(f)-p(f))**2
11079 IF(MINT(15).EQ.21) JS=2
11082 KCS=ISIGN(1,MINT(14+JS))
11085 ELSEIF(ISUB.LE.40) THEN
11086 IF(ISUB.EQ.31) THEN
11087 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
11088 IF(MINT(15).EQ.21) JS=2
11091 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11092 RVCKM=VINT(180+I)*PYR(0)
11095 IPM=(5-ISIGN(1,I))/2
11097 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11098 MINT(20+JS)=ISIGN(IB,I)
11099 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11100 IF(RVCKM.LE.0D0) GOTO 300
11103 KCS=ISIGN(1,MINT(14+JS))
11105 ELSEIF(ISUB.EQ.32) THEN
11106 C...f + g -> f + h0; th = (p(f)-p(f))**2
11107 IF(MINT(15).EQ.21) JS=2
11110 KCS=ISIGN(1,MINT(14+JS))
11112 ELSEIF(ISUB.EQ.33) THEN
11113 C...f + gamma -> f + g; th=(p(f)-p(f))**2
11114 IF(MINT(15).EQ.22) JS=2
11117 KCS=ISIGN(1,MINT(14+JS))
11119 ELSEIF(ISUB.EQ.34) THEN
11120 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11121 IF(MINT(15).EQ.22) JS=2
11123 KCS=ISIGN(1,MINT(14+JS))
11125 ELSEIF(ISUB.EQ.35) THEN
11126 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11127 IF(MINT(15).EQ.22) JS=2
11131 ELSEIF(ISUB.EQ.36) THEN
11132 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11133 IF(MINT(15).EQ.22) JS=2
11136 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11138 RVCKM=VINT(180+I)*PYR(0)
11141 IPM=(5-ISIGN(1,I))/2
11143 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11144 MINT(20+JS)=ISIGN(IB,I)
11145 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11146 IF(RVCKM.LE.0D0) GOTO 320
11149 IB=2*((IA+1)/2)-1+MOD(IA,2)
11150 MINT(20+JS)=ISIGN(IB,I)
11154 ELSEIF(ISUB.EQ.37) THEN
11155 C...f + gamma -> f + h0
11157 ELSEIF(ISUB.EQ.38) THEN
11158 C...f + Z0 -> f + g
11160 ELSEIF(ISUB.EQ.39) THEN
11161 C...f + Z0 -> f + gamma
11163 ELSEIF(ISUB.EQ.40) THEN
11164 C...f + Z0 -> f + Z0
11167 ELSEIF(ISUB.LE.50) THEN
11168 IF(ISUB.EQ.41) THEN
11169 C...f + Z0 -> f' + W+/-
11171 ELSEIF(ISUB.EQ.42) THEN
11172 C...f + Z0 -> f + h0
11174 ELSEIF(ISUB.EQ.43) THEN
11175 C...f + W+/- -> f' + g
11177 ELSEIF(ISUB.EQ.44) THEN
11178 C...f + W+/- -> f' + gamma
11180 ELSEIF(ISUB.EQ.45) THEN
11181 C...f + W+/- -> f' + Z0
11183 ELSEIF(ISUB.EQ.46) THEN
11184 C...f + W+/- -> f' + W+/-
11186 ELSEIF(ISUB.EQ.47) THEN
11187 C...f + W+/- -> f' + h0
11189 ELSEIF(ISUB.EQ.48) THEN
11190 C...f + h0 -> f + g
11192 ELSEIF(ISUB.EQ.49) THEN
11193 C...f + h0 -> f + gamma
11195 ELSEIF(ISUB.EQ.50) THEN
11196 C...f + h0 -> f + Z0
11199 ELSEIF(ISUB.LE.60) THEN
11200 IF(ISUB.EQ.51) THEN
11201 C...f + h0 -> f' + W+/-
11203 ELSEIF(ISUB.EQ.52) THEN
11204 C...f + h0 -> f + h0
11206 ELSEIF(ISUB.EQ.53) THEN
11207 C...g + g -> f + fbar; th arbitrary
11208 KCS=(-1)**INT(1.5D0+PYR(0))
11209 MINT(21)=ISIGN(KFLF,KCS)
11213 ELSEIF(ISUB.EQ.54) THEN
11214 C...g + gamma -> f + fbar; th arbitrary
11215 KCS=(-1)**INT(1.5D0+PYR(0))
11216 MINT(21)=ISIGN(KFLF,KCS)
11219 IF(MINT(16).EQ.21) KCC=28
11221 ELSEIF(ISUB.EQ.55) THEN
11222 C...g + Z0 -> f + fbar
11224 ELSEIF(ISUB.EQ.56) THEN
11225 C...g + W+/- -> f + fbar'
11227 ELSEIF(ISUB.EQ.57) THEN
11228 C...g + h0 -> f + fbar
11230 ELSEIF(ISUB.EQ.58) THEN
11231 C...gamma + gamma -> f + fbar; th arbitrary
11232 KCS=(-1)**INT(1.5D0+PYR(0))
11233 MINT(21)=ISIGN(KFLF,KCS)
11237 ELSEIF(ISUB.EQ.59) THEN
11238 C...gamma + Z0 -> f + fbar
11240 ELSEIF(ISUB.EQ.60) THEN
11241 C...gamma + W+/- -> f + fbar'
11244 ELSEIF(ISUB.LE.70) THEN
11245 IF(ISUB.EQ.61) THEN
11246 C...gamma + h0 -> f + fbar
11248 ELSEIF(ISUB.EQ.62) THEN
11249 C...Z0 + Z0 -> f + fbar
11251 ELSEIF(ISUB.EQ.63) THEN
11252 C...Z0 + W+/- -> f + fbar'
11254 ELSEIF(ISUB.EQ.64) THEN
11255 C...Z0 + h0 -> f + fbar
11257 ELSEIF(ISUB.EQ.65) THEN
11258 C...W+ + W- -> f + fbar
11260 ELSEIF(ISUB.EQ.66) THEN
11261 C...W+/- + h0 -> f + fbar'
11263 ELSEIF(ISUB.EQ.67) THEN
11264 C...h0 + h0 -> f + fbar
11266 ELSEIF(ISUB.EQ.68) THEN
11267 C...g + g -> g + g; th arbitrary
11269 KCS=(-1)**INT(1.5D0+PYR(0))
11271 ELSEIF(ISUB.EQ.69) THEN
11272 C...gamma + gamma -> W+ + W-; th arbitrary
11277 ELSEIF(ISUB.EQ.70) THEN
11278 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11279 IF(MINT(15).EQ.22) MINT(21)=23
11280 IF(MINT(16).EQ.22) MINT(22)=23
11284 ELSEIF(ISUB.LE.80) THEN
11285 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11286 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11290 PMQ(1)=PYMASS(MINT(21))
11291 PMQ(2)=PYMASS(MINT(22))
11292 330 JT=INT(1.5D0+PYR(0))
11293 ZMIN=2D0*PMQ(JT)/SHPR
11294 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11295 & (SHPR*(SHPR-PMQ(3-JT)))
11296 ZMAX=MIN(1D0-XH,ZMAX)
11297 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11298 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11299 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11300 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11301 IF(SQC1.LT.1D-8) GOTO 330
11303 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11304 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11305 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11306 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11307 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11308 IF(SQC1.LT.1D-8) GOTO 330
11310 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11311 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11312 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11313 PHIR=PARU(2)*PYR(0)
11315 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11316 & SQRT(1D0-CTHE(2)**2)*CPHI
11318 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11319 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11320 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11321 & PMQ(3-JT)**2/SHP))
11322 ZMIN=2D0*PMQ(3-JT)/SHPR
11323 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11324 ZMAX=MIN(1D0-XH,ZMAX)
11325 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11328 ELSEIF(ISUB.EQ.73) THEN
11329 C...Z0 + W+/- -> Z0 + W+/-
11336 RVCKM=VINT(180+I)*PYR(0)
11339 IPM=(5-ISIGN(1,I))/2
11341 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11342 MINT(20+JT)=ISIGN(IB,I)
11343 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11344 IF(RVCKM.LE.0D0) GOTO 360
11347 IB=2*((IA+1)/2)-1+MOD(IA,2)
11348 MINT(20+JT)=ISIGN(IB,I)
11350 360 PMQ(JT)=PYMASS(MINT(20+JT))
11351 MINT(23-JT)=MINT(17-JT)
11352 PMQ(3-JT)=PYMASS(MINT(23-JT))
11353 JT=INT(1.5D0+PYR(0))
11354 ZMIN=2D0*PMQ(JT)/SHPR
11355 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11356 & (SHPR*(SHPR-PMQ(3-JT)))
11357 ZMAX=MIN(1D0-XH,ZMAX)
11358 IF(ZMIN.GE.ZMAX) GOTO 340
11359 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11360 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11361 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11362 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11363 IF(SQC1.LT.1D-8) GOTO 340
11365 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11366 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11367 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11368 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11369 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11370 IF(SQC1.LT.1D-8) GOTO 340
11372 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11373 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11374 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11375 PHIR=PARU(2)*PYR(0)
11377 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11378 & SQRT(1D0-CTHE(2)**2)*CPHI
11380 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11381 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11382 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11383 & PMQ(3-JT)**2/SHP))
11384 ZMIN=2D0*PMQ(3-JT)/SHPR
11385 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11386 ZMAX=MIN(1D0-XH,ZMAX)
11387 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11390 ELSEIF(ISUB.EQ.74) THEN
11391 C...Z0 + h0 -> Z0 + h0
11393 ELSEIF(ISUB.EQ.75) THEN
11394 C...W+ + W- -> gamma + gamma
11396 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11397 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11403 RVCKM=VINT(180+I)*PYR(0)
11406 IPM=(5-ISIGN(1,I))/2
11408 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11409 MINT(20+JT)=ISIGN(IB,I)
11410 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11411 IF(RVCKM.LE.0D0) GOTO 390
11414 IB=2*((IA+1)/2)-1+MOD(IA,2)
11415 MINT(20+JT)=ISIGN(IB,I)
11417 390 PMQ(JT)=PYMASS(MINT(20+JT))
11419 JT=INT(1.5D0+PYR(0))
11420 ZMIN=2D0*PMQ(JT)/SHPR
11421 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11422 & (SHPR*(SHPR-PMQ(3-JT)))
11423 ZMAX=MIN(1D0-XH,ZMAX)
11424 IF(ZMIN.GE.ZMAX) GOTO 370
11425 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11426 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11427 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11428 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11429 IF(SQC1.LT.1D-8) GOTO 370
11431 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11432 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11433 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11434 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11435 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11436 IF(SQC1.LT.1D-8) GOTO 370
11438 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11439 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11440 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11441 PHIR=PARU(2)*PYR(0)
11443 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11444 & SQRT(1D0-CTHE(2)**2)*CPHI
11446 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11447 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11448 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11449 & PMQ(3-JT)**2/SHP))
11450 ZMIN=2D0*PMQ(3-JT)/SHPR
11451 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11452 ZMAX=MIN(1D0-XH,ZMAX)
11453 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11456 ELSEIF(ISUB.EQ.78) THEN
11457 C...W+/- + h0 -> W+/- + h0
11459 ELSEIF(ISUB.EQ.79) THEN
11460 C...h0 + h0 -> h0 + h0
11462 ELSEIF(ISUB.EQ.80) THEN
11463 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11464 IF(MINT(15).EQ.22) JS=2
11467 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11469 MINT(20+JS)=ISIGN(IB,I)
11473 ELSEIF(ISUB.LE.90) THEN
11474 IF(ISUB.EQ.81) THEN
11475 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11476 MINT(21)=ISIGN(MINT(55),MINT(15))
11480 ELSEIF(ISUB.EQ.82) THEN
11481 C...g + g -> Q + Qbar; th arbitrary
11482 KCS=(-1)**INT(1.5D0+PYR(0))
11483 MINT(21)=ISIGN(MINT(55),KCS)
11487 ELSEIF(ISUB.EQ.83) THEN
11488 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11490 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11492 IF(KFAOLD.GT.10) THEN
11493 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11495 RCKM=VINT(180+KFOLD)*PYR(0)
11496 IPM=(5-ISIGN(1,KFOLD))/2
11497 KFANEW=-MOD(KFAOLD+1,2)
11498 410 KFANEW=KFANEW+2
11499 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11500 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11501 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11502 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11503 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11504 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11506 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11508 IF(MINT(2).EQ.1) THEN
11509 MINT(21)=ISIGN(MINT(55),MINT(15))
11510 MINT(22)=ISIGN(KFANEW,MINT(16))
11512 MINT(21)=ISIGN(KFANEW,MINT(15))
11513 MINT(22)=ISIGN(MINT(55),MINT(16))
11518 ELSEIF(ISUB.EQ.84) THEN
11519 C...g + gamma -> Q + Qbar; th arbitary
11520 KCS=(-1)**INT(1.5D0+PYR(0))
11521 MINT(21)=ISIGN(MINT(55),KCS)
11524 IF(MINT(16).EQ.21) KCC=28
11526 ELSEIF(ISUB.EQ.85) THEN
11527 C...gamma + gamma -> F + Fbar; th arbitary
11528 KCS=(-1)**INT(1.5D0+PYR(0))
11529 MINT(21)=ISIGN(MINT(56),KCS)
11533 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11534 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11535 MINT(21)=KFPR(ISUB,1)
11536 MINT(22)=KFPR(ISUB,2)
11538 KCS=(-1)**INT(1.5D0+PYR(0))
11541 ELSEIF(ISUB.LE.100) THEN
11542 IF(ISUB.EQ.95) THEN
11543 C...Low-pT ( = energyless g + g -> g + g)
11545 KCS=(-1)**INT(1.5D0+PYR(0))
11547 ELSEIF(ISUB.EQ.96) THEN
11548 C...Multiple interactions (should be reassigned to QCD process)
11551 ELSEIF(ISUB.LE.110) THEN
11552 IF(ISUB.EQ.101) THEN
11553 C...g + g -> gamma*/Z0
11557 ELSEIF(ISUB.EQ.102) THEN
11558 C...g + g -> h0 (or H0, or A0)
11562 ELSEIF(ISUB.EQ.103) THEN
11563 C...gamma + gamma -> h0 (or H0, or A0)
11567 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11568 C...g + g -> chi_0c or chi_2c.
11572 ELSEIF(ISUB.EQ.106) THEN
11573 C...g + g -> J/Psi + gamma
11574 MINT(21)=KFPR(ISUB,1)
11575 MINT(22)=KFPR(ISUB,2)
11578 ELSEIF(ISUB.EQ.107) THEN
11579 C...g + gamma -> J/Psi + g
11580 MINT(21)=KFPR(ISUB,1)
11581 MINT(22)=KFPR(ISUB,2)
11583 IF(MINT(16).EQ.22) KCC=33
11585 ELSEIF(ISUB.EQ.108) THEN
11586 C...gamma + gamma -> J/Psi + gamma
11587 MINT(21)=KFPR(ISUB,1)
11588 MINT(22)=KFPR(ISUB,2)
11590 ELSEIF(ISUB.EQ.110) THEN
11591 C...f + fbar -> gamma + h0; th arbitrary
11592 IF(PYR(0).GT.0.5D0) JS=2
11597 ELSEIF(ISUB.LE.120) THEN
11598 IF(ISUB.EQ.111) THEN
11599 C...f + fbar -> g + h0; th arbitrary
11600 IF(PYR(0).GT.0.5D0) JS=2
11605 ELSEIF(ISUB.EQ.112) THEN
11606 C...f + g -> f + h0; th = (p(f) - p(f))**2
11607 IF(MINT(15).EQ.21) JS=2
11610 KCS=ISIGN(1,MINT(14+JS))
11612 ELSEIF(ISUB.EQ.113) THEN
11613 C...g + g -> g + h0; th arbitrary
11614 IF(PYR(0).GT.0.5D0) JS=2
11617 KCS=(-1)**INT(1.5D0+PYR(0))
11619 ELSEIF(ISUB.EQ.114) THEN
11620 C...g + g -> gamma + gamma; th arbitrary
11621 IF(PYR(0).GT.0.5D0) JS=2
11626 ELSEIF(ISUB.EQ.115) THEN
11627 C...g + g -> g + gamma; th arbitrary
11628 IF(PYR(0).GT.0.5D0) JS=2
11631 KCS=(-1)**INT(1.5D0+PYR(0))
11633 ELSEIF(ISUB.EQ.116) THEN
11634 C...g + g -> gamma + Z0
11636 ELSEIF(ISUB.EQ.117) THEN
11637 C...g + g -> Z0 + Z0
11639 ELSEIF(ISUB.EQ.118) THEN
11640 C...g + g -> W+ + W-
11643 ELSEIF(ISUB.LE.140) THEN
11644 IF(ISUB.EQ.121) THEN
11645 C...g + g -> Q + Qbar + h0
11646 KCS=(-1)**INT(1.5D0+PYR(0))
11647 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11649 KCC=11+INT(0.5D0+PYR(0))
11652 ELSEIF(ISUB.EQ.122) THEN
11653 C...q + qbar -> Q + Qbar + h0
11654 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11659 ELSEIF(ISUB.EQ.123) THEN
11660 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11665 ELSEIF(ISUB.EQ.124) THEN
11666 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11672 RVCKM=VINT(180+I)*PYR(0)
11675 IPM=(5-ISIGN(1,I))/2
11677 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11678 MINT(20+JT)=ISIGN(IB,I)
11679 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11680 IF(RVCKM.LE.0D0) GOTO 430
11683 IB=2*((IA+1)/2)-1+MOD(IA,2)
11684 MINT(20+JT)=ISIGN(IB,I)
11690 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11691 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11692 IF(MINT(15).EQ.22) JS=2
11695 KCS=ISIGN(1,MINT(14+JS))
11697 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11698 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11699 IF(MINT(15).EQ.22) JS=2
11701 KCS=ISIGN(1,MINT(14+JS))
11703 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11704 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11705 KCS=(-1)**INT(1.5D0+PYR(0))
11706 MINT(21)=ISIGN(KFLF,KCS)
11709 IF(MINT(16).EQ.21) KCC=28
11711 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11712 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11713 KCS=(-1)**INT(1.5D0+PYR(0))
11714 MINT(21)=ISIGN(KFLF,KCS)
11720 ELSEIF(ISUB.LE.160) THEN
11721 IF(ISUB.EQ.141) THEN
11722 C...f + fbar -> gamma*/Z0/Z'0
11725 ELSEIF(ISUB.EQ.142) THEN
11726 C...f + fbar' -> W'+/-
11727 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11728 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11729 KFRES=ISIGN(34,KCH1+KCH2)
11731 ELSEIF(ISUB.EQ.143) THEN
11732 C...f + fbar' -> H+/-
11733 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11734 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11735 KFRES=ISIGN(37,KCH1+KCH2)
11737 ELSEIF(ISUB.EQ.144) THEN
11739 KFRES=ISIGN(41,MINT(15)+MINT(16))
11741 ELSEIF(ISUB.EQ.145) THEN
11742 C...q + l -> LQ (leptoquark)
11743 IF(IABS(MINT(16)).LE.8) JS=2
11744 KFRES=ISIGN(42,MINT(14+JS))
11746 KCS=ISIGN(1,MINT(14+JS))
11748 ELSEIF(ISUB.EQ.146) THEN
11749 C...e + gamma -> e* (excited lepton)
11750 IF(MINT(15).EQ.22) JS=2
11751 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11754 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11755 C...q + g -> q* (excited quark)
11756 IF(MINT(15).EQ.21) JS=2
11757 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11759 KCS=ISIGN(1,MINT(14+JS))
11761 ELSEIF(ISUB.EQ.149) THEN
11762 C...g + g -> eta_tc
11765 KCS=(-1)**INT(1.5D0+PYR(0))
11768 ELSEIF(ISUB.LE.200) THEN
11769 IF(ISUB.EQ.161) THEN
11770 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11771 IF(MINT(15).EQ.21) JS=2
11774 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11775 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11776 MINT(20+JS)=ISIGN(IB,I)
11778 KCS=ISIGN(1,MINT(14+JS))
11780 ELSEIF(ISUB.EQ.162) THEN
11781 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11782 IF(MINT(15).EQ.21) JS=2
11783 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11784 KFLQL=KFDP(MDCY(42,2),2)
11785 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11787 KCS=ISIGN(1,MINT(14+JS))
11789 ELSEIF(ISUB.EQ.163) THEN
11790 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11791 KCS=(-1)**INT(1.5D0+PYR(0))
11792 MINT(21)=ISIGN(42,KCS)
11796 ELSEIF(ISUB.EQ.164) THEN
11797 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11798 MINT(21)=ISIGN(42,MINT(15))
11802 ELSEIF(ISUB.EQ.165) THEN
11803 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11804 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11807 ELSEIF(ISUB.EQ.166) THEN
11808 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11809 IF(MOD(MINT(15),2).EQ.0) THEN
11810 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11811 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11813 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11814 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11817 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11818 C...q + q' -> q" + q* (excited quark)
11819 KFQSTR=KFPR(ISUB,2)
11820 KFQEXC=MOD(KFQSTR,KEXCIT)
11822 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11823 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11824 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11828 ELSEIF(ISUB.EQ.169) THEN
11829 C...q + qbar -> e + e* (excited lepton)
11830 KFQSTR=KFPR(ISUB,2)
11831 KFQEXC=MOD(KFQSTR,KEXCIT)
11833 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11834 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11837 ELSEIF(ISUB.EQ.191) THEN
11838 C...f + fbar -> rho_tc0.
11841 ELSEIF(ISUB.EQ.192) THEN
11842 C...f + fbar' -> rho_tc+/-
11843 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11844 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11845 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11847 ELSEIF(ISUB.EQ.193) THEN
11848 C...f + fbar -> omega_tc0.
11851 ELSEIF(ISUB.EQ.194) THEN
11852 C...f + fbar -> f' + fbar' via mixture of s-channel
11853 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11854 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11857 ELSEIF(ISUB.EQ.195) THEN
11858 C...f + fbar' -> f'' + fbar''' via s-channel
11859 C...rho_tc+ th=(p(f)-p(f'))**2
11860 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11861 IF(MOD(MINT(15),2).EQ.0) THEN
11862 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11863 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11865 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11866 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11871 ELSEIF(ISUB.LE.215) THEN
11872 IF(ISUB.EQ.201) THEN
11873 C...f + fbar -> ~e_L + ~e_Lbar
11874 MINT(21)=ISIGN(KSUSY1+11,KCS)
11877 ELSEIF(ISUB.EQ.202) THEN
11878 C...f + fbar -> ~e_R + ~e_Rbar
11879 MINT(21)=ISIGN(KSUSY2+11,KCS)
11882 ELSEIF(ISUB.EQ.203) THEN
11883 C...f + fbar -> ~e_L + ~e_Rbar
11884 IF(MINT(15).LT.0) JS=2
11885 IF(MINT(2).EQ.1) THEN
11886 MINT(20+JS)=KFPR(ISUB,1)
11887 MINT(23-JS)=-KFPR(ISUB,2)
11889 MINT(20+JS)=-KFPR(ISUB,1)
11890 MINT(23-JS)=KFPR(ISUB,2)
11893 ELSEIF(ISUB.EQ.204) THEN
11894 C...f + fbar -> ~mu_L + ~mu_Lbar
11895 MINT(21)=ISIGN(KSUSY1+13,KCS)
11898 ELSEIF(ISUB.EQ.205) THEN
11899 C...f + fbar -> ~mu_R + ~mu_Rbar
11900 MINT(21)=ISIGN(KSUSY2+13,KCS)
11903 ELSEIF(ISUB.EQ.206) THEN
11904 C...f + fbar -> ~mu_L + ~mu_Rbar
11905 IF(MINT(15).LT.0) JS=2
11906 IF(MINT(2).EQ.1) THEN
11907 MINT(20+JS)=KFPR(ISUB,1)
11908 MINT(23-JS)=-KFPR(ISUB,2)
11910 MINT(20+JS)=-KFPR(ISUB,1)
11911 MINT(23-JS)=KFPR(ISUB,2)
11914 ELSEIF(ISUB.EQ.207) THEN
11915 C...f + fbar -> ~tau_1 + ~tau_1bar
11916 MINT(21)=ISIGN(KSUSY1+15,KCS)
11919 ELSEIF(ISUB.EQ.208) THEN
11920 C...f + fbar -> ~tau_2 + ~tau_2bar
11921 MINT(21)=ISIGN(KSUSY2+15,KCS)
11924 ELSEIF(ISUB.EQ.209) THEN
11925 C...f + fbar -> ~tau_1 + ~tau_2bar
11926 IF(MINT(15).LT.0) JS=2
11927 IF(MINT(2).EQ.1) THEN
11928 MINT(20+JS)=KFPR(ISUB,1)
11929 MINT(23-JS)=-KFPR(ISUB,2)
11931 MINT(20+JS)=-KFPR(ISUB,1)
11932 MINT(23-JS)=KFPR(ISUB,2)
11935 ELSEIF(ISUB.EQ.210) THEN
11936 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11937 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11938 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11939 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11940 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11942 ELSEIF(ISUB.EQ.211) THEN
11943 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11944 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11945 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11946 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11947 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11949 ELSEIF(ISUB.EQ.212) THEN
11950 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11951 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11952 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11953 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11954 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11956 ELSEIF(ISUB.EQ.213) THEN
11957 C...f + fbar -> ~nul + ~nulbar
11958 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11961 ELSEIF(ISUB.EQ.214) THEN
11962 C...f + fbar -> ~nutau + ~nutaubar
11963 MINT(21)=ISIGN(KSUSY1+16,KCS)
11967 ELSEIF(ISUB.LE.225) THEN
11968 IF(ISUB.EQ.216) THEN
11969 C...f + fbar -> ~chi01 + ~chi01
11973 ELSEIF(ISUB.EQ.217) THEN
11974 C...f + fbar -> ~chi02 + ~chi02
11978 ELSEIF(ISUB.EQ.218 ) THEN
11979 C...f + fbar -> ~chi03 + ~chi03
11983 ELSEIF(ISUB.EQ.219 ) THEN
11984 C...f + fbar -> ~chi04 + ~chi04
11988 ELSEIF(ISUB.EQ.220 ) THEN
11989 C...f + fbar -> ~chi01 + ~chi02
11990 IF(MINT(15).LT.0) JS=2
11991 C IF(PYR(0).GT.0.5D0) JS=2
11992 MINT(20+JS)=KSUSY1+22
11993 MINT(23-JS)=KSUSY1+23
11995 ELSEIF(ISUB.EQ.221 ) THEN
11996 C...f + fbar -> ~chi01 + ~chi03
11997 IF(MINT(15).LT.0) JS=2
11998 C IF(PYR(0).GT.0.5D0) JS=2
11999 MINT(20+JS)=KSUSY1+22
12000 MINT(23-JS)=KSUSY1+25
12002 ELSEIF(ISUB.EQ.222) THEN
12003 C...f + fbar -> ~chi01 + ~chi04
12004 IF(MINT(15).LT.0) JS=2
12005 C IF(PYR(0).GT.0.5D0) JS=2
12006 MINT(20+JS)=KSUSY1+22
12007 MINT(23-JS)=KSUSY1+35
12009 ELSEIF(ISUB.EQ.223) THEN
12010 C...f + fbar -> ~chi02 + ~chi03
12011 IF(MINT(15).LT.0) JS=2
12012 C IF(PYR(0).GT.0.5D0) JS=2
12013 MINT(20+JS)=KSUSY1+23
12014 MINT(23-JS)=KSUSY1+25
12016 ELSEIF(ISUB.EQ.224) THEN
12017 C...f + fbar -> ~chi02 + ~chi04
12018 IF(MINT(15).LT.0) JS=2
12019 C IF(PYR(0).GT.0.5D0) JS=2
12020 MINT(20+JS)=KSUSY1+23
12021 MINT(23-JS)=KSUSY1+35
12023 ELSEIF(ISUB.EQ.225) THEN
12024 C...f + fbar -> ~chi03 + ~chi04
12025 IF(MINT(15).LT.0) JS=2
12026 C IF(PYR(0).GT.0.5D0) JS=2
12027 MINT(20+JS)=KSUSY1+25
12028 MINT(23-JS)=KSUSY1+35
12031 ELSEIF(ISUB.LE.236) THEN
12032 IF(ISUB.EQ.226) THEN
12033 C...f + fbar -> ~chi+-1 + ~chi-+1
12034 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
12035 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12036 MINT(21)=ISIGN(KSUSY1+24,KCH1)
12039 ELSEIF(ISUB.EQ.227) THEN
12040 C...f + fbar -> ~chi+-2 + ~chi-+2
12041 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12042 MINT(21)=ISIGN(KSUSY1+37,KCH1)
12045 ELSEIF(ISUB.EQ.228) THEN
12046 C...f + fbar -> ~chi+-1 + ~chi-+2
12047 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
12048 C...js=1 if pyr<.5, js=2 if pyr>.5
12049 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
12050 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
12051 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
12052 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
12053 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12055 IF(MINT(2).EQ.1) THEN
12056 MINT(21)= ISIGN(KSUSY1+24,KCH1)
12057 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
12058 c IF(KCH2.EQ.0) JS=2
12060 MINT(21)= ISIGN(KSUSY1+37,KCH1)
12061 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
12063 c IF(KCH2.EQ.1) JS=2
12066 ELSEIF(ISUB.EQ.229) THEN
12067 C...q + qbar' -> ~chi01 + ~chi+-1
12068 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
12069 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12070 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12072 IF(MOD(MINT(15),2).EQ.0) JS=2
12073 MINT(20+JS)=KSUSY1+22
12074 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12076 ELSEIF(ISUB.EQ.230) THEN
12077 C...q + qbar' -> ~chi02 + ~chi+-1
12078 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12079 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12080 IF(MOD(MINT(15),2).EQ.0) JS=2
12081 MINT(20+JS)=KSUSY1+23
12082 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12084 ELSEIF(ISUB.EQ.231) THEN
12085 C...q + qbar' -> ~chi03 + ~chi+-1
12086 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12087 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12088 IF(MOD(MINT(15),2).EQ.0) JS=2
12089 MINT(20+JS)=KSUSY1+25
12090 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12092 ELSEIF(ISUB.EQ.232) THEN
12093 C...q + qbar' -> ~chi04 + ~chi+-1
12094 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12095 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12096 IF(MOD(MINT(15),2).EQ.0) JS=2
12097 MINT(20+JS)=KSUSY1+35
12098 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12100 ELSEIF(ISUB.EQ.233) THEN
12101 C...q + qbar' -> ~chi01 + ~chi+-2
12102 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12103 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12104 IF(MOD(MINT(15),2).EQ.0) JS=2
12105 MINT(20+JS)=KSUSY1+22
12106 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12108 ELSEIF(ISUB.EQ.234) THEN
12109 C...q + qbar' -> ~chi02 + ~chi+-2
12110 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12111 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12112 IF(MOD(MINT(15),2).EQ.0) JS=2
12113 MINT(20+JS)=KSUSY1+23
12114 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12116 ELSEIF(ISUB.EQ.235) THEN
12117 C...q + qbar' -> ~chi03 + ~chi+-2
12118 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12119 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12120 IF(MOD(MINT(15),2).EQ.0) JS=2
12121 MINT(20+JS)=KSUSY1+25
12122 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12124 ELSEIF(ISUB.EQ.236) THEN
12125 C...q + qbar' -> ~chi04 + ~chi+-2
12126 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12127 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12128 IF(MOD(MINT(15),2).EQ.0) JS=2
12129 MINT(20+JS)=KSUSY1+35
12130 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12133 ELSEIF(ISUB.LE.245) THEN
12134 IF(ISUB.EQ.237) THEN
12135 C...q + qbar -> ~chi01 + ~g
12137 IF(PYR(0).GT.0.5D0) JS=2
12138 MINT(20+JS)=KSUSY1+21
12139 MINT(23-JS)=KSUSY1+22
12142 ELSEIF(ISUB.EQ.238) THEN
12143 C...q + qbar -> ~chi02 + ~g
12145 IF(PYR(0).GT.0.5D0) JS=2
12146 MINT(20+JS)=KSUSY1+21
12147 MINT(23-JS)=KSUSY1+23
12150 ELSEIF(ISUB.EQ.239) THEN
12151 C...q + qbar -> ~chi03 + ~g
12153 IF(PYR(0).GT.0.5D0) JS=2
12154 MINT(20+JS)=KSUSY1+21
12155 MINT(23-JS)=KSUSY1+25
12158 ELSEIF(ISUB.EQ.240) THEN
12159 C...q + qbar -> ~chi04 + ~g
12161 IF(PYR(0).GT.0.5D0) JS=2
12162 MINT(20+JS)=KSUSY1+21
12163 MINT(23-JS)=KSUSY1+35
12166 ELSEIF(ISUB.EQ.241) THEN
12167 C...q + qbar' -> ~chi+-1 + ~g
12168 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12169 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12170 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12171 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12172 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12173 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12174 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12176 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12177 MINT(20+JS)=KSUSY1+21
12178 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12181 ELSEIF(ISUB.EQ.242) THEN
12182 C...q + qbar' -> ~chi+-2 + ~g
12183 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12184 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12185 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12186 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12187 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12188 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12189 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12191 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12192 MINT(20+JS)=KSUSY1+21
12193 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12196 ELSEIF(ISUB.EQ.243) THEN
12197 C...q + qbar -> ~g + ~g ; th arbitrary
12202 ELSEIF(ISUB.EQ.244) THEN
12203 C...g + g -> ~g + ~g ; th arbitrary
12205 KCS=(-1)**INT(1.5D0+PYR(0))
12210 ELSEIF(ISUB.LE.260) THEN
12211 IF(ISUB.EQ.246) THEN
12212 C...qj + g -> ~qj_L + ~chi01
12213 IF(MINT(15).EQ.21) JS=2
12216 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12217 MINT(23-JS)=KSUSY1+22
12219 KCS=ISIGN(1,MINT(14+JS))
12221 ELSEIF(ISUB.EQ.247) THEN
12222 C...qj + g -> ~qj_R + ~chi01
12223 IF(MINT(15).EQ.21) JS=2
12226 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12227 MINT(23-JS)=KSUSY1+22
12229 KCS=ISIGN(1,MINT(14+JS))
12231 ELSEIF(ISUB.EQ.248) THEN
12232 C...qj + g -> ~qj_L + ~chi02
12233 IF(MINT(15).EQ.21) JS=2
12236 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12237 MINT(23-JS)=KSUSY1+23
12239 KCS=ISIGN(1,MINT(14+JS))
12241 ELSEIF(ISUB.EQ.249) THEN
12242 C...qj + g -> ~qj_R + ~chi02
12243 IF(MINT(15).EQ.21) JS=2
12246 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12247 MINT(23-JS)=KSUSY1+23
12249 KCS=ISIGN(1,MINT(14+JS))
12251 ELSEIF(ISUB.EQ.250) THEN
12252 C...qj + g -> ~qj_L + ~chi03
12253 IF(MINT(15).EQ.21) JS=2
12256 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12257 MINT(23-JS)=KSUSY1+25
12259 KCS=ISIGN(1,MINT(14+JS))
12261 ELSEIF(ISUB.EQ.251) THEN
12262 C...qj + g -> ~qj_R + ~chi03
12263 IF(MINT(15).EQ.21) JS=2
12266 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12267 MINT(23-JS)=KSUSY1+25
12269 KCS=ISIGN(1,MINT(14+JS))
12271 ELSEIF(ISUB.EQ.252) THEN
12272 C...qj + g -> ~qj_L + ~chi04
12273 IF(MINT(15).EQ.21) JS=2
12276 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12277 MINT(23-JS)=KSUSY1+35
12279 KCS=ISIGN(1,MINT(14+JS))
12281 ELSEIF(ISUB.EQ.253) THEN
12282 C...qj + g -> ~qj_R + ~chi04
12283 IF(MINT(15).EQ.21) JS=2
12286 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12287 MINT(23-JS)=KSUSY1+35
12289 KCS=ISIGN(1,MINT(14+JS))
12291 ELSEIF(ISUB.EQ.254) THEN
12292 C...qj + g -> ~qk_L + ~chi+-1
12293 IF(MINT(15).EQ.21) JS=2
12296 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12297 IB=-IA+INT((IA+1)/2)*4-1
12298 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12300 KCS=ISIGN(1,MINT(14+JS))
12302 ELSEIF(ISUB.EQ.255) THEN
12303 C...qj + g -> ~qk_L + ~chi+-1
12304 IF(MINT(15).EQ.21) JS=2
12307 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12308 IB=-IA+INT((IA+1)/2)*4-1
12309 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12311 KCS=ISIGN(1,MINT(14+JS))
12313 ELSEIF(ISUB.EQ.256) THEN
12314 C...qj + g -> ~qk_L + ~chi+-2
12315 IF(MINT(15).EQ.21) JS=2
12318 IB=-IA+INT((IA+1)/2)*4-1
12319 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12320 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12322 KCS=ISIGN(1,MINT(14+JS))
12324 ELSEIF(ISUB.EQ.257) THEN
12325 C...qj + g -> ~qk_R + ~chi+-2
12326 IF(MINT(15).EQ.21) JS=2
12329 IB=-IA+INT((IA+1)/2)*4-1
12330 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12331 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12333 KCS=ISIGN(1,MINT(14+JS))
12335 ELSEIF(ISUB.EQ.258) THEN
12336 C...qj + g -> ~qj_L + ~g
12337 IF(MINT(15).EQ.21) JS=2
12340 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12341 MINT(23-JS)=KSUSY1+21
12343 IF(JS.EQ.2) KCC=KCC+2
12346 ELSEIF(ISUB.EQ.259) THEN
12347 C...qj + g -> ~qj_R + ~g
12348 IF(MINT(15).EQ.21) JS=2
12351 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12352 MINT(23-JS)=KSUSY1+21
12354 IF(JS.EQ.2) KCC=KCC+2
12358 ELSEIF(ISUB.LE.270) THEN
12359 IF(ISUB.EQ.261) THEN
12360 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12362 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12363 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12365 C...Correct color combination
12366 IF(MINT(43).EQ.4) KCC=4
12368 ELSEIF(ISUB.EQ.262) THEN
12369 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12371 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12372 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12374 C...Correct color combination
12375 IF(MINT(43).EQ.4) KCC=4
12377 ELSEIF(ISUB.EQ.263) THEN
12378 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12379 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12380 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12381 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12382 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12385 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12386 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12388 C...Correct color combination
12389 IF(MINT(43).EQ.4) KCC=4
12391 ELSEIF(ISUB.EQ.264) THEN
12392 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12393 KCS=(-1)**INT(1.5D0+PYR(0))
12394 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12398 ELSEIF(ISUB.EQ.265) THEN
12399 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12400 KCS=(-1)**INT(1.5D0+PYR(0))
12401 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12406 ELSEIF(ISUB.LE.301) THEN
12407 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12408 C...qi + qj -> ~qi_L + ~qj_L
12410 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12411 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12412 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12414 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12415 C...qi + qj -> ~qi_R + ~qj_R
12417 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12418 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12419 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12421 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12422 C...qi + qj -> ~qi_L + ~qj_R
12423 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12424 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12426 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12428 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12429 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12430 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12431 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12433 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12435 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12436 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12437 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12438 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12440 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12442 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12443 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12444 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12445 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12447 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12449 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12450 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12452 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12453 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12455 IF(MINT(43).EQ.4) KCC=4
12457 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12458 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12460 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12461 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12463 IF(MINT(43).EQ.4) KCC=4
12465 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12466 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12468 KCS=(-1)**INT(1.5D0+PYR(0))
12469 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12473 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12474 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12475 KCS=(-1)**INT(1.5D0+PYR(0))
12476 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12480 ELSEIF(ISUB.EQ.294) THEN
12481 C...qj + g -> ~qj_L + ~g
12482 IF(MINT(15).EQ.21) JS=2
12485 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12486 MINT(23-JS)=KSUSY1+21
12488 IF(JS.EQ.2) KCC=KCC+2
12491 ELSEIF(ISUB.EQ.295) THEN
12492 C...qj + g -> ~qj_R + ~g
12493 IF(MINT(15).EQ.21) JS=2
12496 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12497 MINT(23-JS)=KSUSY1+21
12499 IF(JS.EQ.2) KCC=KCC+2
12502 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12503 C...q + qbar' -> H+ + H0
12504 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12505 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12506 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12507 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12508 MINT(23-JS)=KFPR(ISUB,2)
12509 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12510 C...f + fbar -> A0 + H0; th arbitrary
12511 IF(PYR(0).GT.0.5D0) JS=2
12512 MINT(20+JS)=KFPR(ISUB,1)
12513 MINT(23-JS)=KFPR(ISUB,2)
12514 ELSEIF(ISUB.EQ.301) THEN
12515 C...f + fbar -> H+ H-
12516 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12520 ELSEIF(ISUB.LE.330) THEN
12521 IF(ISUB.EQ.311)THEN
12522 C...g + g -> g* + g* (UED)
12524 KCS=(-1)**INT(1.5D0+PYR(0))
12527 MINT(21)=IUEDEQ(472)
12528 MINT(22)=IUEDEQ(472)
12529 ELSEIF(ISUB.EQ.312)THEN
12530 C...q + g -> q*_D + g*, q*_S + g*
12531 C...The two channels have the same cross section
12533 IF(PYR(0).GT.0.5)KKFLMI=456
12534 IF(MINT(15).EQ.21) JS=2
12536 IF(MINT(15).EQ.21)KCC=KCC+2
12537 IF(MINT(15).NE.21)THEN
12538 KCS=ISIGN(1,MINT(15))
12540 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12541 MINT(22)=IUEDEQ(472)
12542 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12544 IF(MINT(16).NE.21)THEN
12545 KCS=ISIGN(1,MINT(16))
12546 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12548 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12549 MINT(21)=IUEDEQ(472)
12551 ELSEIF(ISUB.EQ.313)THEN
12552 C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12553 C...The two channels have the same cross section
12555 IF(PYR(0).GT.0.5)KKFLMI=456
12557 IF(MINT(15).EQ.MINT(16))THEN
12558 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12560 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12563 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12564 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12565 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12566 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12568 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12569 ELSEIF(ISUB.EQ.314)THEN
12570 C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12571 C...The two channels have the same cross section
12573 IF(PYR(0).GT.0.5)KKFLMI=456
12574 KCS=(-1)**INT(1.5D0+PYR(0))
12576 IF(XFLAOUT.LE.0.2)THEN
12577 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12578 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12579 ELSEIF(XFLAOUT.LE.0.4)THEN
12580 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12581 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12582 ELSEIF(XFLAOUT.LE.0.6)THEN
12583 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12584 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12585 ELSEIF(XFLAOUT.LE.0.8)THEN
12586 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12587 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12589 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12590 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12595 ELSEIF(ISUB.EQ.315)THEN
12596 C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12597 C...The two channels have the same cross section
12599 IF(PYR(0).GT.0.5)KKFLMI=456
12600 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12602 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12605 ELSEIF(ISUB.EQ.316)THEN
12606 C...q + qbar' -> q*_D + q*_S_bar'
12607 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12608 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12609 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12610 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12612 ELSEIF(ISUB.EQ.317)THEN
12613 C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12614 C...The two channels have the same cross section
12616 IF(PYR(0).GT.0.5)KKFLMI=456
12617 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12618 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12619 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12620 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12622 ELSEIF(ISUB.EQ.318)THEN
12623 C...q + q' -> q*_D + q*_S'
12625 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12626 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12627 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12628 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12629 ELSEIF(ISUB.EQ.319)THEN
12630 C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12631 C...The two channels have the same cross section
12633 IF(PYR(0).GT.0.5)KKFLMI=456
12636 C...N.B. NFLAVOURS=IUED(3)
12639 IF(I.NE.IABS(MINT(15)))THEN
12644 FLASTEP=1./(IUED(3)-1)
12647 IF(XFLAOUT.LE.FLAVV)THEN
12648 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12649 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12654 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12655 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12656 CALL PYSTOP(5000000)
12662 ELSEIF(ISUB.LE.360) THEN
12664 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12665 C...l + l -> H_L++/--, H_R++/--
12666 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12667 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12668 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12670 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12671 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12672 IF(MINT(15).EQ.22) JS=2
12673 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12674 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12677 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12678 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12679 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12682 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12683 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12684 C...as inner process).
12689 RVCKM=VINT(180+I)*PYR(0)
12692 IPM=(5-ISIGN(1,I))/2
12694 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12695 MINT(20+JT)=ISIGN(IB,I)
12696 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12697 IF(RVCKM.LE.0D0) GOTO 450
12700 IB=2*((IA+1)/2)-1+MOD(IA,2)
12701 MINT(20+JT)=ISIGN(IB,I)
12705 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12706 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12708 ELSEIF(ISUB.EQ.353) THEN
12709 C...f + fbar -> Z_R0
12712 ELSEIF(ISUB.EQ.354) THEN
12713 C...f + fbar' -> W+/-
12714 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12715 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12716 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12720 ELSEIF(ISUB.LE.380) THEN
12722 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12723 C...f + fbar -> charged+ charged- technicolor
12724 KSW=(-1)**INT(1.5D0+PYR(0))
12725 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12726 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12728 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12729 C...f + fbar -> neutral neutral technicolor
12730 MINT(21)=KFPR(ISUB,1)
12731 MINT(22)=KFPR(ISUB,2)
12733 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12734 C...f + fbar' -> neutral charged technicolor
12737 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12738 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12739 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12740 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12741 MINT(20+JS)=KFPR(ISUB,IN)
12743 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12744 C...f + fbar' -> charged neutral technicolor
12747 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12748 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12749 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12750 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12751 MINT(23-JS)=KFPR(ISUB,IN)
12754 ELSEIF(ISUB.LE.400) THEN
12755 IF(ISUB.EQ.381) THEN
12756 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12758 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12760 ELSEIF(ISUB.EQ.382) THEN
12761 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12762 MINT(21)=ISIGN(KFLF,MINT(15))
12766 ELSEIF(ISUB.EQ.383) THEN
12767 C...f + fbar -> g + g; th arbitrary, TC extensions
12772 ELSEIF(ISUB.EQ.384) THEN
12773 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12774 IF(MINT(15).EQ.21) JS=2
12776 IF(MINT(15).EQ.21) KCC=KCC+2
12777 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12778 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12780 ELSEIF(ISUB.EQ.385) THEN
12781 C...g + g -> f + fbar; th arbitrary, TC extensions
12782 KCS=(-1)**INT(1.5D0+PYR(0))
12783 MINT(21)=ISIGN(KFLF,KCS)
12787 ELSEIF(ISUB.EQ.386) THEN
12788 C...g + g -> g + g; th arbitrary, TC extensions
12790 KCS=(-1)**INT(1.5D0+PYR(0))
12792 ELSEIF(ISUB.EQ.387) THEN
12793 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12794 MINT(21)=ISIGN(MINT(55),MINT(15))
12798 ELSEIF(ISUB.EQ.388) THEN
12799 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12800 KCS=(-1)**INT(1.5D0+PYR(0))
12801 MINT(21)=ISIGN(MINT(55),KCS)
12805 ELSEIF(ISUB.EQ.391) THEN
12806 C...f + fbar -> G*.
12809 ELSEIF(ISUB.EQ.392) THEN
12814 ELSEIF(ISUB.EQ.393) THEN
12815 C...q + qbar -> g + G*; th arbitrary.
12816 IF(PYR(0).GT.0.5D0) JS=2
12817 MINT(20+JS)=KFPR(ISUB,1)
12818 MINT(23-JS)=KFPR(ISUB,2)
12821 ELSEIF(ISUB.EQ.394) THEN
12822 C...q + g -> q + G*; th = (p(f) - p(f))**2
12823 IF(MINT(15).EQ.21) JS=2
12824 MINT(23-JS)=KFPR(ISUB,2)
12826 KCS=ISIGN(1,MINT(14+JS))
12828 ELSEIF(ISUB.EQ.395) THEN
12829 C...g + g -> G* + g; th arbitrary.
12830 IF(PYR(0).GT.0.5D0) JS=2
12831 MINT(23-JS)=KFPR(ISUB,2)
12835 ELSEIF(ISUB.LE.420) THEN
12836 IF(ISUB.EQ.401) THEN
12837 C...g + g -> t + b + H+/-
12838 KCS=(-1)**INT(1.5D0+PYR(0))
12839 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12840 MINT(22)=ISIGN(5,-KCS)
12841 KCC=11+INT(0.5D0+PYR(0))
12842 KFRES=ISIGN(KFHIGG,-KCS)
12844 ELSEIF(ISUB.EQ.402) THEN
12845 C...q + qbar -> t + b + H+/-
12846 KFL=(-1)**INT(1.5D0+PYR(0))
12847 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12848 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12850 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12854 C...Additional code by Stefan Wolf
12855 ELSEIF(ISUB.LE.430) THEN
12856 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12857 C...g + g -> QQ~[n] + g
12858 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12859 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12860 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12861 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12862 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12863 C...[g + g -> g + g; th arbitrary]
12864 MINT(21)=KFPR(ISUBSV,1)
12865 MINT(22)=KFPR(ISUBSV,2)
12866 IF(ISUB.EQ.421) THEN
12868 KCS=(-1)**INT(1.5D0+PYR(0))
12871 KCS=(-1)**INT(1.5D0+PYR(0))
12874 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12875 C...q + g -> q + QQ~[n]
12876 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12877 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12878 C...KCC copied from ISUB.EQ.28
12879 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12880 IF(MINT(15).EQ.21) JS=2
12881 MINT(23-JS)=KFPR(ISUBSV,2)
12883 IF(MINT(15).EQ.21) KCC=KCC+2
12884 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12885 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12887 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12888 C...q + q~ -> g + QQ~[n]
12889 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12890 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12891 C...KCC copied from ISUB.EQ.13
12892 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12893 IF(PYR(0).GT.0.5) JS=2
12895 MINT(23-JS)=KFPR(ISUBSV,2)
12899 ELSEIF(ISUB.LE.440) THEN
12900 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12901 C...g + g -> QQ~[n] + g
12902 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12903 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12904 C...KCC and KCS copied from ISUB.EQ.86-89
12905 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12906 MINT(21)=KFPR(ISUBSV,1)
12907 MINT(22)=KFPR(ISUBSV,2)
12909 KCS=(-1)**INT(1.5D0+PYR(0))
12911 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12912 C...q + g -> q + QQ~[n]
12913 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12914 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12915 C...KCC and KCS copied from ISUB.EQ.112
12916 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12917 IF(MINT(15).EQ.21) JS=2
12918 MINT(23-JS)=KFPR(ISUBSV,2)
12920 KCS=ISIGN(1,MINT(14+JS))
12922 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12923 C...q + q~ -> g + QQ~[n]
12924 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12925 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12926 C...KCC copied from ISUB.EQ.111
12927 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12928 IF(PYR(0).GT.0.5) JS=2
12930 MINT(23-JS)=KFPR(ISUBSV,2)
12934 ELSEIF(ISUB.LE.500) THEN
12935 IF(ISUB.EQ.481.OR.ISUB.EQ.482) THEN
12937 KCRES=PYCOMP(KFRES)
12941 $ CALL PYERRM(21,"No resonance for Generic 2-> 2 Process")
12944 $ CALL PYERRM(21,"No decays for resonance in Generic 2->2")
12945 KCI1=PYCOMP(MINT(15))
12946 KCI2=PYCOMP(MINT(16))
12947 ICOL1=ISIGN(KCHG(KCI1,2),MINT(15))
12948 ICOL2=ISIGN(KCHG(KCI2,2),MINT(16))
12953 JCOL1=SIGN(KCHG(KCF1,2),KFF1)
12954 IF(JCOL1.EQ.-2) JCOL1=2
12955 JCOL2=SIGN(KCHG(KCF2,2),KFF2)
12956 IF(JCOL2.EQ.-2) JCOL2=2
12957 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12958 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12961 IF(MCHG.NE.0.AND.KCHW.EQ.-MCHG) KREL=-1
12962 IF(KCHG(KCF1,3).NE.0) KFF1=KFF1*KREL
12963 IF(KCHG(KCF2,3).NE.0) KFF2=KFF2*KREL
12964 IF(JCOL1.EQ.1.OR.JCOL1.EQ.-1) JCOL1=JCOL1*KREL
12965 IF(JCOL2.EQ.1.OR.JCOL2.EQ.-1) JCOL2=JCOL2*KREL
12966 IF((ICOL1.EQ.1.AND.ICOL2.EQ.-1).OR.
12967 $ (ICOL2.EQ.1.AND.ICOL1.EQ.-1)) THEN
12968 IF(PYR(0).GT.0.5D0) JS=2
12971 IF(JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
12973 ELSEIF(JCOL1.EQ.0.AND.JCOL2.EQ.2) THEN
12977 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.0) THEN
12981 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2.AND.MCOL.EQ.0) THEN
12983 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
12985 ELSEIF((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
12986 $ (JCOL1.EQ.-1.AND.JCOL2.EQ.1)) THEN
12987 IF(ICOL1.EQ.JCOL1) THEN
13002 ELSEIF((ICOL1.EQ.2.AND.(ICOL2.EQ.1.OR.ICOL2.EQ.-1)).OR.
13003 $ (ICOL2.EQ.2.AND.(ICOL1.EQ.1.OR.ICOL1.EQ.-1))) THEN
13004 IF((JCOL1.EQ.2.AND.ABS(JCOL2).EQ.1).OR.
13005 $ (JCOL2.EQ.2.AND.ABS(JCOL1).EQ.1)) THEN
13006 IF(MINT(15).EQ.21) JS=2
13008 IF(MINT(15).EQ.21) KCC=KCC+2
13009 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
13010 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
13011 IF(JCOL1.EQ.2) THEN
13018 ELSEIF((ABS(JCOL1).EQ.1.AND.JCOL2.EQ.0).OR.
13019 $ (ABS(JCOL2).EQ.1.AND.JCOL1.EQ.0)) THEN
13020 IF(MINT(15).EQ.21) JS=2
13022 KCS=ISIGN(1,MINT(14+JS))
13023 IF(JCOL1.EQ.0) THEN
13031 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13032 $ JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
13033 IF(PYR(0).GT.0.5D0) JS=2
13037 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13038 $ ((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
13039 $ ((JCOL2.EQ.0.AND.JCOL1.EQ.2)))) THEN
13040 IF(PYR(0).GT.0.5D0) JS=2
13042 KCS=(-1)**INT(1.5D0+PYR(0))
13043 IF(JCOL1.EQ.0) THEN
13050 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13051 $ ((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
13052 $ ((JCOL2.EQ.1.AND.JCOL1.EQ.-1)))) THEN
13053 C....two choices, 0 or 2 depending upon mother properties
13055 KCS=(-1)**INT(1.5D0+PYR(0))
13057 IF(JCOL1.EQ.1) THEN
13064 c MINT(20+JS)=KFF1*KCS
13065 c MINT(23-JS)=KFF2*KCS
13066 ELSEIF(MCOL.EQ.0) THEN
13068 MINT(20+JS)=KFF1*KCS
13069 MINT(23-JS)=KFF2*KCS
13072 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13073 $ JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
13074 C....two choices, 0 or 2 depending upon mother properties
13077 IF(PYR(0).GT.0.5D0) JS=2
13080 ELSEIF(MCOL.EQ.2) THEN
13081 IF(PYR(0).GT.0.5D0) JS=2
13083 KCS=(-1)**INT(1.5D0+PYR(0))
13087 ELSEIF((ICOL1.EQ.1.AND.ICOL2.EQ.1).OR.
13088 $ (ICOL1.EQ.-1.AND.ICOL2.EQ.-1)) THEN
13090 IF(PYR(0).GT.0.5D0) JS=2
13093 ELSEIF(ICOL1.EQ.0.AND.ICOL2.EQ.0.AND.MCOL.EQ.0) THEN
13095 IF(PYR(0).GT.0.5D0) JS=2
13099 CALL PYERRM(21,"PYSCAT: No recognized Generic Process")
13101 IF(ISUBSV.EQ.482) KFRES=0
13105 IF(ISET(ISUB).EQ.11) THEN
13106 C...Store documentation for user-defined processes
13107 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
13108 KUPPO(1)=MINT(83)+5
13109 KUPPO(2)=MINT(83)+6
13113 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
13122 IF(IDUP(IUP).EQ.0) K(I,2)=90
13124 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
13132 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
13135 C...Store final state partons for user-defined processes
13140 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
13142 IF(IDUP(IUP).EQ.0) K(N,2)=90
13143 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
13146 K(N,3)=MINT(84)+MOTHUP(1,IUP)
13150 C...Search for daughters of intermediate colourless particles.
13151 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
13152 DO 475 IUPDAU=IUP+1,NUP
13153 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
13155 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
13163 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
13165 C...Arrange colour flow for user-defined processes
13169 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
13170 IF(K(I1,1).EQ.1) K(I1,1)=3
13171 IF(K(I1,1).EQ.11) K(I1,1)=14
13172 C...Find a not yet considered colour/anticolour line.
13174 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
13177 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
13181 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
13182 C...Find all others belonging to same line.
13185 DO 520 IUP2=IUP1+1,NUP
13188 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
13189 IF(ISDE2.EQ.ISDE1) THEN
13190 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
13191 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
13193 ELSEIF(I4.NE.0) THEN
13194 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
13195 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
13197 ELSEIF(IUP2.LE.2) THEN
13198 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
13199 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
13202 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
13203 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
13213 ELSEIF(IDOC.EQ.7) THEN
13214 C...Resonance not decaying; store kinematics
13229 C...Special cases: colour flow in coloured resonances
13230 KCRES=PYCOMP(KFRES)
13231 IF(KCHG(KCRES,2).NE.0) THEN
13235 IF(KCS.EQ.-1) JC=3-J
13236 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13237 & MINT(84)+ICOL(KCC,1,JC)
13238 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13239 & MINT(84)+ICOL(KCC,2,JC)
13240 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13241 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13250 ELSEIF(IDOC.EQ.8) THEN
13251 C...2 -> 2 processes: store outgoing partons in their CM-frame
13254 KCA=PYCOMP(MINT(20+JT))
13256 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13258 K(I,3)=MINT(83)+IDOC+JT-2
13260 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13261 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13263 P(I,5)=PYMASS(K(I,2))
13265 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13266 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13268 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13269 KFA1=IABS(MINT(21))
13270 KFA2=IABS(MINT(22))
13271 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13279 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13280 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13281 P(IPU4,4)=SHR-P(IPU3,4)
13282 P(IPU4,3)=-P(IPU3,3)
13287 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13288 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13290 ELSEIF(IDOC.EQ.9) THEN
13291 C...2 -> 3 processes: store outgoing partons in their CM frame
13294 KCA=PYCOMP(MINT(20+JT))
13296 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13298 K(I,3)=MINT(83)+IDOC+JT-3
13300 C...t and b in opposide order in event list as compared to
13301 C...matrix element?
13302 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13303 IF(IABS(K(I,2)).LE.22) THEN
13304 P(I,5)=PYMASS(K(I,2))
13306 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13308 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13309 P(I,1)=PT*COS(VINT(198+5*JTA))
13310 P(I,2)=PT*SIN(VINT(198+5*JTA))
13314 K(IPU5,3)=MINT(83)+IDOC
13316 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13317 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13318 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13319 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13320 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13322 P(IPU5,3)=PMT3*SINH(VINT(211))
13323 P(IPU5,4)=PMT3*COSH(VINT(211))
13324 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13325 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13326 IF(SQL12.LE.0D0) THEN
13330 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13331 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13332 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13333 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13334 C...t and b in opposide order in event list as compared to
13336 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13337 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13338 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13340 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13341 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13347 ELSEIF(IDOC.EQ.11) THEN
13348 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13349 PHI(1)=PARU(2)*PYR(0)
13354 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13356 K(I,3)=MINT(83)+IDOC+JT-2
13357 P(I,5)=PYMASS(K(I,2))
13358 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13362 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13363 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13364 P(I,1)=PTABS*COS(PHI(JT))
13365 P(I,2)=PTABS*SIN(PHI(JT))
13366 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13367 P(I,4)=0.5D0*SHPR*Z(JT)
13371 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13375 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13376 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13377 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13384 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13385 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13386 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13387 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13396 ELSEIF(IDOC.EQ.12) THEN
13397 C...Z0 and W+/- scattering: store bosons and outgoing partons
13398 PHI(1)=PARU(2)*PYR(0)
13400 JTRAN=INT(1.5D0+PYR(0))
13404 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13406 K(I,3)=MINT(83)+IDOC+JT-2
13407 P(I,5)=PYMASS(K(I,2))
13408 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13409 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13410 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13411 P(I,1)=PTABS*COS(PHI(JT))
13412 P(I,2)=PTABS*SIN(PHI(JT))
13413 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13414 P(I,4)=0.5D0*SHPR*Z(JT)
13417 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13420 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13425 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13426 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13427 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13430 K(IPU,2)=KFPR(ISUB,JT)
13431 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13432 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13433 K(IPU,3)=MINT(83)+8+JT
13434 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13435 P(IPU,5)=PYMASS(K(IPU,2))
13437 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13439 MINT(22+JT)=K(IPU,2)
13441 C...Find rotation and boost for hard scattering subsystem
13444 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13445 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13446 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13447 GAMCM=(P(I1,4)+P(I2,4))/SHR
13448 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13449 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13450 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13451 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13452 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13453 PHICM=PYANGL(PX,PY)
13454 C...Store hard scattering subsystem. Rotate and boost it
13455 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13457 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13459 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13460 PHIWZ=VINT(24)-PHICM
13461 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13462 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13463 P(IPU5,3)=PABS*CTHWZ
13464 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13465 P(IPU6,1)=-P(IPU5,1)
13466 P(IPU6,2)=-P(IPU5,2)
13467 P(IPU6,3)=-P(IPU5,3)
13468 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13469 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13481 MINT(8)=MINT(83)+10
13484 IF(ISET(ISUB).EQ.11) THEN
13485 ELSEIF(IDOC.GE.8) THEN
13486 C...Store colour connection indices
13489 IF(KCS.EQ.-1) JC=3-J
13490 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13491 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13492 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13493 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13494 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13495 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13496 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13497 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13500 C...Copy outgoing partons to documentation lines
13502 IF(IDOC.EQ.9) IMAX=3
13504 I1=MINT(83)+IDOC-IMAX+I
13508 IF(IDOC.LE.9) K(I1,3)=0
13509 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13515 ELSEIF(IDOC.EQ.9) THEN
13516 C...Store colour connection indices
13519 IF(KCS.EQ.-1) JC=3-J
13520 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13521 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13522 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13523 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13524 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13525 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13526 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13527 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13528 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13529 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13532 C...Copy outgoing partons to documentation lines
13534 I1=MINT(83)+IDOC-3+I
13545 C...Copy outgoing partons to list of allowed radiators.
13547 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13548 DO 690 I=MINT(84)+3,N
13551 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13555 C...Low-pT events: remove gluons used for string drawing purposes
13556 IF(ISUB.EQ.95) THEN
13557 IF(MINT(35).LE.1) THEN
13558 K(IPU3,1)=K(IPU3,1)+10
13559 K(IPU4,1)=K(IPU4,1)+10
13565 DO 720 I=MINT(83)+5,MINT(83)+8
13575 C***********************************************************************
13578 C...Handles intertwined pT-ordered spacelike initial-state parton
13579 C...and multiple interactions.
13581 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13582 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13583 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13584 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13586 C...Double precision and integer declarations.
13587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13588 IMPLICIT INTEGER(I-N)
13589 INTEGER PYK,PYCHGE,PYCOMP
13592 DOUBLE PRECISION PYALPS
13593 C...Parameter statement for maximum size of showers.
13594 PARAMETER (MAXNUR=1000)
13596 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13597 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13599 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13600 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13601 COMMON/PYINT1/MINT(400),VINT(400)
13602 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13603 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13604 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13605 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13606 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13607 COMMON/PYCTAG/NCT,MCT(4000,2)
13608 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13609 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13610 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13611 C...Local arrays and saved variables.
13612 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13613 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13616 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13617 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13619 C----------------------------------------------------------------------
13620 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13621 C...done only once per event, while MODE=0 is repeated each time the
13622 C...evolution needs to be restarted.
13623 IF (MODE.EQ.-1) THEN
13627 C...Store hard scattering variables
13644 C...Set shat for hardest scattering
13646 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13649 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13653 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13654 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13655 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13657 C----------------------------------------------------------------------
13658 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13659 C...interaction initiators, with no previous evolution. Check the input
13660 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13661 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13662 C...smaller than the CM energy / 2.)
13663 ELSEIF (MODE.EQ.0) THEN
13664 C...Reset counters and switches
13670 C...Reset hard scattering variables
13681 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13682 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13685 C...Reset statistics on activity in event.
13690 C...Reset extra companion reweighting factor
13693 C...We do not generate MI for soft process (ISUB=95), but the
13694 C...initialization must be done regardless, for later purposes.
13697 C...Initialize multiple interactions.
13698 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13699 IF(MINT(51).NE.0) RETURN
13701 C...Decide whether quarks in hard scattering were valence or sea
13705 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13706 IF(MINT(51).NE.0) RETURN
13709 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13711 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13712 IF (MSTP(70).EQ.2) THEN
13713 C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13714 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13715 ELSEIF (MSTP(70).EQ.3) THEN
13716 C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13717 ALPHA0 = MAX(1D-6,PARP(73))
13718 Q20 = ALAM3**2/PARP(64)
13719 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13720 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13722 C...Also store PT2MIN in VINT(17).
13723 180 VINT(17)=PT2MIN
13725 C...Set FS masses zero now.
13729 C...Initialize IS showers with VINT(56) as max scale.
13732 IF (MSTP(70).EQ.0) THEN
13733 PT20=MAX(PT2MIN,PARP(62)**2)
13734 ELSEIF (MSTP(70).EQ.1) THEN
13735 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13737 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13738 IF(MINT(51).NE.0) RETURN
13742 C----------------------------------------------------------------------
13743 C...MODE= 1: Evolve event from PTMAX to PTMIN.
13744 ELSEIF (MODE.EQ.1) THEN
13746 C...Skip if no phase space.
13747 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13749 C...Starting pT2 max scale (to be udpated successively).
13752 C...Evolve two sides of the event to find which branches at highest pT.
13757 C...Loop over current shower initiators.
13758 IF (MSTP(61).GE.1) THEN
13759 DO 230 MI=1,MINT(31)
13760 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13762 IF (MI.EQ.1) ISUB=ISUBHD
13765 C...Set up shat, initiator x values, and x remaining in BR.
13767 VINT(141)=XMI(1,MI)
13768 VINT(142)=XMI(2,MI)
13771 DO 210 JI=1,MINT(31)
13772 IF (JI.EQ.MINT(36)) GOTO 210
13773 VINT(143)=VINT(143)-XMI(1,JI)
13774 VINT(144)=VINT(144)-XMI(2,JI)
13776 C...Loop over sides.
13777 C...Generate trial branchings for this interaction. The hardest
13778 C...branching so far is automatically updated if necessary in /PYISMX/.
13782 IF (MSTP(70).EQ.0) THEN
13783 PT20=MAX(PT2MIN,PARP(62)**2)
13784 ELSEIF (MSTP(70).EQ.1) THEN
13786 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13788 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13789 IF (MINT(51).NE.0) RETURN
13794 C...Generate trial additional interaction.
13795 MINT(36)=MINT(31)+1
13796 240 IF (MOD(MSTP(81),10).GE.1) THEN
13798 C...Set up X remaining in BR.
13801 DO 250 JI=1,MINT(31)
13802 VINT(143)=VINT(143)-XMI(1,JI)
13803 VINT(144)=VINT(144)-XMI(2,JI)
13805 C...Generate trial interaction
13806 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13807 IF (MINT(51).EQ.1) RETURN
13810 C...And the winner is:
13811 IF (PT2MX.LT.PT2MIN) THEN
13813 ELSEIF (JSMX.EQ.0) THEN
13814 C...Accept additional interaction (may still fail).
13815 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13816 IF(MINT(51).NE.0) RETURN
13817 IF (IFAIL.EQ.0) THEN
13818 SHAT(MINT(36))=VINT(44)
13819 C...Decide on flavours (valence/sea/companion).
13822 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13823 IF(MINT(51).NE.0) RETURN
13826 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13827 C...Reconstruct kinematics of acceptable ISR branching.
13828 C...Set up shat, initiator x values, and x remaining in BR.
13831 VINT(44)=SHAT(MINT(36))
13832 VINT(141)=XMI(1,MINT(36))
13833 VINT(142)=XMI(2,MINT(36))
13836 DO 280 JI=1,MINT(31)
13837 IF (JI.EQ.MINT(36)) GOTO 280
13838 VINT(143)=VINT(143)-XMI(1,JI)
13839 VINT(144)=VINT(144)-XMI(2,JI)
13842 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13843 IF (MINT(51).EQ.1) RETURN
13844 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13845 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13846 MINT(354)=MINT(354)+1
13847 VINT(354)=VINT(354)+SQRT(PT2MX)
13848 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13849 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13850 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13853 C...Update PT2 iteration scale.
13856 C...Loop back to continue evolution.
13857 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13858 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13860 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13863 C----------------------------------------------------------------------
13864 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13865 ELSEIF (MODE.EQ.2) THEN
13867 C...Revert to "ordinary" meanings of some parameters.
13869 MINT(12+JS)=K(IMI(JS,1,1),2)
13870 VINT(140+JS)=XMI(JS,1)
13871 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13873 DO 300 MI=1,MINT(31)
13874 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13878 C...Restore saved quantities for hardest interaction.
13893 C*********************************************************************
13896 C...Generates spacelike parton showers.
13898 SUBROUTINE PYSSPA(IPU1,IPU2)
13900 C...Double precision and integer declarations.
13901 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13902 IMPLICIT INTEGER(I-N)
13903 INTEGER PYK,PYCHGE,PYCOMP
13904 PARAMETER (MAXNUR=1000)
13906 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13907 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13908 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13909 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13910 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13911 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13912 COMMON/PYINT1/MINT(400),VINT(400)
13913 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13914 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13915 COMMON/PYCTAG/NCT,MCT(4000,2)
13916 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13917 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13918 C...Local arrays and data.
13919 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13920 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13921 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13922 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13923 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13926 C...Read out basic information; set global Q^2 scale.
13931 VINT2R=VINT(2)*VINT(143)*VINT(144)
13932 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13933 &MIN(VINT2R,PARP(67)*VINT(56))
13936 C...Define which processes ME corrections have been implemented for.
13938 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13939 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13940 & ISUB.EQ.144) MECOR=1
13941 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13942 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13945 C...Initialize QCD evolution and check phase space.
13949 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13952 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13953 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13954 Q2INT=SQRT(Q0S*Q2EFF)
13955 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13956 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13957 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13959 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13962 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13963 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13964 Q2INT=SQRT(Q0S*Q2EFF)
13965 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13966 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13967 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13974 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13976 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13977 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13978 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13979 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13983 C...Initialize QED evolution and check phase space.
13987 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13988 &SPME=PMAS(13,1)**2
13989 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13990 &SPME=PMAS(15,1)**2
13991 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13994 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13996 TEMX=LOG(Q2MX/SPME)
13997 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13999 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14004 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
14006 C...Loopback point in case of failure to reconstruct kinematics.
14015 IF(LOOP.GT.100) THEN
14026 C...Initial values: flavours, momenta, virtualities.
14029 KFBEAM(JT)=MINT(10+JT)
14030 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
14031 KFLS(JT)=MINT(14+JT)
14032 KFLS(JT+2)=KFLS(JT)
14034 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
14035 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
14037 Q2S(JT)=FCQ2MX*Q2MX
14044 C...Calculate initial parton distribution weights.
14045 MINT(105)=MINT(102+JT)
14046 MINT(109)=MINT(106+JT)
14047 VINT(120)=VINT(2+JT)
14049 C.... Store side in MINT(124)
14052 IF(XS(JT).LT.1D0-XEE) THEN
14053 IF(MINT(31).GE.2) MINT(30)=JT
14054 IF(MSTP(57).LE.1) THEN
14055 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
14057 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
14061 XFS(JT,KFL)=XFB(KFL)
14063 C...Special kinematics check for c/b quarks (that g -> c cbar or
14064 C...b bbar kinematically possible).
14065 KFLCB=IABS(KFLS(JT))
14066 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14067 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
14074 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
14076 C...Find if interference with final state partons.
14078 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
14082 KCA=PYCOMP(IABS(KFLS(I)))
14083 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
14085 IF(KCFI(I).NE.0) THEN
14086 IF(I.EQ.1) IPFS=IPUS1
14087 IF(I.EQ.2) IPFS=IPUS2
14089 ICSI=MOD(K(IPFS,3+J),MSTU(5))
14090 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
14091 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
14093 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
14095 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
14100 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
14103 C...Pick up leg with highest virtuality.
14107 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
14108 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
14109 IF(MORE(JT).EQ.0) JT=3-JT
14114 XFB(KFL)=XFS(JT,KFL)
14119 C...Check if allowed to branch.
14121 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
14123 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
14124 IF(XB.GE.1D0-2D0*XEC) MCEV=0
14127 IF(MINT(44+JT).EQ.3) THEN
14129 IF(XB.GE.1D0-2D0*XEE) MEEV=0
14130 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
14132 C***Currently kill QED shower for resolved photoproduction.
14133 IF(MINT(18+JT).EQ.1) MEEV=0
14134 C***Currently kill shower for W inside electron.
14135 IF(IABS(KFLB).EQ.24) THEN
14140 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
14142 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14147 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
14151 IF(MSTP(62).LE.1) THEN
14152 IF(ZS(JT).GT.0.99999D0) THEN
14155 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
14156 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
14157 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
14159 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14160 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14163 ALSDUM=PYALPS(FQ2C*Q2B)
14164 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
14166 B0=(33D0-2D0*MSTU(118))/6D0
14168 IF(MEEV.EQ.2) TEVEB=TEVCB
14172 C...Select side for interference with final state partons.
14173 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
14176 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
14178 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
14179 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
14180 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
14182 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
14186 C...Calculate preweighting factor for ME-corrected processes.
14187 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14189 C...Calculate Altarelli-Parisi weights.
14195 C...q -> q (g or gamma emission), g -> q.
14196 IF(IABS(KFLB).LE.10) THEN
14197 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
14198 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
14200 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
14201 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
14203 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14204 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
14205 WTAPC(21)=WTGF*WTAPC(21)
14206 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
14208 C...f -> f, gamma -> f.
14209 ELSEIF(IABS(KFLB).LE.20) THEN
14210 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
14211 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
14212 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
14213 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
14214 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14215 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
14216 WTAPE(22)=WTGF*WTAPE(22)
14218 C...f -> g, g -> g.
14219 ELSEIF(KFLB.EQ.21) THEN
14220 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
14221 DO 180 KFL=1,MSTP(58)
14225 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
14226 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14227 DO 190 KFL=1,MSTP(58)
14228 WTAPC(KFL)=WTFG*WTAPC(KFL)
14229 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
14231 WTAPC(21)=WTGG*WTAPC(21)
14233 C...f -> gamma, W+, W-.
14234 ELSEIF(KFLB.EQ.22) THEN
14235 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
14238 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14239 WTAPE(11)=WTFG*WTAPE(11)
14240 WTAPE(-11)=WTFG*WTAPE(-11)
14242 ELSEIF(KFLB.EQ.24) THEN
14243 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
14244 & (XEE*(XB+XEE)))/XB
14245 ELSEIF(KFLB.EQ.-24) THEN
14246 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
14247 & (XEE*(XB+XEE)))/XB
14250 C...Calculate parton distribution weights and sum.
14253 IF(NTRY.GT.500) THEN
14259 XFBO=MAX(1D-10,XFB(KFLB))
14261 WTSF(KFL)=XFB(KFL)/XFBO
14262 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14263 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14265 WTSUMC=MAX(0.0001D0,WTSUMC)
14266 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14268 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14271 IF(NTRY2.GT.500) THEN
14276 IF(MSTP(64).LE.0) THEN
14277 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14278 ELSEIF(MSTP(64).EQ.1) THEN
14279 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14281 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14285 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14286 & (PARU(101)*FWTE*WTSUME*TEMX)))
14287 ELSEIF(MEEV.EQ.2) THEN
14288 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14291 C...Translate t into Q2 scale; choose between QCD and QED evolution.
14292 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14293 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14294 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14295 C...Ensure that Q2 is above threshold for charm/bottom.
14297 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14299 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14300 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14301 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14302 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14305 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14307 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14310 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14311 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14312 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14313 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14314 IF(Q2EB.GT.Q2MNE) MCE=2
14315 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14316 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14317 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14318 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14319 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14320 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14322 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14323 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14326 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14327 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14330 C...Evolution possibly ended. Update t values.
14334 ELSEIF(MCE.EQ.1) THEN
14337 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14338 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14342 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14345 C...Select flavour for branching parton.
14346 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14347 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14350 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14351 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14352 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14353 IF(KFLA.EQ.25) THEN
14358 C...Choose z value and corrective weight.
14360 C...q -> q + g or q -> q + gamma.
14361 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14362 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14363 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14364 WTZ=0.5D0*(1D0+Z**2)
14366 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14367 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14368 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14369 C...f -> f + gamma.
14370 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14371 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14372 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14373 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14375 Z=XB+XB*(XEE/(1D0-XEE))*
14376 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14378 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14379 C...f -> gamma + f.
14380 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
14381 Z=XB+XB*(XEE/(1D0-XEE))*
14382 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14383 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
14385 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14386 Z=XB+XB*(XEE/(1D0-XEE))*
14387 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14388 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14389 & (Q2B/(Q2B+PMAS(24,1)**2))
14391 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14392 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14393 WTZ=1D0-2D0*Z*(1D0-Z)
14395 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14396 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14397 WTZ=(1D0-Z*(1D0-Z))**2
14398 C...gamma -> f + fbar.
14399 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14400 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14401 WTZ=1D0-2D0*Z*(1D0-Z)
14403 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14405 C...Option with resummation of soft gluon emission as effective z shift.
14407 IF(MSTP(65).GE.1) THEN
14409 IF(KFLB.NE.21) RSOFT=8D0/3D0
14410 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14411 IF(Z.LE.XB) GOTO 220
14414 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14415 IF(MSTP(64).GE.2) THEN
14416 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14417 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14418 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14419 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14423 C...Remove kinematically impossible branchings.
14424 UHAT=Q2B-DSH*(1D0-Z)/Z
14425 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14427 C...Select phi angle of branching at random.
14428 PHIBR=PARU(2)*PYR(0)
14430 C...Matrix-element corrections for some processes.
14431 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14432 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14433 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14435 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14436 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14438 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14439 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14441 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14442 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14447 C...Impose angular constraint in first branching from interference
14448 C...with final state partons.
14450 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14451 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14452 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14453 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14454 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14455 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14459 C...Option with angular ordering requirement.
14460 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14461 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14462 IF(THE2T.GT.THE2(JT)) GOTO 220
14466 C...Weighting with new parton distributions.
14467 MINT(105)=MINT(102+JT)
14468 MINT(109)=MINT(106+JT)
14469 VINT(120)=VINT(2+JT)
14470 IF(MINT(31).GE.2) MINT(30)=JT
14472 C.... Store side in MINT(124)
14475 IF(MSTP(57).LE.1) THEN
14476 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14478 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14481 IF(XFBN.LT.1D-20) THEN
14482 IF(KFLA.EQ.KFLB) THEN
14488 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14489 TEVCB=0.5D0*(TEVCBS+TEVCB)
14491 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14492 TEVEB=0.5D0*(TEVEBS+TEVEB)
14504 C.... Store side in MINT(124)
14507 IF(MINT(31).GE.2) MINT(30)=JT
14508 IF(MSTP(57).LE.1) THEN
14509 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14511 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14514 IF(XFAN.LT.1D-20) GOTO 200
14516 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14518 C...Define two hard scatterers in their CM-frame.
14519 260 IF(N.EQ.NS+2) THEN
14521 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14524 IF(JR.EQ.1) IPO=IPUS1
14525 IF(JR.EQ.2) IPO=IPUS2
14535 P(I,3)=DPLCM*(-1)**(JR+1)
14536 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14537 P(I,5)=-SQRT(DQ2(JR))
14540 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14541 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14542 MCT(I,1)=MCT(IPO,1)
14543 MCT(I,2)=MCT(IPO,2)
14546 C...Find maximum allowed mass of timelike parton.
14547 ELSEIF(N.GT.NS+2) THEN
14552 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14553 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14554 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14555 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14556 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14558 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14559 & 1D-10*DPD(1)) IKIN=1
14560 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14561 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14562 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14563 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14565 C...Generate timelike parton shower (if required).
14572 C...f -> f + g (gamma).
14573 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14575 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14576 C...f -> g (gamma, W+-) + f.
14577 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14579 IF(KFLS(JT+2).EQ.24) THEN
14581 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14584 C...g (gamma) -> f + fbar, g + g.
14586 K(IT,2)=-KFLS(JT+2)
14587 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14590 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14591 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14592 P(IT,5)=PYMASS(K(IT,2))
14593 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14594 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14597 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14598 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14599 IF(MSTP(63).EQ.1) THEN
14601 ELSEIF(MSTP(63).EQ.2) THEN
14602 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14606 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14607 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14608 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14609 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14610 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14612 C...Only do timelike shower here if using PYSHOW
14613 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14614 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14618 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14621 C...Reconstruct kinematics of branching: timelike parton shower.
14623 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14624 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14625 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14626 & (4D0*DSH*DPC(3)**2)
14627 IF(DPT2.LT.0D0) GOTO 100
14628 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14629 & DSHR)/DPC(3)-DPC(3)
14631 P(IT,3)=DPB(1)*(-1)**(JT+1)
14632 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14634 DPB(1)=SQRT(DPB(1)**2+DPT2)
14635 DPB(2)=SQRT(DPB(1)**2+DMS)
14637 DPB(4)=SQRT(DPB(3)**2+DMS)
14638 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14640 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14641 THE=PYANGL(P(IT,3),P(IT,1))
14642 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14645 C...Reconstruct kinematics of branching: spacelike parton.
14654 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14655 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14656 P(N+1,5)=-SQRT(DQ2(3))
14660 C...Define colour flow of branching.
14665 C...f -> f + gamma (Z, W).
14666 IF(IABS(K(IT,2)).GE.22) THEN
14670 C...f -> gamma (Z, W) + f.
14671 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14674 C...gamma -> q + qbar, g + g.
14675 ELSEIF(K(N+1,2).EQ.22) THEN
14681 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14685 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14688 C...qbar -> qbar + g.
14689 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14692 C...qbar -> g + qbar.
14693 ELSEIF(K(N+1,2).LT.0) THEN
14696 C...g -> g + g; g -> q + qbar.
14697 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14704 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14705 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14706 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14707 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14708 IF(ID1.NE.ID2) THEN
14709 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14710 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14713 IF(K(IT,1).EQ.1) THEN
14718 C...Boost to new CM-frame.
14719 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14720 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14721 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14722 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14723 IR=N+(JT-1)*(IS(1)-N)
14724 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14727 C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14728 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14731 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14734 C...Global statistics.
14735 MINT(352)=MINT(352)+1
14736 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14737 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14741 C...Update kinematics variables.
14744 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14747 C...Save quantities; loop back.
14751 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14752 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14753 KFLS(JT+2)=KFLS(JT)
14758 XFS(JT,KFL)=XFA(KFL)
14767 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14768 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14769 IF(MSTU(21).GE.1) N=NS
14770 IF(MSTU(21).GE.1) RETURN
14772 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14774 C...Boost hard scattering partons to frame of shower initiators.
14776 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14782 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14783 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14784 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14786 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14787 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14788 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14790 C...Store user information. Reset Lambda value.
14791 IF(MINT(31).LE.1) THEN
14792 K(IPU1,3)=MINT(83)+3
14793 K(IPU2,3)=MINT(83)+4
14795 K(IPU1,3)=MINT(83)+1
14796 K(IPU2,3)=MINT(83)+2
14799 MINT(12+JT)=KFLS(JT)
14800 VINT(140+JT)=XS(JT)
14801 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14802 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14809 C*********************************************************************
14812 C...Generates pT-ordered spacelike initial-state parton showers and
14813 C...trial joinings.
14814 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14815 C... interaction initiators at PT2NOW.
14816 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14817 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14818 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14819 C... is below PT2CUT.
14820 C... (Also generate test joinings if MSTP(96)=1.)
14821 C...MODE= 1: Accept stored shower branching. Update event record etc.
14822 C...PT2NOW : Starting (max) PT2 scale for evolution.
14823 C...PT2CUT : Lower limit for evolution.
14824 C...PT2 : Result of evolution. Generated PT2 for trial emission.
14825 C...IFAIL : Status return code. IFAIL=0 when all is well.
14827 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14829 C...Double precision and integer declarations.
14830 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14831 IMPLICIT INTEGER(I-N)
14832 INTEGER PYK,PYCHGE,PYCOMP
14833 C...Parameter statement for maximum size of showers.
14834 PARAMETER (MAXNUR=1000)
14836 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14837 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14839 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14840 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14841 COMMON/PYINT1/MINT(400),VINT(400)
14842 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14843 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14844 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14845 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14846 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14847 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14848 COMMON/PYCTAG/NCT,MCT(4000,2)
14849 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14850 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14851 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14852 C...Local variables
14853 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14854 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14855 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14856 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14857 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14858 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14859 C...For check on excessive weights.
14862 C...Only give errors for very large weights, otherwise just warnings
14863 DATA WTEMAX /1.5D0/
14864 C...Only give errors for large pT, otherwise just warnings
14869 C----------------------------------------------------------------------
14870 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14871 C...starting from the hardest interaction initiators.
14872 IF (MODE.EQ.-1) THEN
14873 C...Set hard scattering SHAT.
14875 C...Mass thresholds and Lambda for QCD evolution.
14876 AEM2PI=PARU(101)/PARU(2)
14880 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14881 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14882 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14883 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14884 C...Optionally use Lambda_MC = Lambda_CMW
14885 IF (MSTP(64).EQ.3) THEN
14886 ALAM5 = ALAM5 * 1.569
14887 ALAM4 = ALAM4 * 1.618
14888 ALAM3 = ALAM3 * 1.661
14892 C...Massive quark forced creation threshold (in M**2).
14894 C...Set upper limit for X (ensures some X left for beam remnant).
14895 XMXC=1D0-2D0*PARP(111)/VINT(1)
14897 IF (MSTP(61).GE.1) THEN
14898 C...Initial values: flavours, momenta, virtualities.
14902 C...Special kinematics check for c/b quarks (that g -> c cbar or
14903 C...b bbar kinematically possible).
14904 KFLB=K(IMI(JS,1,1),2)
14906 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14907 C...Check PT2MAX > mQ^2
14908 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14909 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14910 & 'No Q creation possible.')
14914 C...Check for physical z values (m == MQ / sqrt(s))
14915 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14916 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14917 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14918 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14919 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14930 C...Zero joining array
14936 C----------------------------------------------------------------------
14937 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14938 C...MINT(30). Store if emission PT2 scale is largest so far.
14939 C...Also generate test joinings if MSTP(96)=1.
14940 ELSEIF(MODE.EQ.0) THEN
14945 C...No shower for structureless beam
14946 IF (MINT(44+JS).EQ.1) RETURN
14949 C...Absolute shower max scale = VINT(56)
14950 IF (MSTP(67).NE.0) THEN
14951 PT2 = MIN(PT2NOW,VINT(56))
14953 C...For MSTP(67)=0, adjust starting scale by PARP(67)
14954 PT2=MIN(PT2NOW,PARP(67)*VINT(56))
14956 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14957 C...Define for which processes ME corrections have been implemented.
14958 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14959 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14960 & .142.OR.ISUB.EQ.144) MECOR=1
14961 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14962 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14963 C...Calculate preweighting factor for ME-corrected processes.
14964 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14966 C...Basic info on daughter for which to find mother.
14967 KFLB=K(IMI(JS,MI,1),2)
14969 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14970 C...second companion.
14971 KSVCB=MAX(-1,IMI(JS,MI,2))
14972 C...Treat "first" companion of a pair like an ordinary sea quark
14973 C...(except that creation diagram is not allowed)
14974 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14975 C...X (rescaled to [0,1])
14976 XB=XMI(JS,MI)/VINT(142+JS)
14977 C...Massive quarks (use physical masses.)
14980 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14982 IF (KFLBA.EQ.5) RMQ2=RMB2
14983 C...Special threshold treatment for non-photon beams
14984 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14985 C...Check that not below mass threshold.
14986 IF(MQMASS.GT.0.AND.PT2.LT.TMIN*RMQ2) THEN
14987 CALL PYERRM(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '//
14988 & 'No Q creation possible.')
14990 C...Special return code if failing before any evolution at all: bad event
14991 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
14997 C...Flags for parton distribution calls.
14998 MINT(105)=MINT(102+JS)
14999 MINT(109)=MINT(106+JS)
15000 VINT(120)=VINT(2+JS)
15003 C.... Store side in MINT(124)
15005 C...Calculate initial parton distribution weights.
15006 IF(XB.GE.XMXC) THEN
15008 ELSEIF(MQMASS.EQ.0) THEN
15009 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15011 C...Initialize massive quark PT2 dependent pdf underestimate.
15013 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
15014 C.!.Tentative treatment of massive valence quarks.
15015 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
15017 TPM0=LOG(PT20/RMQ2)
15020 IF (KFLBA.LE.6) THEN
15021 C...For quarks, only include respective sea, val, or cmp part.
15022 IF (KSVCB.LE.0) THEN
15023 XFB(KFLB)=XPSVC(KFLB,KSVCB)
15025 C...Find companion's companion
15028 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
15032 C...Momentum fraction of the companion quark.
15033 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
15035 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15039 C...Determine overestimated z range: switch at c and b masses.
15040 130 IF (PT2.GT.TMIN*RMB2) THEN
15042 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
15045 ELSEIF(PT2.GT.TMIN*RMC2) THEN
15047 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
15056 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
15057 ALAM2=ALAM2/PARP(64)
15058 C...Overestimated ZMAX:
15059 IF (MQMASS.EQ.0) THEN
15061 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
15064 C...Massive (limit for bremsstrahlung diagram > creation)
15065 FMQ=SQRT(RMQ2/SHTNOW(MI))
15070 C...If kinematically impossible then do not evolve.
15071 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
15073 C...Reset Altarelli-Parisi and PDF weights.
15080 C...Zero joining weights and compute X(partner) and X(mother) values.
15082 IF (MSTP(96).NE.0) THEN
15083 DO 150 MJ=1,MINT(31)
15086 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
15087 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
15092 C...Approximate Altarelli-Parisi weights (integrated AP dz).
15093 C...q -> q, g -> q or q -> q + gamma (already set which).
15094 IF(KFLBA.LE.5) THEN
15095 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
15096 IF (KSVCB.LT.0) THEN
15097 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
15099 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
15100 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
15101 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
15103 WTAP(21)=0.5D0*(ZMAX-ZMIN)
15104 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
15105 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
15106 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15107 WTAP(KFLB)=WTFF*WTAP(KFLB)
15108 WTAP(21)=WTGF*WTAP(21)
15111 IF(MSTP(61).EQ.1) WTAPE=0D0
15112 IF (KSVCB.GE.1) THEN
15113 C...Kill normal creation but add joining diagrams for cmp quark.
15115 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
15116 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
15117 & " quark here. Not handled yet, giving up!")
15122 C...Check for possible joinings
15123 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
15124 C...Find companion's companion.
15127 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
15128 IF (MJOIND(JS,MJ).EQ.0) THEN
15131 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
15132 IF (WTAPJ(MJ).GT.1D-6) THEN
15138 C...Add trial gluon joinings.
15139 DO 170 MJ=1,MINT(31)
15140 KFLC=K(IMI(JS,MJ,1),2)
15141 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
15142 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
15143 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
15144 IF (WTAPJ(MJ).GT.1D-6) THEN
15151 ELSEIF (IMI(JS,MI,2).GE.0) THEN
15152 C...Kill creation diagram for val quarks and sea quarks with companions.
15154 ELSEIF (MQMASS.EQ.0) THEN
15155 C...Extra safety factor for massless sea quark creation.
15156 WTAP(21)=WTAP(21)*1.25D0
15159 C... q -> g, g -> g.
15160 ELSEIF(KFLB.EQ.21) THEN
15161 C...Here we decide later whether a quark picked up is valence or
15162 C...sea, so we maintain the extra factor sqrt(z) since we deal
15163 C...with the *sum* of sea and valence in this context.
15164 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
15165 C...new: do not allow backwards evol to pick up heavy flavour.
15166 DO 180 KFL=1,MIN(3,MSTP(58))
15170 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
15171 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15173 WTAP(21)=WTGG*WTAP(21)
15175 C...Check for possible joinings (companions handled separately above)
15176 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
15178 DO 190 MJ=1,MINT(31)
15179 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
15181 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
15182 IF (KSVCC.GE.1) GOTO 190
15183 KFLC=K(IMI(JS,MJ,1),2)
15184 C...Only try g -> g + g once.
15185 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
15186 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
15187 IF (KFLC.EQ.21) THEN
15188 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
15190 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
15192 IF (WTAPJ(MJ).GT.1D-6) THEN
15201 C...Initialize massive quark evolution
15202 IF (MQMASS.NE.0) THEN
15203 RML=(RMQ2+VINT(18))/ALAM2
15205 TPL=LOG((PT2+VINT(18))/ALAM2)
15206 TPM=LOG((PT2+VINT(18))/RMQ2)
15207 WN=WTAP(21)*WPDF0/B0
15211 C...Loopback point for iteration
15215 IF(NTRY.GT.500) THEN
15216 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
15221 C... Calculate PDF weights and sum for evolution rate.
15223 XFBO=MAX(1D-10,XFB(KFLB))
15225 WTPDF(KFL)=XFB(KFL)/XFBO
15226 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
15228 C...Only add gluon mother diagram for massless KFLB.
15229 IF(MQMASS.EQ.0) THEN
15230 WTPDF(21)=XFB(21)/XFBO
15231 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
15233 WTSUM=MAX(0.0001D0,WTSUM)
15235 C...Add joining diagrams where applicable.
15237 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15238 DO 220 MJ=1,MINT(31)
15239 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
15240 WTPDFJ(MJ)=1D0/XFBO
15241 C...x and x*pdf (+ sea/val) for parton C.
15242 KFLC=K(IMI(JS,MJ,1),2)
15244 KSVCC=MAX(-1,IMI(JS,MJ,2))
15245 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
15249 C.... Store side in MINT(124)
15254 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15256 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
15257 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15258 ELSEIF (KSVCC.GE.1) THEN
15259 print*, 'error! parton C is companion!'
15261 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
15262 C...x and x*pdf (+ sea/val) for parton A.
15265 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15268 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15274 C.... Store side in MINT(124)
15277 IF (KSVCA.LE.0) THEN
15278 C...Consider C the "evolved" parton if B is gluon. Val/sea
15279 C...counting will then be done correctly in PYPDFU.
15280 IF (KFLBA.EQ.21) MINT(36)=MJ
15281 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15283 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15285 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15286 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15288 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15289 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15293 C...Pick normal pT2 (in overestimated z range).
15296 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15299 C...Evolve q -> q gamma separately, pick it if larger pT.
15300 IF(KFLBA.LE.5.AND.MSTP(61).GE.2) THEN
15301 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15302 IF(PT2QED.GT.PT2) THEN
15309 C... Evolve massive quark creation separately.
15311 IF (MQMASS.NE.0) THEN
15312 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
15314 C...If massive quark also on opposite side, ensure sufficient remaining
15315 C...phase space also for creation of that quark
15317 KFLOPP = K(IMI(3-JS,MI,1),2)
15318 IF (ABS(KFLOPP).EQ.4.OR.ABS(KFLOPP).EQ.5) TMINQQ = 1.05
15319 C...Ensure mininimum PT2CR and force creation near threshold.
15320 IF (PT2CR.LT.TMINQQ*RMQ2) THEN
15322 IF (NTHRES.GT.50) THEN
15323 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15324 & 'massive quark creation. Gave up trying.')
15326 C...Special return code if failing before any evolution at all: bad event
15327 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15332 C...Signal that massive quark creation is being forced
15335 C... Select largest PT2 (brems or creation):
15336 IF (PT2CR.GT.PT2) THEN
15345 C... Compute logarithms for this PT2
15346 TPL=LOG((PT2+VINT(18))/ALAM2)
15347 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15348 WTCRQQ=TPM/LOG(PT2/RMQ2)
15351 C...Evolve joining separately
15353 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15354 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15356 IF (PT2JN.GE.PT2) THEN
15362 C...Loopback if crossed c/b mass thresholds.
15363 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15366 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15371 C...Speed up shower. Skip if higher-PT acceptable branching
15372 C...already found somewhere else.
15373 C...Also finish if below lower cutoff.
15375 IF ((PT2-PT2MX).LT.-0.001.OR.PT2.LT.PT2CUT) RETURN
15377 C...Select parton A flavour (massive Q handled above.)
15378 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15382 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15383 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15384 IF(KFLA.EQ.6) KFLA=21
15385 ELSEIF (MJOIN.EQ.1) THEN
15386 C...Tentative joining accept/reject.
15387 WTRAN=PYR(0)*WTJOIN
15390 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15391 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15392 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15393 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15397 C...x*pdf (+ sea/val) at new pT2 for parton B.
15398 IF (KSVCB.LE.0) THEN
15401 C.... Store side in MINT(124)
15404 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15405 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15407 C...Companion distributions do not evolve.
15410 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15411 KFLC=K(IMI(JS,MJ,1),2)
15413 KSVCC=MAX(-1,IMI(JS,MJ,2))
15414 IF (KSVCB.GE.1) KSVCC=-1
15415 C...x*pdf (+ sea/val) at new pT2 for parton C.
15419 C.... Store side in MINT(124)
15422 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15424 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15425 WTVETO=WTVETO/XFJ(KFLC)
15426 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15429 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15432 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15436 IF (KSVCA.LE.0) THEN
15439 C.... Store side in MINT(124)
15442 IF (KFLB.EQ.21) MINT(36)=MJ
15443 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15445 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15447 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15449 WTVETO=WTVETO*XFJ(KFLA)
15450 C...Monte Carlo veto.
15451 IF (WTVETO.LT.PYR(0)) GOTO 200
15452 C...If accept, save PT2 of this joining.
15453 IF (PT2.GT.PT2MX) THEN
15461 C...Exit and continue evolution.
15466 C...Choose z value (still in overestimated range) and corrective weight.
15467 C...Unphysical z will be rejected below when Q2 has is computed.
15470 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15471 C...q -> q + g or q -> q + gamma (already set which).
15472 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15473 IF (KSVCB.LT.0) THEN
15474 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15476 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15477 Z=((1-ZFAC)/(1+ZFAC))**2
15479 WTZ=0.5D0*(1D0+Z**2)
15480 C...Massive weight correction.
15481 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15482 C...Valence quark weight correction (extra sqrt)
15483 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15486 C...NB: MQ>0 not yet implemented. Forced absent above.
15487 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15489 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15490 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15493 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15495 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15496 WTZ=Z**2+(1D0-Z)**2
15497 C...Massive correction
15498 IF (MQMASS.NE.0) THEN
15499 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15500 C...Extra safety margin for light sea quark creation
15501 ELSEIF (KSVCB.LT.0) THEN
15506 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15508 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15509 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15510 WTZ=(1D0-Z*(1D0-Z))**2
15513 C...Derive Q2 from pT2.
15515 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15517 C...Loopback if outside allowed z range for given pT2.
15518 RM2C=PYMASS(KFLC)**2
15519 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15520 IF (PT2ADJ.LT.1D-6) GOTO 230
15522 C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15523 C...No modification for very first emission if using ME correction
15525 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15529 C...For 1st branching, limit phase space by s-hat with color-partner
15530 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15533 C...Use anticolor tag for antiquark, or for gluon half the time
15534 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15535 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15537 MCTAG=MCT(IDIP,MSIDE)
15538 C...Default is to set up phase space using the opposite incoming parton
15539 JDIP=IMI(3-JS,MI,1)
15541 C...Alternatively, look for final-state color partner (pick first if several)
15543 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15548 C...Compute momentum transfer: sdip = -t = - (p1 - p2)^2
15549 C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2)
15550 SDIP=ABS(((P(IDIP,4)-P(JDIP,4))**2-(P(IDIP,3)-P(JDIP,3))**2
15551 & -(P(IDIP,2)-P(JDIP,2))**2-(P(IDIP,1)-P(JDIP,1))**2))
15552 IF (MSTP67.EQ.1) THEN
15553 C...1 Option to completely kill radiation above s_dip * PARP(67)
15554 IF (4D0*PT2.GT.PARP(67)*SDIP) GOTO 230
15555 ELSE IF (MSTP67.EQ.2) THEN
15556 C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15557 C... (-> improved power showers?)
15558 IF (4D0*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15561 C...For subsequent branchings, loopback if nonordered in angle/rapidity
15562 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15563 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15567 C...Select phi angle of branching at random.
15570 C...Matrix-element corrections for some processes.
15571 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15572 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15573 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15575 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15576 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15578 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15579 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15581 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15582 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15587 C...Parton distributions at new pT2 but old x.
15590 C.... Store side in MINT(124)
15593 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15594 C...Treat val and cmp separately
15595 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15597 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15599 IF(XFBN.LT.1D-20) THEN
15600 IF(KFLA.EQ.KFLB) THEN
15613 C...Parton distributions at new pT2 and new x.
15617 C.... Store side in MINT(124)
15620 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15621 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15622 C...q -> q + g: only consider respective sea, val, or cmp content.
15623 IF (KSVCB.LE.0) THEN
15624 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15627 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15631 IF(XFAN.LT.1D-20) THEN
15635 C...If weighting fails continue evolution.
15637 IF (MCRQQ.EQ.0) THEN
15638 WTPDFA=1D0/WTPDF(KFLA)
15639 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15640 ELSEIF(MCRQQ.EQ.1) THEN
15642 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15644 ELSEIF(MCRQQ.EQ.2) THEN
15645 C...Force massive quark creation.
15649 C...Loop back if trial emission fails.
15650 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15651 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15652 IF(WTTOT.LT.0D0) THEN
15653 WRITE(CHWT,'(1P,E12.4)') WTTOT
15654 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15655 ELSEIF(WTTOT.GT.WTACC) THEN
15656 WRITE(CHWT,'(1P,E12.4)') WTTOT
15657 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15658 C...Too high weight: write out as error, but do not update error counter
15659 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15661 & '(PYPTIS:) Weight '//CHWT//' above unity')
15662 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15663 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15666 & '(PYPTIS:) Weight '//CHWT//' above unity')
15668 C...Useful for debugging but commented out for distribution:
15669 C print*, 'JS, MI',JS, MI
15670 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15671 C print*, 'A -> B C',KFLA, KFLB, KFLC
15673 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15676 C...Special for PT2 = PT2MX (e.g., if two incoming massive quarks
15677 C...simultaneously reached their creation thresholds)
15678 IF (ABS(PT2-PT2MX).LT.0.001) THEN
15679 IF (PYR(0).GT.0.5) PT2=1.0001*PT2MX
15682 C...Save acceptable branching.
15683 IF(PT2.GT.PT2MX) THEN
15696 C----------------------------------------------------------------------
15697 C...MODE= 1: Accept stored shower branching. Update event record etc.
15698 ELSEIF (MODE.EQ.1) THEN
15703 C...Shift down rest of event record to make room for insertion.
15708 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15709 KT1=K(I,4)/MSTU(5)**2
15710 KT2=K(I,5)/MSTU(5)**2
15711 ID1=MOD(K(I,4),MSTU(5))
15712 ID2=MOD(K(I,5),MSTU(5))
15713 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15714 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15715 IF (ID1.GE.IT) ID1=ID1+2
15716 IF (ID2.GE.IT) ID2=ID2+2
15717 IF (IM1.GE.IT) IM1=IM1+2
15718 IF (IM2.GE.IT) IM2=IM2+2
15719 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15720 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15726 MCT(I+2,1)=MCT(I,1)
15727 MCT(I+2,2)=MCT(I,2)
15730 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15731 DO 300 JI=1,MINT(31)
15732 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15733 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15734 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15735 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15736 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15737 C...Also update companion pointers to the present mother.
15738 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15741 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15743 C...Zero entries dedicated for new timelike and mother partons.
15754 C...Define timelike and new mother partons. History.
15761 C...Set mother origin = side.
15762 K(IM,3)=MINT(83)+JS+2
15763 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15765 C...Define colour flow of branching.
15768 C...q -> q + gamma.
15769 IF(K(IT,2).EQ.22) THEN
15774 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15778 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15781 C...qbar -> qbar + g.
15782 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15785 C...qbar -> g + qbar.
15786 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15789 C...g -> g + g; g -> q + qbar..
15790 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15797 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15798 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15799 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15800 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15801 IF(ID1.NE.ID2) THEN
15802 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15803 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15805 IF(K(IT,1).EQ.1) THEN
15809 C...Update IMI and colour tag arrays.
15817 C...If mother flag not yet set for spacelike parton, trace it.
15818 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15819 IF(MINT(51).NE.0) RETURN
15823 C...If mother flag not yet set for timelike parton, trace it.
15824 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15825 IF(MINT(51).NE.0) RETURN
15828 C...Boost recoiling parton to compensate for Q2 scale.
15829 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15830 & (1D0+(1D0+Q2BMX/SHAT)**2)
15832 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15834 C...Define system to be rotated and boosted
15835 C...(not including the 2 just added partons)
15836 C...(but including the docu lines for first interaction)
15837 IMIN=IMISEP(MI-1)+1
15838 IF (MI.EQ.1) IMIN=MINT(83)+5
15841 C...Rotate back system in phi to compensate for subsequent rotation.
15842 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15844 C...Define kinematics of new partons in old frame.
15846 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15847 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15848 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15849 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15851 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15852 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15853 P(IT,5)=SQRT(RM2CMX)
15855 C...Update internal line, now spacelike
15856 P(IS,1)=P(IM,1)-P(IT,1)
15857 P(IS,2)=P(IM,2)-P(IT,2)
15858 P(IS,3)=P(IM,3)-P(IT,3)
15859 P(IS,4)=P(IM,4)-P(IT,4)
15860 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15861 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15862 IF (P(IS,5).LT.0D0) THEN
15863 P(IS,5)=-SQRT(ABS(P(IS,5)))
15865 P(IS,5)=SQRT(P(IS,5))
15868 C...Boost entire system and rotate to new frame.
15869 C...(including docu lines)
15870 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15871 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15872 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15873 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15878 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15880 THETA=PYANGL(P(I1,3),P(I1,1))
15881 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15883 C...Global statistics.
15884 MINT(352)=MINT(352)+1
15885 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15886 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15888 C...Add parton with relevant pT scale for timelike shower.
15889 IF (K(IT,2).NE.22) THEN
15892 PTPART(NPART)=SQRT(PT2AMX)
15895 C...Update saved variables.
15896 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15897 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15898 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15899 PT2SAV(JSMX,MIMX)=PT2MX
15904 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15905 C...Gluon reconstructs to quark.
15906 C...Decide whether newly created quark is valence or sea:
15908 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15909 IF(MINT(51).NE.0) RETURN
15911 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15912 C...Quark reconstructs to gluon.
15913 C...Now some guy may have lost his companion. Check.
15915 IF (ICMP.GT.0) THEN
15916 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15917 & //' away. Cannot handle that yet. Giving up.')
15920 ELSEIF(ICMP.LT.0) THEN
15921 C...A sea quark with companion still in BR was reconstructed to a gluon.
15922 C...Companion should now be removed from the beam remnant.
15923 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15926 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15927 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15928 DO 370 JI=1,MINT(31)
15930 JFL=-K(IMI(JS,JI,1),2)
15931 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15935 NVC(JS,IFL)=NVC(JS,IFL)-1
15937 C...Set gluon IMI(JS,MI,2) = 0.
15939 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15940 C...Quark reconstructing to quark. If sea with companion still in BR
15941 C...then update associated x value.
15942 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15943 IF (IMI(JS,MI,2).LT.0) THEN
15946 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15952 C...If reached this point, normal exit.
15958 C*********************************************************************
15961 C...Generates maximum ME weight in some initial-state showers.
15962 C...Inparameter MECOR: kind of hard scattering process
15963 C...Outparameter WTFF: maximum weight for fermion -> fermion
15964 C... WTGF: maximum weight for gluon/photon -> fermion
15965 C... WTFG: maximum weight for fermion -> gluon/photon
15966 C... WTGG: maximum weight for gluon -> gluon
15968 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15970 C...Double precision and integer declarations.
15971 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15972 IMPLICIT INTEGER(I-N)
15973 INTEGER PYK,PYCHGE,PYCOMP
15975 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15976 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15977 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15978 COMMON/PYINT1/MINT(400),VINT(400)
15979 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15980 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15982 C...Default maximum weight.
15988 C...Select maximum weight by process.
15989 IF(MECOR.EQ.1) THEN
15992 ELSEIF(MECOR.EQ.2) THEN
16000 C*********************************************************************
16003 C...Calculates actual ME weight in some initial-state showers.
16004 C...Inparameter MECOR: kind of hard scattering process
16005 C... IFLCB: flavour combination of branching,
16006 C... 1 for fermion -> fermion,
16007 C... 2 for gluon/photon -> fermion
16008 C... 3 for fermion -> gluon/photon,
16009 C... 4 for gluon -> gluon
16010 C... Q2: Q2 value of shower branching
16011 C... Z: Z value of branching
16012 C...In+outparameter PHIBR: azimuthal angle of branching
16013 C...Outparameter WTME: actual ME weight
16015 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
16017 C...Double precision and integer declarations.
16018 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16019 IMPLICIT INTEGER(I-N)
16020 INTEGER PYK,PYCHGE,PYCOMP
16022 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16023 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16024 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16025 COMMON/PYINT1/MINT(400),VINT(400)
16026 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16027 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
16029 C...Default output.
16032 C...Define kinematics of shower branching in Mandelstam variables.
16036 UH=Q2-SQM*(1D0-Z)/Z
16038 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
16039 IF(MECOR.EQ.1) THEN
16040 IF(IFLCB.EQ.1) THEN
16041 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
16042 ELSEIF(IFLCB.EQ.2) THEN
16043 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
16046 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
16047 ELSEIF(MECOR.EQ.2) THEN
16048 IF(IFLCB.EQ.3) THEN
16049 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
16050 ELSEIF(IFLCB.EQ.4) THEN
16051 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
16054 C...Matrix-element corrections for q + qbar -> Higgs (h0)
16055 ELSEIF(MECOR.EQ.3) THEN
16056 IF(IFLCB.EQ.2) THEN
16057 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
16058 1 (SH**2+2D0*SQM*(SQM-SH))
16065 C*********************************************************************
16068 C...Handles the generation of additional interactions in the new
16069 C...multiple interactions framework.
16070 C...MODE=-1 : Initalize MI from scratch.
16071 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
16072 C... Sudakov for PT2, abort if below PT2CUT.
16073 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
16074 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
16075 C...PT2NOW : Starting (max) PT2 scale for evolution.
16076 C...PT2CUT : Lower limit for evolution.
16077 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
16078 C...IFAIL : Status return code.
16079 C... = 0: All is well.
16080 C... < 0: Phase space exhausted, generation to be terminated.
16081 C... > 0: Additional interaction vetoed, but continue evolution.
16083 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
16084 C...Double precision and integer declarations.
16085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16086 IMPLICIT INTEGER(I-N)
16087 INTEGER PYK,PYCHGE,PYCOMP
16088 C...Parameter statement for maximum size of showers.
16089 PARAMETER (MAXNUR=1000)
16091 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16092 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16093 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16094 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16095 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16096 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16097 COMMON/PYINT1/MINT(400),VINT(400)
16098 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16099 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
16100 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
16101 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
16102 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
16103 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
16104 & XMI(2,240),PT2MI(240),IMISEP(0:240)
16105 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
16106 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
16107 COMMON/PYCTAG/NCT,MCT(4000,2)
16108 C...Local arrays and saved variables.
16109 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
16111 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
16112 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
16113 & /PYISMX/,/PYCTAG/
16114 SAVE NCHN,XT2FAC,SIGS
16117 C...Set MI subprocess = QCD 2 -> 2.
16120 C----------------------------------------------------------------------
16121 C...MODE=-1: Initialize from scratch
16122 IF (MODE.EQ.-1) THEN
16123 C...Initialize PT2 array.
16125 C...Initialize list of incoming beams and partons from two sides.
16132 IMI(JS,1,1)=MINT(84)+JS
16134 XMI(JS,1)=VINT(40+JS)
16135 C...Rescale x values to fractions of photon energy.
16136 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
16137 C...Hard reset: hard interaction initiators motherless by definition.
16138 K(MINT(84)+JS,3)=2+JS
16139 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
16140 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
16144 IF (MOD(MSTP(81),10).GE.1) THEN
16145 IF(MSTP(82).LE.1) THEN
16146 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
16148 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
16149 & VINT(317)/(VINT(318)*VINT(320))
16150 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
16152 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
16153 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
16156 C...Zero entries relating to scatterings beyond the first.
16162 IMISEP(MI)=IMISEP(1)
16167 C...Initialize factors for PDF reshaping.
16169 KFBEAM(JS)=MINT(10+JS)
16170 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
16171 KFABM=IABS(KFBEAM(JS))
16172 KFSBM=ISIGN(1,KFBEAM(JS))
16174 C...Zero flavour content of incoming beam particle.
16178 C... Flavour content of baryon.
16179 IF(KFABM.GT.1000) THEN
16180 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
16181 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
16182 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
16183 C... Flavour content of pi+-, K+-.
16184 ELSEIF(KFABM.EQ.211) THEN
16185 KFIVAL(JS,1)=KFSBM*2
16186 KFIVAL(JS,2)=-KFSBM
16187 ELSEIF(KFABM.EQ.321) THEN
16188 KFIVAL(JS,1)=-KFSBM*3
16189 KFIVAL(JS,2)=KFSBM*2
16190 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
16193 C...Zero initial valence and companion content.
16198 C...Set up colour line tags starting from hard interaction initiators.
16200 C...Reset colour tag array and colour processing flags.
16201 DO 150 I=IMISEP(0)+1,N
16204 K(I,4)=MOD(K(I,4),MSTU(5)**2)
16205 K(I,5)=MOD(K(I,5),MSTU(5)**2)
16207 C... Consider each side in turn.
16212 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16214 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
16216 CALL PYCTTR(I1,KCS,I2)
16217 IF(MINT(51).NE.0) RETURN
16221 C...Range checking for companion quark pdf large-x param.
16222 IF (MSTP(87).LT.0) THEN
16223 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16226 ELSEIF (MSTP(87).GT.4) THEN
16227 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16232 C----------------------------------------------------------------------
16233 C...MODE=0: Generate trial interaction. Return codes:
16234 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
16235 C...IFAIL = 0: Additional interaction generated at PT2.
16236 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
16237 ELSEIF (MODE.EQ.0) THEN
16238 C...Abolute MI max scale = VINT(62)
16239 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
16240 180 IF(MSTP(82).LE.1) THEN
16241 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
16242 IF(XT2.LT.VINT(149)) IFAIL=-2
16244 IF(XT2.LE.0.01001D0*VINT(149)) THEN
16247 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
16248 & LOG(PYR(0)))-VINT(149)
16251 C...Also exit if below lower limit or if higher trial branching
16253 PT2=0.25D0*VINT(2)*XT2
16254 IF (PT2.LE.PT2CUT) IFAIL=-4
16255 IF (PT2.LE.PT2MX) IFAIL=-5
16256 IF (IFAIL.NE.0) THEN
16260 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
16261 VINT(25)=4D0*PT2/VINT(2)
16264 C...Choose tau and y*. Calculate cos(theta-hat).
16265 IF(PYR(0).LE.COEF(ISUB,1)) THEN
16266 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
16267 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
16269 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
16272 C...New: require shat > 1.
16273 IF(TAU*VINT(2).LT.1D0) GOTO 180
16277 IF(RYST.GT.COEF(ISUB,8)) MYST=2
16278 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
16279 CALL PYKMAP(2,MYST,PYR(0))
16280 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
16282 C...Check that x not used up. Accept or reject kinematical variables.
16283 X1M=SQRT(TAU)*EXP(VINT(22))
16284 X2M=SQRT(TAU)*EXP(-VINT(22))
16285 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
16286 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
16288 CALL PYSIGH(NCHN,SIGS)
16289 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16290 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16291 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16293 C...Save if highest PT so far.
16294 IF (PT2.GT.PT2MX) THEN
16300 C----------------------------------------------------------------------
16301 C...MODE=1: Generate and save accepted scattering.
16302 ELSEIF (MODE.EQ.1) THEN
16304 C...Reset K, P, V, and MCT vectors.
16316 C...Choose flavour of reacting partons (and subprocess).
16318 IF (NTRY.GT.50) THEN
16319 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16320 & //'interaction. Giving up!')
16328 ICONMI=ISIG(ICHN,3)
16329 RSIGS=RSIGS-SIGH(ICHN)
16330 IF(RSIGS.LE.0D0) GOTO 230
16333 C...Reassign to appropriate process codes.
16334 230 ISUBMI=ICONMI/10
16335 ICONMI=MOD(ICONMI,10)
16337 C...Choose new quark flavour for annihilation graphs
16338 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16339 SH=VINT(21)*VINT(2)
16340 CALL PYWIDT(21,SH,WDTP,WDTE)
16341 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16342 DO 250 I=1,MDCY(21,3)
16343 KFLF=KFDP(I+MDCY(21,2)-1,1)
16344 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16345 IF(RKFL.LE.0D0) GOTO 260
16347 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16348 IF(KFLF.GE.4) GOTO 240
16349 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16352 ELSEIF(ISUBMI.EQ.53) THEN
16358 C...Final state flavours and colour flow: default values
16365 IF(ISUBMI.EQ.11) THEN
16366 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16368 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16370 ELSEIF(ISUBMI.EQ.12) THEN
16371 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16372 KFL3=ISIGN(KFLF,KFL1)
16376 ELSEIF(ISUBMI.EQ.13) THEN
16377 C...f + fbar -> g + g; th arbitrary
16382 ELSEIF(ISUBMI.EQ.28) THEN
16383 C...f + g -> f + g; th = (p(f)-p(f))**2
16384 IF(KFL1.EQ.21) JS=2
16386 IF(KFL1.EQ.21) KCC=KCC+2
16387 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16388 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16390 ELSEIF(ISUBMI.EQ.53) THEN
16391 C...g + g -> f + fbar; th arbitrary
16392 KCS=(-1)**INT(1.5D0+PYR(0))
16393 KFL3=ISIGN(KFLF,KCS)
16397 ELSEIF(ISUBMI.EQ.68) THEN
16398 C...g + g -> g + g; th arbitrary
16400 KCS=(-1)**INT(1.5D0+PYR(0))
16403 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16404 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16405 & .OR.IABS(KFL4).EQ.5) THEN
16406 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16407 IF (PT2.LE.1.05*RMMAX2) THEN
16408 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16409 & //' too close to threshold (2nd try).')
16414 C...Store flavours of scattering.
16422 C...Set flavours and mothers of scattering partons.
16431 K(N+1,3)=MINT(83)+1
16432 K(N+2,3)=MINT(83)+2
16436 C...Store colour connection indices.
16439 IF(KCS.EQ.-1) JC=3-J
16440 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16441 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16442 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16443 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16446 C...Store incoming and outgoing partons in their CM-frame.
16447 SHR=SQRT(VINT(21))*VINT(1)
16450 P(N+2,3)=-0.5D0*SHR
16452 P(N+3,5)=PYMASS(K(N+3,2))
16453 P(N+4,5)=PYMASS(K(N+4,2))
16454 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16458 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16459 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16460 P(N+4,4)=SHR-P(N+3,4)
16463 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16465 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16467 C...Global statistics.
16468 MINT(351)=MINT(351)+1
16469 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16470 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16472 C...Keep track of loose colour ends and information on scattering.
16473 MINT(31)=MINT(31)+1
16475 PT2MI(MINT(36))=PT2
16476 IMISEP(MINT(31))=N+4
16478 IMI(JS,MINT(31),1)=N+JS
16479 IMI(JS,MINT(31),2)=0
16480 XMI(JS,MINT(31))=VINT(40+JS)
16482 C...Update cumulative counters
16483 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16484 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16487 C...Add to list of final state partons
16490 PTPART(NPART+1)=SQRT(PT2)
16491 PTPART(NPART+2)=SQRT(PT2)
16495 NISGEN(1,MINT(31))=0
16496 NISGEN(2,MINT(31))=0
16500 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16501 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16506 C...Finally, assign colour tags to new partons
16508 I1=IMI(JS,MINT(31),1)
16509 I2=IMI(3-JS,MINT(31),1)
16511 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16513 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16515 CALL PYCTTR(I1,KCS,I2)
16516 IF(MINT(51).NE.0) RETURN
16520 C----------------------------------------------------------------------
16521 C...MODE=2: Decide whether quarks in last scattering were valence,
16522 C...companion, or sea.
16523 ELSEIF (MODE.EQ.2) THEN
16527 KFSBM=ISIGN(1,MINT(10+JS))
16528 IFL=K(IMI(JS,MI,1),2)
16530 IF (IABS(IFL).GE.6) THEN
16531 IF (IABS(IFL).EQ.6) THEN
16532 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16536 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16537 C...(Do not include the parton itself in the X rescaling.)
16539 XRSC=X/(VINT(142+JS)+X)
16540 C...Note: XPSVC = x*pdf.
16543 C.... Store side in MINT(124)
16545 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16548 C...Ensure that pdfs are positive definite
16549 IF (SEA.LT.0D0) THEN
16550 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16552 ELSEIF (VAL.LT.0D0) THEN
16553 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16557 DO 310 IVC=1,NVC(JS,IFL)
16558 CMP=CMP+XPSVC(IFL,IVC)
16562 C...Decide (Extra factor x cancels in the dvision).
16563 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16566 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16567 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16569 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16570 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16571 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16572 IF(KFIVAL(JS,1).EQ.0) THEN
16573 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16574 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16575 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16576 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16578 C...Count down valence remaining. Do not count current scattering.
16579 DO 340 I1=1,NMI(JS)
16580 IF (I1.EQ.MINT(36)) GOTO 340
16581 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16585 IF(IVNOW.EQ.0) GOTO 330
16588 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16589 IF(KFIVAL(JS,1).EQ.0) THEN
16590 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16593 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16595 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16596 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16600 ELSEIF (RVCS.LE.VAL+SEA) THEN
16601 C...If sea, add opposite sign companion parton. Store X and I.
16602 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16603 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16604 C...Set pointer to companion
16605 IMI(JS,MI,2)=-NVC(JS,-IFL)
16608 C...If companion, check whether we've got any in the books
16609 IF (NVC(JS,IFL).EQ.0) THEN
16611 C...Only report error first time for this event
16613 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16614 C...Try a few times
16615 IF (NTRY.LE.10) THEN
16617 C... But if it stil fails, abort this event
16623 C...If several possibilities, decide which one
16627 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16628 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16629 C...Find original sea (anti-)quark. Do not consider current scattering.
16631 DO 360 I1=1,NMI(JS)
16632 IF (I1.EQ.MINT(36)) GOTO 360
16633 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16634 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16635 IMI(JS,MI,2)=IMI(JS,I1,1)
16636 IMI(JS,I1,2)=IMI(JS,MI,1)
16639 C...Mark companion "out-kicked".
16640 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16647 C*********************************************************************
16649 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16650 C...Giving the x*f pdf of a companion quark, with its partner at XS,
16651 C...using an approximate gluon density like (1-X)^NPOW/X. The value
16652 C...corresponds to an unrescaled range between 0 and 1-X.
16654 FUNCTION PYFCMP(XC,XS,NPOW)
16656 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16660 C...Parent gluon momentum fraction
16662 IF (Y.GE.1D0) RETURN
16663 C...Common factor (includes factor XC, since PYFCMP=x*f)
16664 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16665 C...Store normalized companion x*f distribution.
16666 IF (NPOW.LE.0) THEN
16667 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16668 ELSEIF (NPOW.EQ.1) THEN
16669 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16670 ELSEIF (NPOW.EQ.2) THEN
16671 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16672 & +3D0*XS*(1D0+XS)*LOG(XS)))
16673 ELSEIF (NPOW.EQ.3) THEN
16674 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16675 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16676 ELSEIF (NPOW.GE.4) THEN
16677 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16678 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16683 C*********************************************************************
16685 C...PYPCMP: Auxiliary to PYPDFU.
16686 C...Giving the momentum integral of a companion quark, with its
16687 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16688 C...The value corresponds to an unrescaled range between 0 and 1-XS.
16690 FUNCTION PYPCMP(XS,NPOW)
16692 DOUBLE PRECISION XS, PYPCMP
16694 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16696 ELSEIF (NPOW.LE.0) THEN
16697 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16698 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16699 ELSEIF (NPOW.EQ.1) THEN
16700 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16701 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16702 ELSEIF (NPOW.EQ.2) THEN
16703 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16704 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16705 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16706 & -3D0*XS*LOG(XS)*(1+XS)))
16707 ELSEIF (NPOW.EQ.3) THEN
16708 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16709 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16710 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16711 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16713 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16714 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16715 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16716 & -6D0*XS*LOG(XS)*(1D0+XS)))
16721 C*********************************************************************
16724 C...Rearranges contents of the HEPEUP commonblock so that
16725 C...mothers precede daughters and daughters of a decay are
16726 C...listed consecutively.
16730 C...Double precision and integer declarations.
16731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16732 IMPLICIT INTEGER(I-N)
16734 C...User process event common block.
16736 PARAMETER (MAXNUP=500)
16737 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16738 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16739 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16740 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16741 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16745 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16746 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16747 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16749 C...Check whether a rearrangement is required.
16752 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16755 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16759 C...Find the new order that particles should have.
16765 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16770 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16771 IF(NNEW.NE.NUP) THEN
16773 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16777 C...Copy old info into temporary storage.
16781 MOTUPT(1,I)=MOTHUP(1,I)
16782 MOTUPT(2,I)=MOTHUP(2,I)
16783 ICOUPT(1,I)=ICOLUP(1,I)
16784 ICOUPT(2,I)=ICOLUP(2,I)
16788 VTIUPT(I)=VTIMUP(I)
16789 SPIUPT(I)=SPINUP(I)
16792 C...Copy info back into HEPEUP in right order.
16795 IDUP(I)=IDUPT(IOLD)
16796 ISTUP(I)=ISTUPT(IOLD)
16800 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16801 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16803 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16805 MOTHUP(1,I)=MOTHUP(2,I)
16808 ICOLUP(1,I)=ICOUPT(1,IOLD)
16809 ICOLUP(2,I)=ICOUPT(2,IOLD)
16811 PUP(J,I)=PUPT(J,IOLD)
16813 VTIMUP(I)=VTIUPT(IOLD)
16814 SPINUP(I)=SPIUPT(IOLD)
16818 c...If incoming particles are massive recalculate to put them massless.
16819 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16820 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16821 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16822 PUP(4,1)=0.5D0*PPLUS
16825 PUP(4,2)=0.5D0*PMINUS
16833 C*********************************************************************
16836 C...Administers the generation of successive final-state showers
16837 C...in external processes.
16839 SUBROUTINE PYADSH(NFIN)
16841 C...Double precision and integer declarations.
16842 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16843 IMPLICIT INTEGER(I-N)
16844 INTEGER PYK,PYCHGE,PYCOMP
16845 C...Parameter statement for maximum size of showers.
16846 PARAMETER (MAXNUR=1000)
16848 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16849 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16850 COMMON/PYCTAG/NCT,MCT(4000,2)
16851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16852 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16853 COMMON/PYINT1/MINT(400),VINT(400)
16854 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16856 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16858 C...Set primary vertex.
16860 V(MINT(83)+5,J)=0D0
16861 V(MINT(83)+6,J)=0D0
16862 V(MINT(84)+1,J)=0D0
16863 V(MINT(84)+2,J)=0D0
16866 C...Isolate systems of particles with the same mother.
16869 DO 140 I=MINT(84)+3,NFIN
16871 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16878 C...Set production vertices.
16879 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16886 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16889 IF(MSTP(125).GE.1) THEN
16897 C...End loop over systems. Return if no showers to be performed.
16898 IBEG(NSYS+1)=NFIN+1
16899 IF(MSTP(71).LE.0) RETURN
16901 C...Loop through systems of particles; check that sensible size.
16903 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16904 IF(MINT(35).LE.2) THEN
16905 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16907 ELSEIF(NSIZ.LE.1) THEN
16908 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16910 ELSEIF(NSIZ.GT.80) THEN
16911 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16916 C...Save status codes and daughters of showering particles; reset them.
16923 IF(K(I,1).GT.10) THEN
16925 IF(KSAV(II,1).EQ.14) K(I,1)=3
16927 IF(KSAV(II,1).LE.10) THEN
16928 ELSEIF(K(I,1).EQ.1) THEN
16934 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16935 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16936 K(I,4)=K(I,4)-KSAV(II,4)
16937 K(I,5)=K(I,5)-KSAV(II,5)
16940 PSUM(J)=PSUM(J)+P(I,J)
16944 C...Perform shower.
16945 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16947 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16949 IF(MINT(35).LE.2) THEN
16951 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16953 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16956 C...For external processes, first call, also ISR partons radiate.
16957 C...Can use existing PYPART list, removing partons that radiate later.
16958 ELSEIF(ISYS.EQ.1) THEN
16961 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16963 IPART(NPARTN)=IPART(II)
16964 PTPART(NPARTN)=PTPART(II)
16968 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16970 C...For subsequent calls use the systems excluded above.
16976 PTPART(II)=0.5D0*QMAX
16978 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16981 C...Look up showered copies of original showering particles.
16985 C...Particles without daughters need not be studied.
16986 IF(KSAV(II,1).LE.10) GOTO 260
16987 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16988 ELSEIF(K(I,1).EQ.11) THEN
16989 190 IMV=MOD(K(IMV,4),MSTU(5))
16990 IF(K(IMV,1).EQ.11) GOTO 190
16992 KDA1=MOD(K(I,4),MSTU(5))
16994 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16996 KDA2=MOD(K(I,5),MSTU(5))
16998 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17001 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
17004 KDA1=MOD(K(I3,4),MSTU(5))
17006 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17008 KDA2=MOD(K(I3,5),MSTU(5))
17010 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17016 C...Restore daughter info of original partons to showered copies.
17017 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
17018 IF(KSAV(II,1).LE.10) THEN
17019 ELSEIF(K(I,1).EQ.1) THEN
17020 K(IMV,4)=KSAV(II,4)
17021 K(IMV,5)=KSAV(II,5)
17023 K(IMV,4)=K(IMV,4)+KSAV(II,4)
17024 K(IMV,5)=K(IMV,5)+KSAV(II,5)
17027 C...Reset mother info of existing daughters to showered copies.
17028 DO 210 I3=IBEG(ISYS+1),NFIN
17029 IF(K(I3,3).EQ.I) K(I3,3)=IMV
17030 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
17031 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
17032 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
17036 C...Boost all original daughters to new frame of showered copy.
17037 C...Also update their colour tags.
17040 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
17042 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
17044 BETA(J)=FAC*BETA(J)
17046 DO 250 I3=IBEG(ISYS+1),NFIN
17049 IF(MSTP(128).LE.0) THEN
17050 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
17051 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
17053 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
17054 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
17055 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
17058 IF(IMO.EQ.IMV) THEN
17059 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
17060 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
17061 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
17062 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
17070 C...End of loop over showering systems
17076 C*********************************************************************
17079 C...Interface to UPVETO, which allows user to veto event generation
17080 C...on the parton level, after parton showers but before multiple
17081 C...interactions, beam remnants and hadronization is added.
17083 SUBROUTINE PYVETO(IVETO)
17085 C...All real arithmetic in double precision.
17086 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17087 C...Three Pythia functions return integers, so need declaring.
17088 INTEGER PYK,PYCHGE,PYCOMP
17090 C...PYTHIA commonblocks.
17091 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17092 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17093 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17094 COMMON/PYINT1/MINT(400),VINT(400)
17095 SAVE /PYJETS/,/PYPARS/,/PYINT1/
17096 C...HEPEVT commonblock.
17097 PARAMETER (NMXHEP=4000)
17098 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17099 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
17100 DOUBLE PRECISION PHEP,VHEP
17103 DIMENSION IRESO(100)
17105 C...Define longitudinal boost from initiator rest frame to cm frame.
17106 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
17107 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
17109 C...Presentation is different if using pT-ordered shower
17110 IF(MINT(35).EQ.3) THEN
17115 C... Reset counters.
17120 C...Oth pass: identify beam and incoming partons
17121 DO 140 I=MINT(83)+1,MINT(83)+6
17123 IF(K(I,2).EQ.94) THEN
17132 C...First pass: identify final locations of resonances
17133 C...and of their daughters before showering.
17134 DO 150 I=MINT(84)+3,N
17138 C...Skip shower CM frame documentation lines.
17139 IF(K(I,2).EQ.94) THEN
17141 C... Store a new intermediate product, when mother in documentation.
17142 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
17143 & K(I,3).LE.MINT(84)) THEN
17149 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
17151 C... Store a new intermediate product, when mother in main section.
17152 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
17153 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
17159 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
17162 IF(ISTORE.EQ.1) THEN
17163 C...Copy parton info, boosting momenta along z axis to cm frame.
17168 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
17169 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
17171 C...Store one mother. Rest of history and vertex info zeroed.
17183 C...Second pass: identify current set of "final" partons.
17184 DO 200 I=MINT(84)+3,N
17188 C...Store a final parton.
17189 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
17193 C..Trace it back through shower, to check if from documented particle.
17197 IF(IHIST.GT.MINT(84)) THEN
17198 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
17200 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
17204 IF(IMOTH.EQ.0) GOTO 160
17205 IMOTH=MAX(0,IMOTH-6)
17206 ELSEIF(IHIST.LE.4) THEN
17207 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
17216 IF(ISTORE.EQ.1) THEN
17217 C...Copy parton info, boosting momenta along z axis to cm frame.
17222 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
17223 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
17225 C...Store one mother. Rest of history and vertex info zeroed.
17236 C...Call user-written routine to decide whether to keep events.
17240 C*********************************************************************
17243 C...Allows resonances to decay (including parton showers for hadronic
17246 SUBROUTINE PYRESD(IRES)
17248 C...Double precision and integer declarations.
17249 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17250 IMPLICIT INTEGER(I-N)
17251 INTEGER PYK,PYCHGE,PYCOMP
17252 C...Parameter statement to help give large particle numbers.
17253 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
17254 &KEXCIT=4000000,KDIMEN=5000000)
17255 C...Parameter statement for maximum size of showers.
17256 PARAMETER (MAXNUR=1000)
17258 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
17259 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17260 COMMON/PYCTAG/NCT,MCT(4000,2)
17261 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17262 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17263 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
17264 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17265 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17266 COMMON/PYINT1/MINT(400),VINT(400)
17267 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17268 COMMON/PYINT4/MWID(500),WIDS(500,5)
17269 COMMON/PYPUED/IUED(0:99),RUED(0:99)
17270 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
17271 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
17272 C...Local arrays and complex and character variables.
17273 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
17274 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(4),ILIN(6),
17275 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
17276 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),VDCY(4),
17277 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(4),ITRI(4),IOCT(4),KCQ4(3),
17279 COMPLEX FGK,HA(6,6),HC(6,6)
17281 CHARACTER CODE*9,MASS*9
17283 DIMENSION PV(10,5),RORD(10),UE(3),BE(3),WTCOR(10)
17284 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
17286 C...Functions: momentum in two-particle decays and four-product.
17287 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
17289 C...The F, Xi and Xj functions of Gunion and Kunszt
17290 C...(Phys. Rev. D33, 665, plus errata from the authors).
17291 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
17292 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
17293 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
17294 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
17295 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17296 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17297 &2D0*(D34/D56+D56/D34))
17299 C...Some general constants.
17302 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17306 GMMZ=PMAS(23,1)*PMAS(23,2)
17308 GMMW=PMAS(24,1)*PMAS(24,2)
17311 C...Boost and rotate to rest frame of incoming partons,
17312 C...to get proper amount of smearing of decay angles.
17318 C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17319 C...(101,102) are off shell and can have inconsistent momenta, resulting
17320 C...in boosts larger than unity. However, the corresponding docu partons
17321 C...(5,6) are kept on shell, and have consistent momenta that can be used
17322 C...to derive this boost instead. Ultimately, should change the way the new
17323 C...shower stores intermediate partons, but just using partons (5,6) for now
17324 C...does define the boost and furnishes a quick and much needed solution.
17325 IF (MINT(35).EQ.3) THEN
17329 ETOTIN=P(IIN1,4)+P(IIN2,4)
17330 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17331 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17332 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17333 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17334 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17335 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17336 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17337 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17340 C...Reset original resonance configuration.
17345 C...Define initial one, two or three objects for subprocess.
17349 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17350 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17351 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17353 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17354 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17355 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17356 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17357 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17359 ELSEIF(ISET(ISUB).EQ.5) THEN
17360 IREF(1,1)=MINT(84)+3
17361 IREF(1,2)=MINT(84)+4
17362 IREF(1,3)=MINT(84)+5
17363 IREF(1,4)=MINT(83)+7
17364 IREF(1,5)=MINT(83)+8
17365 IREF(1,6)=MINT(83)+9
17369 C...Define original resonance for odd cases.
17372 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17374 IF(IHDEC.EQ.1) ISUB=3
17376 IREF(1,4)=K(IRES,3)
17378 IF(IREF(1,4).GT.MINT(84)) THEN
17379 110 ITMPMO=IREF(1,4)
17380 IF(K(ITMPMO,2).EQ.94) THEN
17381 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17382 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17383 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17385 C...Explicitly check that reference particle exists, otherwise stop recursion
17386 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17387 IREF(1,4)=K(ITMPMO,3)
17392 IF(IREF(1,4).GT.MINT(84)) THEN
17395 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17396 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17399 EMATCH=ABS(P(II,4)-P(IREF14,4))
17406 C...Check if initial resonance has been moved (in resonance + jet).
17408 IF(IREF(1,JT).GT.0) THEN
17409 IF(K(IREF(1,JT),1).GT.10) THEN
17410 KFA=IABS(K(IREF(1,JT),2))
17411 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17412 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17413 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17414 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17415 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17417 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17418 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17420 DO 130 I=IREF(1,JT)+1,N
17421 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17424 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17425 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17426 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17427 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17429 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17430 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17435 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17436 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17442 C...Set decay vertex for initial resonances
17445 V(IREF(1,JT),I)=0D0
17449 C...Loop over decay history.
17455 IF(IREF(IP,2).EQ.0) JTMAX=1
17456 IF(IREF(IP,3).NE.0) JTMAX=3
17460 C...Check for Higgs which appears as decay product of user-process.
17463 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17465 IF(IHDEC.EQ.1) ISUB=3
17468 C...Start treatment of one, two or three resonances in parallel.
17481 C...Check whether particle can/is allowed to decay.
17482 IF(ID.EQ.0) GOTO 330
17485 IF(MWID(KCA).EQ.0) GOTO 330
17486 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17487 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17488 & KFA.EQ.18) IT4=IT4+1
17489 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17490 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17492 C...Choose lifetime and determine decay vertex.
17493 IF(K(ID,1).EQ.5) THEN
17495 ELSEIF(K(ID,1).NE.4) THEN
17496 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17499 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17502 C...Determine whether decay allowed or not.
17504 IF(MSTJ(22).EQ.2) THEN
17505 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17506 ELSEIF(MSTJ(22).EQ.3) THEN
17507 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17508 ELSEIF(MSTJ(22).EQ.4) THEN
17509 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17510 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17512 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17517 C...Info for selection of decay channel: sign, pairings.
17518 IF(KCHG(KCA,3).EQ.0) THEN
17521 IPM=(5-ISIGN(1,K(ID,2)))/2
17524 IF(JTMAX.EQ.2) THEN
17525 KFB=IABS(K(IREF(IP,3-JT),2))
17526 ELSEIF(JTMAX.EQ.3) THEN
17528 KFB=IABS(K(IREF(IP,JT2),2))
17529 IF(KFB.NE.KFA) THEN
17530 JT2=JT+2-3*((JT+1)/3)
17531 KFB=IABS(K(IREF(IP,JT2),2))
17535 C...Select decay channel.
17536 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17537 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17538 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17539 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17540 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17541 IF(WDTE0S.LE.0D0) GOTO 330
17545 IDC=IDL+MDCY(KCA,2)-1
17546 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17547 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17548 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17551 C...Read out flavours and colour charges of decay channel chosen.
17552 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17553 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17554 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17555 KFC1A=PYCOMP(IABS(KFL1(JT)))
17556 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17558 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17559 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17560 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17561 KFC2A=PYCOMP(IABS(KFL2(JT)))
17562 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17563 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17564 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17566 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17568 KFL4(JT)=KFDP(IDC,4)*ISIGN(1,K(ID,2))
17570 IF(KFL3(JT).NE.0) THEN
17571 KFC3A=PYCOMP(IABS(KFL3(JT)))
17572 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17573 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17574 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17576 IF(KFL4(JT).NE.0) THEN
17577 KFC4A=PYCOMP(IABS(KFL4(JT)))
17578 IF(KCHG(KFC4A,3).EQ.0) KFL4(JT)=IABS(KFL4(JT))
17579 KCQ4(JT)=KCHG(KFC4A,2)*ISIGN(1,KFL4(JT))
17580 IF(KCQ4(JT).EQ.-2) KCQ4(JT)=2
17585 C...Set/save further info on channel.
17587 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17589 HGZ(JT,1)=VINT(111)
17590 HGZ(JT,2)=VINT(112)
17591 HGZ(JT,3)=VINT(114)
17595 C...Select masses; to begin with assume resonances narrow.
17600 KFLW=IABS(KFL1(JT))
17602 ELSEIF(I.EQ.2) THEN
17603 KFLW=IABS(KFL2(JT))
17605 ELSEIF(I.EQ.3) THEN
17606 IF(KFL3(JT).EQ.0) GOTO 220
17607 KFLW=IABS(KFL3(JT))
17609 ELSEIF(I.EQ.4) THEN
17610 IF(KFL4(JT).EQ.0) GOTO 220
17611 KFLW=IABS(KFL4(JT))
17614 P(N+I,5)=PMAS(KCW,1)
17615 PXSUM=PXSUM+P(N+I,5)
17617 C...This prevents SUSY/t particles from becoming too light.
17618 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17619 PMMN(I)=PMAS(KCW,1)
17620 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17621 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17622 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17623 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17624 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17625 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17626 IF(KFDP(IDC,4).NE.0) PMSUM=PMSUM+
17627 & PMAS(PYCOMP(KFDP(IDC,4)),1)
17628 PMMN(I)=MIN(PMMN(I),PMSUM)
17632 ELSEIF(KFLW.EQ.6) THEN
17633 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17635 C...UED: select a graviton mass from continuous distribution
17636 C...(stored in PMAS(39,1) so no value returned)
17637 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17641 C...Check which two out of three are widest.
17644 PWID1=PMAS(KFC1A,2)
17645 PWID2=PMAS(KFC2A,2)
17646 KFLW1=IABS(KFL1(JT))
17647 KFLW2=IABS(KFL2(JT))
17648 IF(KFL3(JT).NE.0) THEN
17649 PWID3=PMAS(KFC3A,2)
17650 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17653 KFLW1=IABS(KFL3(JT))
17654 ELSEIF(PWID3.GT.PWID2) THEN
17657 KFLW2=IABS(KFL3(JT))
17660 IF(KFL4(JT).NE.0) THEN
17661 PWID4=PMAS(KFC4A,2)
17662 IF(PWID4.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17665 KFLW1=IABS(KFL4(JT))
17666 ELSEIF(PWID4.GT.PWID2) THEN
17669 KFLW2=IABS(KFL4(JT))
17673 C...If all narrow then only check that masses consistent.
17674 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17675 & PWID2.LT.PARP(41))) THEN
17677 C....Handle near degeneracy cases.
17678 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17679 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17680 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17681 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17685 IF(PXSUM.GT.P(ID,5)) THEN
17686 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17689 ELSEIF(PXSUM+PARJ(64).GT.P(ID,5)) THEN
17690 CALL PYERRM(3,'(PYRESD:) masses+PARJ(64) too large')
17695 C...For three wide resonances select narrower of three
17696 C...according to BW decoupled from rest.
17699 IF(KFL3(JT).NE.0) THEN
17700 IWID3=6-IWID1-IWID2
17701 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17705 P(N+IWID3,5)=PYMASS(KFLW3)
17706 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17707 PMTOT=PMTOT-P(N+IWID3,5)
17709 C...Select other two correlated within remaining phase space.
17713 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17714 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17715 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17720 CKIN(49)=PMMN(IWID1)
17721 CKIN(50)=PMMN(IWID2)
17722 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17727 IF(MINT(51).EQ.1) GOTO 720
17730 C...Begin fill decay products, with colour flow for coloured objects.
17736 C...Three-body decays
17737 IF(KFL3(JT).NE.0.OR.KFL4(JT).NE.0) THEN
17738 DO 250 I=N+1,N+NPROD
17752 IF(KFL4(JT).NE.0) THEN
17758 C...Generate kinematics (default is flat)
17759 IF(KFL4(JT).EQ.0) THEN
17762 PS=P(N+1,5)+P(N+2,5)+P(N+3,5)+P(N+4,5)
17769 C...Calculate maximum weight ND-particle decay.
17771 WTMAX=1D0/WTCOR(ND-2)
17772 PMAX=PV(1,5)-PS+P(N+ND,5)
17774 DO 381 IL=ND-1,1,-1
17775 PMAX=PMAX+P(N+IL,5)
17776 PMIN=PMIN+P(N+IL+1,5)
17777 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
17780 C...M-generator gives weight. If rejected, try again.
17785 DO 421 IL2=IL1-1,1,-1
17786 IF(RSAV.LE.RORD(IL2)) GOTO 431
17787 RORD(IL2+1)=RORD(IL2)
17789 431 RORD(IL2+1)=RSAV
17793 DO 451 IL=ND-1,1,-1
17794 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
17796 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
17798 IF(WT.LT.PYR(0)*WTMAX) GOTO 411
17800 C...Perform two-particle decays in respective CM frame.
17802 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
17803 UE(3)=2D0*PYR(0)-1D0
17804 PHIX=PARU(2)*PYR(0)
17805 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHIX)
17806 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHIX)
17809 PV(IL+1,J)=-PA*UE(J)
17811 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
17812 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
17815 C...Lorentz transform decay products to lab frame.
17819 DO 531 IL=ND-1,1,-1
17821 BE(J)=PV(IL,J)/PV(IL,4)
17823 GA=PV(IL,4)/PV(IL,5)
17825 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
17827 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
17829 P(I,4)=GA*(P(I,4)+BEP)
17835 C...Set generic colour flows whenever unambiguous,
17836 C...(independently of the order of the decay products)
17837 C...Sum up total colour content
17847 IF (KCQ(J).EQ.-1) THEN
17850 ELSEIF (KCQ(J).EQ.1) THEN
17853 ELSEIF (KCQ(J).EQ.2) THEN
17859 C...Set color flow for generic 1 -> N processes (N arbitrary)
17860 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17861 C...All singlets: do nothing
17863 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17864 C...Two octets, zero triplets, n singlets:
17865 IF (KCQ(0).EQ.2) THEN
17867 K(ID,4)=K(ID,4)+IOCT(2)
17868 K(ID,5)=K(ID,5)+IOCT(2)
17870 K(IOCT(2),4)=MSTU(5)*ID
17871 K(IOCT(2),5)=MSTU(5)*ID
17872 MCT(IOCT(2),1)=MCT(ID,1)
17873 MCT(IOCT(2),2)=MCT(ID,2)
17875 C...1 -> 8 + 8 + n(1)
17877 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17878 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17880 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17881 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17890 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17891 C...Two triplets, zero octets, n singlets.
17892 IF (KCQ(0).EQ.1) THEN
17894 K(ID,4)=K(ID,4)+ITRI(2)
17896 K(ITRI(2),4)=MSTU(5)*ID
17897 MCT(ITRI(2),1)=MCT(ID,1)
17898 ELSEIF (KCQ(0).EQ.-1) THEN
17899 C...3bar -> 3bar + n(1)
17900 K(ID,5)=K(ID,5)+IANT(2)
17902 K(IANT(2),5)=MSTU(5)*ID
17903 MCT(IANT(2),2)=MCT(ID,2)
17905 C...1 -> 3 + 3bar + n(1)
17907 K(ITRI(1),4)=MSTU(5)*IANT(1)
17909 K(IANT(1),5)=MSTU(5)*ITRI(1)
17915 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17916 C...Two triplets, one octet, n singlets.
17917 IF (KCQ(0).EQ.2) THEN
17918 C...8 -> 3 + 3bar + n(1)
17919 K(ID,4)=K(ID,4)+ITRI(1)
17920 K(ID,5)=K(ID,5)+IANT(1)
17922 K(ITRI(1),4)=MSTU(5)*ID
17924 K(IANT(1),5)=MSTU(5)*ID
17925 MCT(ITRI(1),1)=MCT(ID,1)
17926 MCT(IANT(1),2)=MCT(ID,2)
17927 ELSEIF (KCQ(0).EQ.1) THEN
17928 C...3 -> 8 + 3 + n(1)
17929 K(ID,4)=K(ID,4)+IOCT(1)
17931 K(IOCT(1),4)=MSTU(5)*ID
17932 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17934 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17935 MCT(IOCT(1),1)=MCT(ID,1)
17939 ELSEIF (KCQ(0).EQ.-1) THEN
17940 C...3bar -> 8 + 3bar + n(1)
17941 K(ID,5)=K(ID,5)+IOCT(1)
17943 K(IOCT(1),5)=MSTU(5)*ID
17944 K(IOCT(1),4)=MSTU(5)*IANT(2)
17946 K(IANT(2),5)=MSTU(5)*IOCT(1)
17947 MCT(IOCT(1),2)=MCT(ID,2)
17952 C...1 -> 3 + 3bar + 8 + n(1)
17954 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17956 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17957 K(IOCT(1),4)=MSTU(5)*IANT(1)
17959 K(IANT(1),5)=MSTU(5)*IOCT(1)
17967 ELSEIF(NTRI+NANT.EQ.4) THEN
17969 IF (KCQ(0).EQ.1) THEN
17970 C...3 -> 3 + n(1) -> 3 + 3bar
17971 K(ID,4)=K(ID,4)+ITRI(2)
17973 K(ITRI(2),4)=MSTU(5)*ID
17974 MCT(ITRI(2),1)=MCT(ID,1)
17976 K(ITRI(3),4)=MSTU(5)*IANT(1)
17978 K(IANT(1),5)=MSTU(5)*ITRI(3)
17982 ELSEIF (KCQ(0).EQ.-1) THEN
17983 C...3bar -> 3bar + n(1) -> 3 + 3bar
17984 K(ID,5)=K(ID,5)+IANT(2)
17986 K(IANT(2),5)=MSTU(5)*ID
17987 MCT(IANT(2),2)=MCT(ID,2)
17989 K(ITRI(1),4)=MSTU(5)*IANT(3)
17991 K(IANT(3),5)=MSTU(5)*ITRI(1)
17996 ELSEIF(KFL4(JT).NE.0) THEN
17997 CALL PYERRM(21,'(PYRESD:) unknown 4-bdy decay')
17998 CPS-- End of generic cases
17999 C...(could three octets also be handled?)
18000 C...(could (some of) the RPV cases be made generic as well?)
18002 C...Special cases (= old treatment)
18003 C...Set colour flow for t -> W + b + Z.
18004 ELSEIF(KFA.EQ.6) THEN
18007 IF(KCQM(JT).EQ.-1) ISID=5
18009 K(ID,ISID)=K(ID,ISID)+IDAU
18010 K(IDAU,ISID)=MSTU(5)*ID
18012 C...Set colour flow in three-body decays - programmed as special cases.
18014 ELSEIF(KFC2A.LE.6) THEN
18018 IF(KFL2(JT).LT.0) ISID=5
18019 K(N+2,ISID)=MSTU(5)*(N+3)
18020 K(N+3,9-ISID)=MSTU(5)*(N+2)
18021 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
18022 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
18023 & .AND.KFL3(JT).NE.0) THEN
18024 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
18025 C...3-body decays of squarks to colour singlets plus one quark
18026 IF (KQSUMA.EQ.1) THEN
18029 IF (KCQ1(JT).NE.0) IQ=1
18030 IF (KCQ2(JT).NE.0) IQ=2
18031 IF (KCQ3(JT).NE.0) IQ=3
18033 IF (K(N+IQ,2).LT.0) ISID=5
18035 K(ID,ISID)=K(ID,ISID)+(N+IQ)
18036 K(N+IQ,ISID)=MSTU(5)*ID
18039 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
18044 IF(KFL2(JT).LT.0) ISID=5
18045 K(N+1,ISID)=MSTU(5)*(N+2)
18046 K(N+1,9-ISID)=MSTU(5)*(N+3)
18047 K(N+2,ISID)=MSTU(5)*(N+1)
18048 K(N+3,9-ISID)=MSTU(5)*(N+1)
18049 ELSEIF(KFA.EQ.KSUSY1+21) THEN
18053 IF(KFL2(JT).LT.0) ISID=5
18054 K(ID,ISID)=K(ID,ISID)+(N+2)
18055 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
18056 K(N+2,ISID)=MSTU(5)*ID
18057 K(N+3,9-ISID)=MSTU(5)*ID
18060 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
18061 & IABS(KCQ2(JT)).EQ.1) THEN
18065 IF(KFL2(JT).LT.0) ISID=5
18066 K(N+2,ISID)=MSTU(5)*(N+3)
18067 K(N+3,9-ISID)=MSTU(5)*(N+2)
18072 C...Set colour flow in three-body decays with baryon number violation.
18073 C...Neutralino and chargino decays first.
18074 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
18075 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
18076 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
18077 K(N+4,4)=ITJUNC(JT)*MSTU(5)
18078 C...Insert junction to keep track of colours.
18079 IF(KCQ1(JT).NE.0) K(N+1,1)=3
18080 IF(KCQ2(JT).NE.0) K(N+2,1)=3
18081 IF(KCQ3(JT).NE.0) K(N+3,1)=3
18082 C...Set special junction codes:
18086 C...Order decay products by invariant mass. (will be used in PYSTRF).
18087 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)-
18088 & P(N+1,3)*P(N+2,3)
18089 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)-
18090 & P(N+1,3)*P(N+3,3)
18091 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)-
18092 & P(N+2,3)*P(N+3,3)
18093 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
18094 K(N+4,4)=N+3+K(N+4,4)
18095 K(N+4,5)=N+1+MSTU(5)*(N+2)
18096 ELSEIF(PM13.LT.PM23) THEN
18097 K(N+4,4)=N+2+K(N+4,4)
18098 K(N+4,5)=N+1+MSTU(5)*(N+3)
18100 K(N+4,4)=N+1+K(N+4,4)
18101 K(N+4,5)=N+2+MSTU(5)*(N+3)
18107 C...Connect daughters to junction.
18111 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
18113 C...Particle counter should be stepped up one extra for junction.
18117 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
18118 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
18119 K(N+4,4)=ITJUNC(JT)*MSTU(5)
18120 C...Insert junction to keep track of colours.
18121 IF(KCQ1(JT).NE.0) K(N+1,1)=3
18122 IF(KCQ2(JT).NE.0) K(N+2,1)=3
18123 IF(KCQ3(JT).NE.0) K(N+3,1)=3
18134 C...Start by connecting all daughters to junction.
18135 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
18136 C...Only consider colour topologies with off shell resonances.
18137 RMQ1=PMAS(PYCOMP(K(II,2)),1)
18138 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
18139 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
18140 IF (RMGLU-RMQ1.LT.RMRES) THEN
18141 C...Calculate propagators for each colour topology.
18142 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
18143 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
18144 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
18148 CTMSUM=CTMSUM+CTM2(II-N)
18150 CTMSUM=PYR(0)*CTMSUM
18151 C...Select colour topology J, with most off shell least likely.
18154 CTMSUM=CTMSUM-CTM2(J)
18155 IF (CTMSUM.GT.0D0) GOTO 300
18156 C...The lucky winner gets its colour (anti-colour) directly from gluino.
18157 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
18158 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
18159 C...The other gluino colour is connected to junction
18160 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
18162 K(N+4,4)=K(N+4,4)+ID
18163 C...Lastly, connect junction to remaining daughters.
18164 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
18165 C...Particle counter should be stepped up one extra for junction.
18169 C...Update particle counter.
18172 C...2) Everything else two-body decay.
18174 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
18179 C...First set colour flow as if mother colour singlet.
18180 IF(KCQ1(JT).NE.0) THEN
18182 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
18183 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
18185 IF(KCQ2(JT).NE.0) THEN
18187 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
18188 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
18190 C...Then redirect colour flow if mother (anti)triplet.
18191 IF(KCQM(JT).EQ.0) THEN
18192 ELSEIF(KCQM(JT).NE.2) THEN
18194 IF(KCQM(JT).EQ.-1) ISID=5
18196 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
18197 K(ID,ISID)=K(ID,ISID)+IDAU
18198 K(IDAU,ISID)=MSTU(5)*ID
18199 C...Then redirect colour flow if mother octet.
18200 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
18202 IF(KCQ1(JT).EQ.0) IDAU=N
18203 K(ID,4)=K(ID,4)+IDAU
18204 K(ID,5)=K(ID,5)+IDAU
18205 K(IDAU,4)=MSTU(5)*ID
18206 K(IDAU,5)=MSTU(5)*ID
18209 IF(KCQ1(JT).EQ.-1) ISID=5
18210 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
18211 K(ID,ISID)=K(ID,ISID)+(N-1)
18212 K(ID,9-ISID)=K(ID,9-ISID)+N
18213 K(N-1,ISID)=MSTU(5)*ID
18214 K(N,9-ISID)=MSTU(5)*ID
18217 C...Insert junction
18218 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
18220 C...~q* mother: type 3 junction. ~q mother: type 4.
18221 ITJUNC(JT)=(7+KCQM(JT))/2
18222 C...Specify junction KF and set colour flow from junction
18226 C...Junction type encoded together with mother:
18227 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
18228 K(N,5)=N-1+MSTU(5)*(N-2)
18229 C...Zero P and V for junction (V filled later)
18234 C...Set colour flow from mother to junction
18235 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
18236 C...Set colour flow from daughters to junction
18240 C...(Anti-)colour mother is junction.
18241 K(II,1+ITJUNC(JT)) = MSTU(5)*N
18246 C...End loop over resonances for daughter flavour and mass selection.
18248 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
18250 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
18251 & KFL1(JT).EQ.0) THEN
18252 WRITE(CODE,'(I9)') K(ID,2)
18253 WRITE(MASS,'(F9.3)') P(ID,5)
18254 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
18255 & CODE//' with mass'//MASS)
18261 C...Check for allowed combinations. Skip if no decays.
18262 IF(JTMAX.EQ.1) THEN
18263 IF(KDCY(1).EQ.0) GOTO 710
18264 ELSEIF(JTMAX.EQ.2) THEN
18265 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
18266 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
18267 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
18268 ELSEIF(JTMAX.EQ.3) THEN
18269 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
18270 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
18271 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
18272 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
18273 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
18274 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
18275 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
18278 C...Special case: matrix element option for Z0 decay to quarks.
18279 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
18280 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
18282 C...Check consistency of MSTJ options set.
18283 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
18285 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
18288 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
18290 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
18295 C...Select alpha_strong behaviour.
18298 MSTU(111)=MSTJ(108)
18299 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
18301 PARU(112)=PARJ(121)
18302 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
18304 C...Find axial fraction in total cross section for scalar gluon model.
18306 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
18307 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
18308 POLL=1D0-PARJ(131)*PARJ(132)
18309 SFF=1D0/(16D0*XW*XW1)
18310 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
18311 & (PARJ(123)*PARJ(124))**2)
18312 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
18314 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
18315 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
18316 & (PARJ(132)-PARJ(131)))
18319 QF=KCHG(KFLC,1)/3D0
18321 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
18322 & 1D0-(2D0*PMQ/P(ID,5))**2))
18323 VF=SIGN(1D0,QF)-4D0*QF*XW
18324 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
18325 & VF**2*HF1W)+VQ**3*HF1W
18326 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
18329 C...Choice of jet configuration.
18330 CALL PYXJET(P(ID,5),NJET,CUT)
18334 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
18335 ELSEIF(NJET.EQ.3) THEN
18336 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
18341 C...Fill jet configuration; return if incorrect kinematics.
18343 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
18344 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
18345 ELSEIF(NJET.EQ.2) THEN
18346 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
18347 ELSEIF(NJET.EQ.3) THEN
18348 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
18349 ELSEIF(KFLN.EQ.21) THEN
18350 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
18353 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
18356 IF(MSTU(24).NE.0) THEN
18363 C...Angular orientation according to matrix element.
18364 IF(MSTJ(106).EQ.1) THEN
18365 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
18366 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
18368 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
18369 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
18372 C...Boost partons to Z0 rest frame.
18373 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
18374 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18376 C...Mark decayed resonance and add documentation lines,
18378 IDOC=MINT(83)+MINT(4)
18380 I1=MINT(83)+MINT(4)+1
18382 IF(MSTP(128).GE.1) K(I,3)=ID
18383 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18394 C...Generate parton shower.
18395 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
18396 CALL PYSHOW(N-1,N,P(ID,5))
18397 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
18401 PTPART(1)=0.5D0*P(ID,5)
18402 PTPART(2)=PTPART(1)
18404 IF(K(N-1,2).GT.0) THEN
18411 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18414 C... End special case for Z0: skip ahead.
18420 C...Order incoming partons and outgoing resonances.
18421 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
18424 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
18425 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
18426 & ILIN(1)=2*MINT(84)+3-ILIN(1)
18427 ILIN(2)=2*MINT(84)+3-ILIN(1)
18429 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
18433 IF(K(IREF(IP,1),2).EQ.23) IORD=2
18434 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
18435 IAKIPD=IABS(K(IREF(IP,IORD),2))
18436 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
18437 IF(KDCY(IORD).EQ.0) IORD=3-IORD
18439 C...Order decay products of resonances.
18440 DO 370 JT=IORD,3-IORD,3-2*IORD
18441 IF(KDCY(JT).EQ.0) THEN
18442 ILIN(IMAX+1)=NSD(JT)
18444 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18445 ILIN(IMAX+1)=N+2*JT-1
18446 ILIN(IMAX+2)=N+2*JT
18448 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18449 K(N+2*JT,2)=K(NSD(JT)+2,2)
18451 ILIN(IMAX+1)=N+2*JT
18453 ILIN(IMAX+2)=N+2*JT-1
18455 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18456 K(N+2*JT,2)=K(NSD(JT)+2,2)
18460 C...Find charge, isospin, left- and righthanded couplings.
18465 KFA=IABS(K(ILIN(I),2))
18466 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18467 COUP(I,1)=KCHG(KFA,1)/3D0
18468 COUP(I,2)=(-1)**MOD(KFA,2)
18469 COUP(I,4)=-2D0*COUP(I,1)*XWV
18470 COUP(I,3)=COUP(I,2)+COUP(I,4)
18473 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18474 IF(ISUB.EQ.22) THEN
18477 IF(I.EQ.5) I1=3-IORD
18480 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18481 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18482 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18487 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18488 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18489 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18490 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18492 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18496 C...Select angular orientation type - Z'/W' only.
18498 IF(ISUB.EQ.141) THEN
18499 IF(PYR(0).LT.PARU(130)) MZPWP=1
18501 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18502 IAKIR=IABS(K(IREF(2,2),2))
18503 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18504 IF(IAKIR.LE.20) MZPWP=2
18506 IF(IP.GE.3) MZPWP=2
18507 ELSEIF(ISUB.EQ.142) THEN
18508 IF(PYR(0).LT.PARU(136)) MZPWP=1
18510 IAKIR=IABS(K(IREF(2,2),2))
18511 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18512 IF(IAKIR.LE.20) MZPWP=2
18514 IF(IP.GE.3) MZPWP=2
18517 C...Select random angles (begin of weighting procedure).
18518 430 DO 440 JT=1,JTMAX
18519 IF(KDCY(JT).EQ.0) GOTO 440
18520 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18521 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18522 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18525 CTHE(JT)=2D0*PYR(0)-1D0
18526 PHI(JT)=PARU(2)*PYR(0)
18530 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18531 C...Construct massless four-vectors.
18540 IF(KDCY(JT).EQ.0) GOTO 470
18542 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18543 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18544 P(N+2*JT,3)=-0.5D0*P(ID,5)
18545 P(N+2*JT,4)=0.5D0*P(ID,5)
18546 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18547 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18550 C...Store incoming and outgoing momenta, with random rotation to
18551 C...avoid accidental zeroes in HA expressions.
18555 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18556 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18557 P(N+4+I,5)=P(ILIN(I),5)
18559 P(N+4+I,J)=P(ILIN(I),J)
18562 500 THERR=ACOS(2D0*PYR(0)-1D0)
18563 PHIRR=PARU(2)*PYR(0)
18564 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18566 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18567 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18574 C...Calculate internal products.
18575 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18576 & ISUB.EQ.142) THEN
18577 DO 540 I1=IMIN,IMAX-1
18578 DO 530 I2=I1+1,IMAX
18579 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18580 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18581 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18582 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18583 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18584 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18585 HC(I1,I2)=CONJG(HA(I1,I2))
18586 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18587 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18588 HA(I2,I1)=-HA(I1,I2)
18589 HC(I2,I1)=-HC(I1,I2)
18594 C...Calculate four-products.
18601 DO 580 I1=IMIN,IMAX-1
18602 DO 570 I2=I1+1,IMAX
18603 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18604 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18605 PKK(I2,I1)=PKK(I1,I2)
18611 KFAGM=IABS(IREF(IP,7))
18612 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18613 C...Isotropic decay selected by user.
18617 ELSEIF(JTMAX.EQ.3) THEN
18618 C...Isotropic decay when three mother particles.
18622 ELSEIF(IT4.GE.1) THEN
18623 C... Isotropic decay t -> b + W etc for 4th generation q and l.
18627 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18628 & IREF(IP,7).EQ.36) THEN
18629 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18630 C...CP-odd case added by Kari Ertresvag Myklevoll.
18631 C...Now also with mixed Higgs CP-states
18633 IF(IP.EQ.1) WTMAX=SH**2
18634 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18635 KFA=IABS(K(IREF(IP,1),2))
18636 KFT=IABS(K(IREF(IP,2),2))
18638 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18639 & MSTP(25).GE.3) THEN
18640 C...For mixed CP states need epsilon product.
18657 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18658 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18659 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18660 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18661 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18662 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18663 & P22*P30*P41+P13*P22*P31*P40
18664 C...For mixed CP states need gauge boson masses.
18665 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18666 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18667 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18668 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18673 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18674 KFLF1A=IABS(KFL1(1))
18675 EF1=KCHG(KFLF1A,1)/3D0
18676 AF1=SIGN(1D0,EF1+0.1D0)
18677 VF1=AF1-4D0*EF1*XWV
18678 KFLF2A=IABS(KFL1(2))
18679 EF2=KCHG(KFLF2A,1)/3D0
18680 AF2=SIGN(1D0,EF2+0.1D0)
18681 VF2=AF2-4D0*EF2*XWV
18682 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18683 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18686 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18687 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18688 ELSEIF(MSTP(25).LE.2) THEN
18690 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18691 & -2*PKK(3,4)*PKK(5,6)
18692 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18693 & (PKK(3,4)*PKK(5,6))
18694 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18695 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18697 C...Mixed CP states.
18698 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18699 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18700 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18701 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18702 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18703 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18704 & +PKK(3,4)*PKK(5,6)
18705 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18706 & +VA12AS*PKK(3,4)*PKK(5,6)
18707 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18708 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18709 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18710 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18714 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18715 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18718 WT=16D0*PKK(3,5)*PKK(4,6)
18719 ELSEIF(MSTP(25).LE.2) THEN
18721 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18722 & -2*PKK(3,4)*PKK(5,6)
18723 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18724 & (PKK(3,4)*PKK(5,6))
18725 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18726 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18728 C...Mixed CP states.
18729 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18730 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18731 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18732 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18733 & +PKK(3,4)*PKK(5,6)
18734 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18735 & +PKK(3,4)*PKK(5,6)
18736 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18737 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18738 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18739 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18742 C...No angular correlations in other Higgs decays.
18747 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18748 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18750 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18752 IF(MOD(KFAGM,2).EQ.0) THEN
18760 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18761 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18762 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18763 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18765 ELSEIF(ISUB.EQ.1) THEN
18766 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18767 EI=KCHG(IABS(MINT(15)),1)/3D0
18768 AI=SIGN(1D0,EI+0.1D0)
18770 EF=KCHG(IABS(KFL1(1)),1)/3D0
18771 AF=SIGN(1D0,EF+0.1D0)
18774 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18775 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18776 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18777 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18778 & (VI**2+AI**2)*VINT(114)*VF**2)
18779 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18780 & 4D0*VI*AI*VINT(114)*VF*AF)
18781 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18782 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18783 WTMAX=2D0*(WT1+ABS(WT3))
18785 ELSEIF(ISUB.EQ.2) THEN
18786 C...Angular weight for W+/- -> 2 quarks/leptons.
18787 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18788 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18789 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18790 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18793 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18794 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18795 C...-> gluon/gamma + 2 quarks/leptons.
18796 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18797 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18798 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18799 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18800 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18801 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18802 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18803 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18804 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18805 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18806 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18807 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18808 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18809 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18810 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18811 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18813 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18814 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18815 C...-> gluon/gamma + 2 quarks/leptons.
18816 WT=PKK(1,3)**2+PKK(2,4)**2
18817 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18819 ELSEIF(ISUB.EQ.22) THEN
18820 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18821 S34=P(IREF(IP,IORD),5)**2
18822 S56=P(IREF(IP,3-IORD),5)**2
18823 TI=PKK(1,3)+PKK(1,4)+S34
18824 UI=PKK(1,5)+PKK(1,6)+S56
18827 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18828 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18829 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18830 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18831 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18832 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18833 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18834 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18837 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18838 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18839 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18840 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18841 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18842 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18843 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18846 ELSEIF(ISUB.EQ.23) THEN
18847 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18848 D34=P(IREF(IP,IORD),5)**2
18849 D56=P(IREF(IP,3-IORD),5)**2
18850 DT=PKK(1,3)+PKK(1,4)+D34
18851 DU=PKK(1,5)+PKK(1,6)+D56
18852 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18853 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18854 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18855 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18857 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18858 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18859 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18860 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18861 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18862 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18864 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18865 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18866 C...(or H0, or A0).
18867 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18868 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18869 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18870 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18871 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18873 ELSEIF(ISUB.EQ.25) THEN
18874 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18875 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18876 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18877 D34=P(IREF(IP,IORD),5)**2
18878 D56=P(IREF(IP,3-IORD),5)**2
18879 DT=PKK(1,3)+PKK(1,4)+D34
18880 DU=PKK(1,5)+PKK(1,6)+D56
18881 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18882 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18883 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18884 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18885 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18886 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18887 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18888 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18889 IF(MSTP(50).LE.0) THEN
18890 WT=FGK135**2+(CCWW*FGK253)**2
18891 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18892 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18895 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18896 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18897 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18898 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18901 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18902 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18903 C...(or H0, or A0).
18904 WT=PKK(1,3)*PKK(2,4)
18905 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18907 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18908 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18909 C...-> f + 2 quarks/leptons.
18910 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18911 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18912 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18913 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18914 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18915 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18916 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18917 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18918 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18919 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18920 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18921 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18922 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18923 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18924 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18925 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18926 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18927 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18929 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18930 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18931 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18932 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18933 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18935 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18937 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18938 WT=16D0*PKK(3,5)*PKK(4,6)
18941 ELSEIF(ISUB.EQ.110) THEN
18942 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18946 ELSEIF(ISUB.EQ.141) THEN
18947 C...Special case: if only branching ratios known then isotropic decay.
18948 IF(MWID(32).EQ.2) THEN
18951 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18952 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18953 C...Couplings of incoming flavour.
18954 KFAI=IABS(MINT(15))
18955 EI=KCHG(KFAI,1)/3D0
18956 AI=SIGN(1D0,EI+0.1D0)
18959 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18960 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18961 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18962 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18963 VPI=PARU(119+2*KFAIC)
18964 API=PARU(120+2*KFAIC)
18965 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18966 VPI=PARJ(178+2*KFAIC)
18967 API=PARJ(179+2*KFAIC)
18969 VPI=PARJ(186+2*KFAIC)
18970 API=PARJ(187+2*KFAIC)
18972 C...Couplings of final flavour.
18974 EF=KCHG(KFAF,1)/3D0
18975 AF=SIGN(1D0,EF+0.1D0)
18978 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18979 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18980 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18981 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18982 VPF=PARU(119+2*KFAFC)
18983 APF=PARU(120+2*KFAFC)
18984 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18985 VPF=PARJ(178+2*KFAFC)
18986 APF=PARJ(179+2*KFAFC)
18988 VPF=PARJ(186+2*KFAFC)
18989 APF=PARJ(187+2*KFAFC)
18991 C...Asymmetry and weight.
18992 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18993 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18994 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18995 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18996 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18997 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18998 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18999 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
19000 WTMAX=2D0+ABS(ASYM)
19001 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
19002 C...Angular weight for f + fbar -> Z' -> W+ + W-.
19003 RM1=P(NSD(1)+1,5)**2/SH
19004 RM2=P(NSD(1)+2,5)**2/SH
19005 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
19006 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
19007 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
19009 WT=CFLAT+CCOS2*CTHE(1)**2
19010 WTMAX=CFLAT+MAX(0D0,CCOS2)
19011 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
19012 & IABS(KFL1(1)).EQ.37)) THEN
19013 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
19016 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
19017 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
19018 RM1=P(NSD(1)+1,5)**2/SH
19019 RM2=P(NSD(1)+2,5)**2/SH
19020 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
19021 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
19022 WTMAX=1D0+FLAM2/(8D0*RM1)
19023 ELSEIF(MZPWP.EQ.0) THEN
19024 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19025 C...(W:s like if intermediate Z).
19026 D34=P(IREF(IP,IORD),5)**2
19027 D56=P(IREF(IP,3-IORD),5)**2
19028 DT=PKK(1,3)+PKK(1,4)+D34
19029 DU=PKK(1,5)+PKK(1,6)+D56
19030 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
19031 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
19032 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
19033 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
19034 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
19035 ELSEIF(MZPWP.EQ.1) THEN
19036 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19037 C...(W:s approximately longitudinal, like if intermediate H).
19038 WT=16D0*PKK(3,5)*PKK(4,6)
19041 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
19042 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
19047 ELSEIF(ISUB.EQ.142) THEN
19048 C...Special case: if only branching ratios known then isotropic decay.
19049 IF(MWID(34).EQ.2) THEN
19052 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
19053 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
19054 KFAI=IABS(MINT(15))
19056 IF(KFAI.GT.10) KFAIC=2
19057 VI=PARU(129+2*KFAIC)
19058 AI=PARU(130+2*KFAIC)
19061 IF(KFAF.GT.10) KFAFC=2
19062 VF=PARU(129+2*KFAFC)
19063 AF=PARU(130+2*KFAFC)
19064 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
19065 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
19066 WTMAX=2D0+ABS(ASYM)
19067 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
19068 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
19069 RM1=P(NSD(1)+1,5)**2/SH
19070 RM2=P(NSD(1)+2,5)**2/SH
19071 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
19072 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
19073 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
19075 WT=CFLAT+CCOS2*CTHE(1)**2
19076 WTMAX=CFLAT+MAX(0D0,CCOS2)
19077 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
19078 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
19079 RM1=P(NSD(1)+1,5)**2/SH
19080 RM2=P(NSD(1)+2,5)**2/SH
19081 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
19082 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
19083 WTMAX=1D0+FLAM2/(8D0*RM1)
19084 ELSEIF(MZPWP.EQ.0) THEN
19085 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19086 C...(W/Z like if intermediate W).
19087 D34=P(IREF(IP,IORD),5)**2
19088 D56=P(IREF(IP,3-IORD),5)**2
19089 DT=PKK(1,3)+PKK(1,4)+D34
19090 DU=PKK(1,5)+PKK(1,6)+D56
19091 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
19092 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
19093 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
19094 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
19095 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
19096 ELSEIF(MZPWP.EQ.1) THEN
19097 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19098 C...(W/Z approximately longitudinal, like if intermediate H).
19099 WT=16D0*PKK(3,5)*PKK(4,6)
19102 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
19103 C...t + bbar -> t + W + bbar.
19108 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
19110 C...Isotropic decay of leptoquarks (assumed spin 0).
19114 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
19115 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
19117 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
19118 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
19119 WT=1D0+SIDE*CTHE(1)
19121 ELSEIF(IP.EQ.1) THEN
19123 RM1=P(NSD(1)+1,5)**2/SH
19124 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
19125 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
19127 C...W/Z decay assumed isotropic, since not known.
19132 ELSEIF(ISUB.EQ.149) THEN
19133 C...Isotropic decay of techni-eta.
19137 ELSEIF(ISUB.EQ.191) THEN
19138 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19139 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
19140 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
19143 ELSEIF(IP.EQ.1) THEN
19144 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
19145 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19146 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19147 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19148 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19149 KFAI=IABS(MINT(15))
19150 EI=KCHG(KFAI,1)/3D0
19151 AI=SIGN(1D0,EI+0.1D0)
19155 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
19156 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
19158 EF=KCHG(KFAF,1)/3D0
19159 AF=SIGN(1D0,EF+0.1D0)
19163 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
19164 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
19165 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
19166 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
19167 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
19168 WTMAX=4D0*MAX(ASAME,AFLIP)
19170 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
19175 ELSEIF(ISUB.EQ.192) THEN
19176 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19177 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
19178 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
19181 ELSEIF(IP.EQ.1) THEN
19182 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
19183 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19187 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
19192 ELSEIF(ISUB.EQ.193) THEN
19193 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19194 C...Angular weight for f + fbar -> omega_tc0 ->
19195 C...gamma pi_tc0 or Z0 pi_tc0.
19198 ELSEIF(IP.EQ.1) THEN
19199 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
19200 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19201 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19202 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19203 KFAI=IABS(MINT(15))
19204 EI=KCHG(KFAI,1)/3D0
19205 AI=SIGN(1D0,EI+0.1D0)
19209 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
19210 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
19212 EF=KCHG(KFAF,1)/3D0
19213 AF=SIGN(1D0,EF+0.1D0)
19217 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
19218 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
19219 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
19220 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
19221 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
19222 WTMAX=4D0*MAX(BSAME,BFLIP)
19224 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
19229 ELSEIF(ISUB.EQ.353) THEN
19230 C...Angular weight for Z_R0 -> 2 quarks/leptons.
19231 EI=KCHG(IABS(MINT(15)),1)/3D0
19232 AI=SIGN(1D0,EI+0.1D0)
19234 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
19235 AF=SIGN(1D0,EF+0.1D0)
19237 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
19238 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
19239 WT2=RMF*(VI**2+AI**2)*VF**2
19240 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
19241 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
19242 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
19243 WTMAX=2D0*(WT1+ABS(WT3))
19245 ELSEIF(ISUB.EQ.354) THEN
19246 C...Angular weight for W_R+/- -> 2 quarks/leptons.
19247 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
19248 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
19249 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19250 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
19253 ELSEIF(ISUB.EQ.391) THEN
19254 C...Angular weight for f + fbar -> G* -> f + fbar
19255 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
19256 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
19258 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
19259 C...implemented by M.-C. Lemaire
19260 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
19261 & IABS(KFL1(1)).EQ.22)) THEN
19264 C...Other G* decays not yet implemented angular distributions.
19270 ELSEIF(ISUB.EQ.392) THEN
19271 C...Angular weight for g + g -> G* -> f + fbar
19272 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
19275 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
19276 C...implemented by M.-C. Lemaire
19277 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
19278 & IABS(KFL1(1)).EQ.22)) THEN
19279 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
19281 C...Other G* decays not yet implemented angular distributions.
19287 C...Obtain correct angular distribution by rejection techniques.
19292 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
19294 C...Construct massive four-vectors using angles chosen.
19295 590 DO 690 JT=1,JTMAX
19296 IF(KDCY(JT).EQ.0) GOTO 690
19301 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
19304 IF(KFL3(JT).NE.0) NPROD=3
19305 IF(KFL4(JT).NE.0) NPROD=4
19306 CALL PYROBO(NSD(JT)+1,NSD(JT)+NPROD,ACOS(CTHE(JT)),PHI(JT),
19307 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
19311 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
19313 C...Fill in position of decay vertex.
19314 DO 630 I=NSD(JT)+1,N0
19323 C...Mark decayed resonances; trace history.
19327 IF(KCQM(JT).NE.0) THEN
19328 C...Do not kill colour flow through coloured resonance!
19331 K(ID,5)=NSD(JT)+NPROD
19332 IF(ITJUNC(JT).NE.0) K(ID,5)=K(ID,5)+1
19333 C...If 3-body or 2-body with junction:
19334 c IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
19335 C...If 3-body with junction:
19336 c IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
19339 C...Add documentation lines.
19340 ISUBRG=MAX(1,MIN(500,MINT(1)))
19341 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
19342 IDOC=MINT(83)+MINT(4)
19345 c IF(KFL3(JT).NE.0) IHI=IHI+1
19346 DO 650 I=NSD(JT)+1,IHI
19348 I1=MINT(83)+MINT(4)+1
19350 IF(MSTP(128).GE.1) K(I,3)=ID
19351 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
19355 K(I1,3)=IREF(IP,JT+3)
19364 C...If 3-body or 2-body with junction:
19365 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
19366 C...If 3-body with junction:
19367 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
19368 C...If 4-body or 3-body with junction:
19369 IF(KFL4(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
19370 C...If 4-body with junction:
19371 IF(KFL4(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+5,3)=ID
19374 C...Do showering of two or three objects.
19376 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
19377 IF(KFL3(JT).EQ.0) THEN
19378 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
19380 CALL PYSHOW(NSD(JT)+1,-NPROD,P(ID,5))
19383 c...For pT-ordered shower need set up first, especially colour tags.
19384 C...(Need to set up colour tags even if MSTP(71) = 0)
19385 ELSEIF(MINT(35).GE.2) THEN
19387 c IF(KFL3(JT).NE.0) NPART=3
19392 PTPART(1)=0.5D0*P(ID,5)
19393 PTPART(2)=PTPART(1)
19394 PTPART(3)=PTPART(1)
19395 PTPART(4)=PTPART(1)
19396 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
19397 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
19398 IF(MOTHER.LE.NSD(JT)) THEN
19399 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
19402 MCT(NSD(JT)+1,1)=NCT
19406 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
19407 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
19408 IF(MOTHER.LE.NSD(JT)) THEN
19409 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
19412 MCT(NSD(JT)+1,2)=NCT
19416 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
19417 & KCQ2(JT).EQ.2)) THEN
19418 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
19419 IF(MOTHER.LE.NSD(JT)) THEN
19420 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
19423 MCT(NSD(JT)+2,1)=NCT
19427 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
19428 & KCQ2(JT).EQ.2)) THEN
19429 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
19430 IF(MOTHER.LE.NSD(JT)) THEN
19431 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19434 MCT(NSD(JT)+2,2)=NCT
19438 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
19439 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
19440 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
19441 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
19443 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
19444 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19445 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19446 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19448 IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,1).EQ.0.AND.
19449 & (KCQ4(JT).EQ.1.OR. KCQ4(JT).EQ.2)) THEN
19450 MOTHER=K(NSD(JT)+4,4)/MSTU(5)
19451 MCT(NSD(JT)+4,1)=MCT(MOTHER,1)
19453 IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,2).EQ.0.AND.
19454 & (KCQ4(JT).EQ.-1.OR.KCQ4(JT).EQ.2)) THEN
19455 MOTHER=K(NSD(JT)+4,5)/MSTU(5)
19456 MCT(NSD(JT)+4,2)=MCT(MOTHER,2)
19459 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19462 IF(JT.EQ.1) NAFT1=N
19464 C...Check if decay products moved by shower.
19469 C...4-body decays will only work if one of the products is "inert"
19470 IF(NSHAFT.GT.NSHBEF) THEN
19471 IF(K(NSD1,1).GT.10) THEN
19472 DO 660 I=NSHBEF+1,NSHAFT
19473 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19476 IF(K(NSD2,1).GT.10) THEN
19477 DO 670 I=NSHBEF+1,NSHAFT
19478 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19479 & I.NE.NSD1) NSD2=I
19482 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19483 DO 680 I=NSHBEF+1,NSHAFT
19484 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19485 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19488 IF(KFL4(JT).NE.0.AND.K(NSD4,1).GT.10) THEN
19489 DO 685 I=NSHBEF+1,NSHAFT
19490 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD4,2).AND.
19491 & I.NE.NSD1.AND.I.NE.NSD2.AND.I.NE.NSD3) NSD4=I
19496 C...Store decay products for further treatment.
19497 IF(KFL4(JT).EQ.0) THEN
19502 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19506 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19507 IREF(NP,7)=K(IREF(IP,JT),2)
19508 IREF(NP,8)=IREF(IP,JT)
19517 IF(K(NSD1,1).EQ.1) THEN
19520 ELSEIF(K(NSD2,1).EQ.1) THEN
19523 ELSEIF(K(NSD3,1).EQ.1) THEN
19530 IREF(NP,7)=K(IREF(IP,JT),2)
19531 IREF(NP,8)=IREF(IP,JT)
19536 C...Fill information for 2 -> 1 -> 2.
19537 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19538 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19539 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19545 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19546 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19547 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19548 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19549 VINT(47)=SQRT(VINT(48))
19552 C...Possibility of colour rearrangement in W+W- events.
19553 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19554 IAKF1=IABS(KFL1(1))
19555 IAKF2=IABS(KFL1(2))
19556 IAKF3=IABS(KFL2(1))
19557 IAKF4=IABS(KFL2(2))
19558 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19559 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19560 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19561 IF(MINT(51).NE.0) RETURN
19564 C...Loop back if needed.
19565 710 IF(IP.LT.NP) GOTO 170
19567 C...Boost back to standard frame.
19568 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19575 C*********************************************************************
19578 C...Initializes treatment of multiple interactions, selects kinematics
19579 C...of hardest interaction if low-pT physics included in run, and
19580 C...generates all non-hardest interactions.
19582 SUBROUTINE PYMULT(MMUL)
19584 C...Double precision and integer declarations.
19585 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19586 IMPLICIT INTEGER(I-N)
19587 INTEGER PYK,PYCHGE,PYCOMP
19589 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19590 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19591 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19592 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19593 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19594 COMMON/PYINT1/MINT(400),VINT(400)
19595 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19596 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19597 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19598 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19599 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19600 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19601 C...Local arrays and saved variables.
19602 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19603 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19604 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19605 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19607 C...Initialization of multiple interaction treatment.
19609 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19617 C...Loop over phase space points: xT2 choice in 20 bins.
19620 NMUL(IXT2)=MSTP(83)
19622 DO 110 ITRY=1,MSTP(83)
19623 RSCA=0.05D0*((21-IXT2)-PYR(0))
19624 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19625 XT2=MAX(0.01D0*VINT(149),XT2)
19628 C...Choose tau and y*. Calculate cos(theta-hat).
19629 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19630 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19631 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19633 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19639 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19640 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19641 CALL PYKMAP(2,MYST,PYR(0))
19642 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19644 C...Calculate differential cross-section.
19645 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19646 CALL PYSIGH(NCHN,SIGS)
19647 SIGM(IXT2)=SIGM(IXT2)+SIGS
19649 SIGSUM=SIGSUM+SIGM(IXT2)
19651 SIGSUM=SIGSUM/(20D0*MSTP(83))
19653 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19654 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19655 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19656 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19657 PARP(82)=0.9D0*PARP(82)
19658 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19662 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19663 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19665 C...Start iteration to find k factor.
19666 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19667 P83A=(1D0-PARP(83))**2
19668 P83B=2D0*PARP(83)*(1D0-PARP(83))
19670 CQ2I=1D0/PARP(84)**2
19671 CQ2R=2D0/(1D0+PARP(84)**2)
19679 130 IF(IIT.EQ.0) THEN
19681 ELSEIF(IIT.EQ.1) THEN
19684 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19687 C...Evaluate overlap integrals. Find where to divide the b range.
19688 IF(MSTP(82).EQ.2) THEN
19689 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19692 IF(MSTP(82).EQ.3) THEN
19694 ELSEIF(MSTP(82).EQ.4) THEN
19695 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19697 POWIP=MAX(0.4D0,PARP(83))
19698 RPWIP=2D0/POWIP-1D0
19699 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19709 IF(MSTP(82).EQ.3) THEN
19710 OV=EXP(-B**2)/PARU(2)
19711 ELSEIF(MSTP(82).EQ.4) THEN
19712 OV=(P83A*EXP(-MIN(50D0,B**2))+
19713 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19714 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19716 OV=EXP(-B**POWIP)/PARU(2)
19717 SO=SO+PARU(2)*B*DELTAB*OV
19719 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19720 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19721 SP=SP+PARU(2)*B*DELTAB*PACC
19722 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19723 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19724 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19726 BDIV=B+0.5D0*DELTAB
19728 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19730 YK=PARU(1)*XK*SO/SP
19732 C...Continue iteration until convergence.
19742 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19744 C...Store some results for subsequent use.
19752 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19753 PIK=(VNT146/VNT147)*YKE
19755 C...Find relative weight for low and high impact parameter.
19756 PLOWB=PARU(1)*BDIV**2
19757 IF(MSTP(82).EQ.3) THEN
19758 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19759 ELSEIF(MSTP(82).EQ.4) THEN
19760 S4A=P83A*EXP(-BDIV**2)
19761 S4B=P83B*EXP(-BDIV**2*CQ2R)
19762 S4C=P83C*EXP(-BDIV**2*CQ2I)
19763 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19764 ELSEIF(PARP(83).GE.1.999D0) THEN
19770 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19774 C...Initialize iteration in xT2 for hardest interaction.
19775 ELSEIF(MMUL.EQ.2) THEN
19779 IF(MSTP(82).LE.0) THEN
19780 ELSEIF(MSTP(82).EQ.1) THEN
19782 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19783 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19784 & VINT(317)/(VINT(318)*VINT(320))
19785 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19786 ELSEIF(MSTP(82).EQ.2) THEN
19788 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19789 & VINT(149)*(1D0+VINT(149))
19791 XC2=4D0*CKIN(3)**2/VINT(2)
19792 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19795 C...Select impact parameter for hardest interaction.
19796 IF(MSTP(82).LE.2) RETURN
19797 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19798 C...Treatment in low b region.
19800 B=BDIV*SQRT(PYR(0))
19801 IF(MSTP(82).EQ.3) THEN
19802 OV=EXP(-B**2)/PARU(2)
19803 ELSEIF(MSTP(82).EQ.4) THEN
19804 OV=(P83A*EXP(-MIN(50D0,B**2))+
19805 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19806 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19808 OV=EXP(-B**POWIP)/PARU(2)
19810 VINT(148)=OV/VNT147
19811 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19813 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19814 & VINT(149)*(1D0+VINT(149))
19816 C...Treatment in high b region.
19818 IF(MSTP(82).EQ.3) THEN
19819 B=SQRT(BDIV**2-LOG(PYR(0)))
19820 OV=EXP(-B**2)/PARU(2)
19821 ELSEIF(MSTP(82).EQ.4) THEN
19822 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19823 IF(S4RNDM.LT.S4A) THEN
19824 B=SQRT(BDIV**2-LOG(PYR(0)))
19825 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19826 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19828 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19830 OV=(P83A*EXP(-MIN(50D0,B**2))+
19831 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19832 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19833 ELSEIF(PARP(83).GE.1.999D0) THEN
19834 144 B2RPW=B2RPDV-LOG(PYR(0))
19835 ACCIP=(B2RPW/B2RPDV)**RPWIP
19836 IF(ACCIP.LT.PYR(0)) GOTO 144
19837 OV=EXP(-B2RPW)/PARU(2)
19838 B=B2RPW**(1D0/POWIP)
19840 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19841 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19842 IF(ACCIP.LT.PYR(0)) GOTO 146
19843 OV=EXP(-B2RPW)/PARU(2)
19844 B=B2RPW**(1D0/POWIP)
19846 VINT(148)=OV/VNT147
19847 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19849 IF(PACC.LT.PYR(0)) GOTO 142
19852 ELSEIF(MMUL.EQ.3) THEN
19853 C...Low-pT or multiple interactions (first semihard interaction):
19854 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19855 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19860 IF(MSTP(82).LE.0) THEN
19862 ELSEIF(MSTP(82).EQ.1) THEN
19863 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19864 C...Use with "Sudakov" for low b values when impact parameter dependence.
19865 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19866 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19867 & VINT(149)))).GT.PYR(0)) XT2=1D0
19868 IF(XT2.GE.1D0) THEN
19869 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19870 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19873 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19874 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19877 XT2=MAX(0.01D0*VINT(149),XT2)
19878 C...Use without "Sudakov" for high b values when impact parameter dep.
19880 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19881 & PYR(0)*(1D0-XC2))-VINT(149)
19882 XT2=MAX(0.01D0*VINT(149),XT2)
19886 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19887 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19888 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19889 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19892 VINT(21)=0.01D0*VINT(149)
19895 VINT(25)=0.01D0*VINT(149)
19898 C...Multiple interactions (first semihard interaction).
19899 C...Choose tau and y*. Calculate cos(theta-hat).
19900 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19901 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19902 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19904 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19910 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19911 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19912 CALL PYKMAP(2,MYST,PYR(0))
19913 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19915 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19917 C...Store results of cross-section calculation.
19918 ELSEIF(MMUL.EQ.4) THEN
19924 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19925 IF(ISET(ISUB).EQ.2)
19926 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19927 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19928 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19929 & (XTS+VINT(149))))
19930 IRBIN=INT(1D0+20D0*RBIN)
19931 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19932 NMUL(IRBIN)=NMUL(IRBIN)+1
19933 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19936 C...Choose impact parameter if not already done.
19937 ELSEIF(MMUL.EQ.5) THEN
19942 150 IF(MINT(39).GT.0) THEN
19943 ELSEIF(MSTP(82).EQ.3) THEN
19946 VINT(148)=EXPB2/(PARU(2)*VNT147)
19947 VINT(139)=SQRT(B2)/BAVG
19948 ELSEIF(MSTP(82).EQ.4) THEN
19950 IF(RTYPE.LT.P83A) THEN
19952 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19953 B2=-LOG(PYR(0))/CQ2R
19955 B2=-LOG(PYR(0))/CQ2I
19957 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19958 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19959 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19960 VINT(139)=SQRT(B2)/BAVG
19961 ELSEIF(PARP(83).GE.1.999D0) THEN
19962 POWIP=MAX(2D0,PARP(83))
19963 RPWIP=2D0/POWIP-1D0
19964 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19965 160 IF(PYR(0).LT.PROB1) THEN
19966 B2RPW=PYR(0)**(0.5D0*POWIP)
19969 B2RPW=1D0-LOG(PYR(0))
19972 IF(ACCIP.LT.PYR(0)) GOTO 160
19973 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19974 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19976 POWIP=MAX(0.4D0,PARP(83))
19977 RPWIP=2D0/POWIP-1D0
19978 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19979 170 IF(PYR(0).LT.PROB1) THEN
19980 B2RPW=2D0*RPWIP*PYR(0)
19981 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19983 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19984 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19986 IF(ACCIP.LT .PYR(0)) GOTO 170
19987 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19988 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19991 C...Multiple interactions (variable impact parameter) : reject with
19992 C...probability exp(-overlap*cross-section above pT/normalization).
19993 C...Does not apply to low-b region, where "Sudakov" already included.
19995 IF(MINT(39).NE.1) THEN
19996 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19997 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19998 DO 180 IBIN=IRBIN+1,20
19999 RNCOR=RNCOR+NMUL(IBIN)
20000 SIGCOR=SIGCOR+SIGM(IBIN)
20002 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20003 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20004 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20005 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20007 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20008 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20009 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20010 IF(VINT(150).LT.PYR(0)) GOTO 150
20014 C...Generate additional multiple semihard interactions.
20015 ELSEIF(MMUL.EQ.6) THEN
20028 C...Reconstruct strings in hard scattering.
20030 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
20031 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
20033 DO 210 I=MINT(84)+1,NMAX
20034 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
20035 IF(KCS.EQ.0) GOTO 210
20037 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
20038 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
20040 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
20042 IST=MOD(K(I,J+1),MSTU(5))
20044 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
20045 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
20047 IF(J.EQ.1.OR.J.EQ.4) THEN
20057 C...Set up starting values for iteration in xT2.
20058 XT2=4D0*VINT(62)/VINT(2)
20059 IF(MSTP(82).LE.1) THEN
20060 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20061 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20062 & VINT(317)/(VINT(318)*VINT(320))
20063 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20065 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20066 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20070 VINT(143)=1D0-VINT(141)
20071 VINT(144)=1D0-VINT(142)
20073 C...Iterate downwards in xT2.
20074 220 IF(MSTP(82).LE.1) THEN
20075 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20076 IF(XT2.LT.VINT(149)) GOTO 270
20078 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
20079 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20080 & LOG(PYR(0)))-VINT(149)
20081 IF(XT2.LE.0D0) GOTO 270
20082 XT2=MAX(0.01D0*VINT(149),XT2)
20086 C...Choose tau and y*. Calculate cos(theta-hat).
20087 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20088 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20089 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20091 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20097 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20098 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20099 CALL PYKMAP(2,MYST,PYR(0))
20100 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20102 C...Check that x not used up. Accept or reject kinematical variables.
20103 X1M=SQRT(TAU)*EXP(VINT(22))
20104 X2M=SQRT(TAU)*EXP(-VINT(22))
20105 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
20106 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20107 CALL PYSIGH(NCHN,SIGS)
20108 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20109 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
20111 C...Reset K, P and V vectors. Select some variables.
20120 PT=0.5D0*VINT(1)*SQRT(XT2)
20124 C...Add first parton to event record.
20127 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
20128 & 1+INT((2D0+PARJ(2))*PYR(0))
20129 P(N+1,1)=PT*COS(PHI)
20130 P(N+1,2)=PT*SIN(PHI)
20131 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
20132 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
20135 C...Add second parton to event record.
20138 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
20141 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
20142 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
20145 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
20146 C....Choose relevant string pieces to place gluons on.
20152 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
20153 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
20154 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
20155 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
20156 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
20164 C....Colour flow adjustments, new string pieces.
20165 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
20166 & MOD(K(IST1,4),MSTU(5))
20167 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
20168 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
20169 K(I,5)=MSTU(5)*IST1
20170 K(I,4)=MSTU(5)*IST2
20171 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
20172 & MOD(K(IST2,5),MSTU(5))
20173 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
20174 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
20177 KSTR(NSTR+1,2)=IST2
20181 C...String drawing and colour flow for gluon loop.
20182 ELSEIF(K(N+1,2).EQ.21) THEN
20183 K(N+1,4)=MSTU(5)*(N+2)
20184 K(N+1,5)=MSTU(5)*(N+2)
20185 K(N+2,4)=MSTU(5)*(N+1)
20186 K(N+2,5)=MSTU(5)*(N+1)
20193 C...String drawing and colour flow for qqbar pair.
20195 K(N+1,4)=MSTU(5)*(N+2)
20196 K(N+2,5)=MSTU(5)*(N+1)
20202 C...Global statistics.
20203 MINT(351)=MINT(351)+1
20204 VINT(351)=VINT(351)+PT
20205 IF (MINT(351).EQ.1) VINT(356)=PT
20207 C...Update remaining energy; iterate.
20209 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20210 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
20214 MINT(31)=MINT(31)+1
20215 VINT(151)=VINT(151)+VINT(41)
20216 VINT(152)=VINT(152)+VINT(42)
20217 VINT(143)=VINT(143)-VINT(41)
20218 VINT(144)=VINT(144)-VINT(42)
20219 C...Allow FSR for UE (always handle with old showers)
20220 IF(MSTP(152).EQ.1) THEN
20222 IF (MSTJ(41).EQ.10) MSTJ(41)=2
20223 MSTJ(41)=MOD(MSTJ(41),10)
20224 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
20227 IF(MINT(31).LT.240) GOTO 220
20235 C...Format statements for printout.
20236 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
20237 &'actions for MSTP(82) =',I2,' ******')
20238 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20239 &D9.2,' mb: rejected')
20240 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20241 &D9.2,' mb: accepted')
20246 C*********************************************************************
20249 C...Adds on target remnants (one or two from each side) and
20250 C...includes primordial kT for hadron beams.
20252 SUBROUTINE PYREMN(IPU1,IPU2)
20254 C...Double precision and integer declarations.
20255 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20256 IMPLICIT INTEGER(I-N)
20257 INTEGER PYK,PYCHGE,PYCOMP
20259 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20260 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20261 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20262 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20263 COMMON/PYINT1/MINT(400),VINT(400)
20264 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
20266 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
20267 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
20269 C...Find event type and remaining energy.
20272 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
20273 VINT(143)=1D0-VINT(141)
20274 VINT(144)=1D0-VINT(142)
20277 C...Define initial partons.
20282 IF(JT.EQ.1) IPU=IPU1
20283 IF(JT.EQ.2) IPU=IPU2
20290 IF(MINT(47).EQ.1) THEN
20294 ELSEIF(ISUB.EQ.95) THEN
20299 C...No primordial kT, or chosen according to truncated Gaussian or
20300 C...exponential, or (for photon) predetermined or power law.
20301 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
20302 IF(MSTP(91).LE.0) THEN
20304 ELSEIF(MSTP(91).EQ.1) THEN
20305 PT=PARP(91)*SQRT(-LOG(PYR(0)))
20309 PT=-PARP(92)*LOG(RPT1*RPT2)
20311 IF(PT.GT.PARP(93)) GOTO 120
20312 ELSEIF(MINT(106+JT).EQ.3) THEN
20313 PTA=SQRT(VINT(282+JT))
20315 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
20316 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
20317 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
20320 PTB=-PARP(99)*LOG(RPT1*RPT2)
20322 IF(PTB.GT.PARP(100)) GOTO 120
20323 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
20324 PT=PT*0.8D0**MINT(57)
20325 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
20326 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
20327 IF(MSTP(93).LE.0) THEN
20329 ELSEIF(MSTP(93).EQ.1) THEN
20330 PT=PARP(99)*SQRT(-LOG(PYR(0)))
20331 ELSEIF(MSTP(93).EQ.2) THEN
20334 PT=-PARP(99)*LOG(RPT1*RPT2)
20335 ELSEIF(MSTP(93).EQ.3) THEN
20338 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
20342 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
20343 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
20345 IF(PT.GT.PARP(100)) GOTO 120
20353 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20356 IF(MINT(47).EQ.1) RETURN
20358 C...Kinematics construction for initial partons.
20361 IF(ISUB.EQ.95) THEN
20365 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
20366 & (P(I1,2)+P(I2,2))**2
20367 SHR=SQRT(MAX(0D0,SHS))
20368 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
20369 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
20370 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
20371 P(I2,4)=SHR-P(I1,4)
20374 C...Transform partons to overall CM-frame.
20375 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
20376 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
20377 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
20378 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
20379 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
20380 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
20381 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
20382 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
20383 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
20384 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
20385 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
20388 C...Optionally fix up x and Q2 definitions for leptoproduction.
20390 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
20391 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
20392 IF(IDISXQ.EQ.1) THEN
20394 C...Find where incoming and outgoing leptons/partons are sitting.
20396 IF(MINT(42).EQ.1) LESD=2
20397 LPIN=MINT(83)+3-LESD
20399 LQIN=MINT(84)+3-LESD
20400 LEOUT=MINT(84)+2+LESD
20401 LQOUT=MINT(84)+5-LESD
20402 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
20403 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
20405 DO 140 I=MINT(84)+5,N
20406 IF(K(I,2).EQ.94) THEN
20413 IF(LESD.EQ.1) LQBG=IPU2
20415 C...Calculate actual and wanted momentum transfer.
20418 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
20419 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
20420 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
20421 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
20422 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
20423 P(N+1,1)=FAC*P(LEOUT,1)
20424 P(N+1,2)=FAC*P(LEOUT,2)
20425 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
20426 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
20427 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
20430 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
20431 QNEW(J)=P(LEIN,J)-P(N+1,J)
20434 C...Boost outgoing electron and daughters.
20435 IF(LSCMS.EQ.0) THEN
20437 P(LEOUT,J)=P(N+1,J)
20441 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
20443 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
20445 DBE(J)=PINV*P(N+2,J)
20449 190 IORIG=K(IORIG,3)
20450 IF(IORIG.GT.LEOUT) GOTO 190
20451 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
20452 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
20456 C...Copy shower initiator and all outgoing partons.
20460 P(NCOP,J)=P(LQBG,J)
20462 DO 240 I=MINT(84)+1,N
20464 IF(K(I,1).GT.10) GOTO 240
20465 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
20469 220 IORIG=K(IORIG,3)
20470 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
20472 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
20485 C...Calculate relative rescaling factors.
20489 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20492 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20495 C...Transfer extra three-momentum of current.
20498 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20500 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20503 C...Iterate change of initiator momentum to get energy right.
20506 PEEX=-P(N+1,4)-QNEW(4)
20507 PEMV=-P(N+1,3)/P(N+1,4)
20510 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20512 IF(ABS(PEMV).LT.1D-10) THEN
20514 MINT(57)=MINT(57)+1
20518 P(N+1,3)=P(N+1,3)+PZCH
20519 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)
20521 P(I,3)=P(I,3)+V(I,1)*PZCH
20522 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20524 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20526 C...Modify momenta in event record.
20527 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20528 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20529 IF(ABS(HBE).GE.1D0) THEN
20531 MINT(57)=MINT(57)+1
20535 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20544 C...Check minimum invariant mass of remnant system(s).
20545 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20546 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20547 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20548 PMIN(0)=SQRT(PMS(0))
20550 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20551 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20553 IF(MINT(44+JT).EQ.1) GOTO 340
20554 MINT(105)=MINT(102+JT)
20555 MINT(109)=MINT(106+JT)
20556 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20557 IF(MINT(51).NE.0) THEN
20558 MINT(57)=MINT(57)+1
20561 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20562 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20563 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20564 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20565 & P(MINT(83)+JT+2,2)**2)
20567 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20568 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20571 MINT(57)=MINT(57)+1
20575 C...Loop over two remnants; skip if none there.
20579 IF(MINT(44+JT).EQ.1) GOTO 410
20580 IF(JT.EQ.1) IPU=IPU1
20581 IF(JT.EQ.2) IPU=IPU2
20583 C...Store first remnant parton.
20595 P(I,5)=PYMASS(K(I,2))
20597 C...First parton colour connections and kinematics.
20598 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20601 K(I,4)=MSTU(5)*IPU+IPU
20602 K(I,5)=MSTU(5)*IPU+IPU
20603 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20604 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20605 ELSEIF(KCOL.NE.0) THEN
20607 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20609 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20611 IF(KFLCH(JT).EQ.0) THEN
20612 P(I,1)=-P(MINT(83)+JT+2,1)
20613 P(I,2)=-P(MINT(83)+JT+2,2)
20614 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20615 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20619 C...When extra remnant parton or hadron: store extra remnant.
20631 P(I,5)=PYMASS(K(I,2))
20633 C...Find parton colour connections of extra remnant.
20634 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20637 K(I,4)=MSTU(5)*IPU+IPU
20638 K(I,5)=MSTU(5)*IPU+IPU
20639 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20640 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20641 ELSEIF(KCOL.NE.0) THEN
20643 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20645 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20648 C...Relative transverse momentum when two remnants.
20651 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20652 IF(IABS(MINT(10+JT)).LT.20) THEN
20656 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20657 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20659 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20660 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20661 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20662 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20664 C...Meson or baryon; photon as meson. For splitup below.
20666 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20668 C***Relative distribution for electron into two electrons. Temporary!
20669 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20673 C...Relative distribution of electron energy into electron plus parton.
20674 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20677 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20679 C...Relative distribution of energy for particle into two jets.
20680 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20681 CHIK=PARP(92+2*IMB)
20682 IF(MSTP(92).LE.1) THEN
20683 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20684 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20685 ELSEIF(MSTP(92).EQ.2) THEN
20686 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20687 ELSEIF(MSTP(92).EQ.3) THEN
20688 CUT=2D0*0.3D0/VINT(1)
20689 380 CHI(JT)=PYR(0)**2
20690 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20691 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20692 ELSEIF(MSTP(92).EQ.4) THEN
20693 CUT=2D0*0.3D0/VINT(1)
20694 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20695 390 CHIR=CUT*CUTR**PYR(0)
20696 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20697 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20699 CUT=2D0*0.3D0/VINT(1)
20700 CUTA=CUT**(1D0-PARP(98))
20701 CUTB=(1D0+CUT)**(1D0-PARP(98))
20702 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20703 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20704 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20707 C...Relative distribution of energy for particle into jet plus particle.
20709 IF(MSTP(94).LE.1) THEN
20710 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20711 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20712 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20713 ELSEIF(MSTP(94).EQ.2) THEN
20714 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20715 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20716 ELSEIF(MSTP(94).EQ.3) THEN
20717 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20720 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20725 C...Construct total transverse mass; reject if too large.
20726 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20727 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20728 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20729 IF(LOOP.LT.100) THEN
20733 MINT(57)=MINT(57)+1
20737 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20738 VINT(158+JT)=CHI(JT)
20740 C...Subdivide longitudinal momentum according to value selected above.
20741 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20742 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20743 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20744 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20745 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20750 C...Check if longitudinal boosts needed - if so pick two systems.
20751 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20752 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20753 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20754 IF(ISN(1).EQ.0) THEN
20757 ELSEIF(ISN(2).EQ.0) THEN
20760 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20763 ELSEIF(VINT(143).GT.0.2D0) THEN
20766 ELSEIF(VINT(144).GT.0.2D0) THEN
20769 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20778 C...E+-pL wanted for system to be modified.
20779 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20783 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20784 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20787 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20788 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20789 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20790 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20794 DO 450 I=MINT(84)+1,NS
20795 IF(K(I,1).GT.10) GOTO 450
20798 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20800 IF(IORIG.GT.LPIN) GOTO 430
20801 IF(INCL.EQ.0) GOTO 450
20803 PSYS(0,J)=PSYS(0,J)+P(I,J)
20806 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20807 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20808 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20811 C...Construct longitudinal boosts.
20815 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20816 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20818 MINT(57)=MINT(57)+1
20821 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20822 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20823 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20824 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20825 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20826 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20827 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20829 C...Perform longitudinal boosts.
20830 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20832 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20833 ELSEIF(IR.EQ.1) THEN
20834 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20835 ELSEIF(IDISXQ.EQ.1) THEN
20839 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20841 IF(IORIG.GT.LPIN) GOTO 460
20842 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20845 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20847 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20849 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20850 ELSEIF(IL.EQ.2) THEN
20851 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20852 ELSEIF(IDISXQ.EQ.1) THEN
20856 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20858 IF(IORIG.GT.LPIN) GOTO 480
20859 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20862 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20865 C...Final check that energy-momentum conservation worked.
20868 DO 500 I=MINT(84)+1,N
20869 IF(K(I,1).GT.10) GOTO 500
20873 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20874 IF(PDEV.GT.1D-4*VINT(1)) THEN
20876 MINT(57)=MINT(57)+1
20880 C...Calculate rotation and boost from overall CM frame to
20881 C...hadronic CM frame in leptoproduction.
20883 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20886 IF(MINT(42).EQ.1) LESD=2
20887 LPIN=MINT(83)+3-LESD
20889 C...Sum upp momenta of everything not lepton or photon to define boost.
20894 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20895 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20896 IF(K(I,2).EQ.22) GOTO 530
20898 PSUM(J)=PSUM(J)+P(I,J)
20901 VINT(223)=-PSUM(1)/PSUM(4)
20902 VINT(224)=-PSUM(2)/PSUM(4)
20903 VINT(225)=-PSUM(3)/PSUM(4)
20905 C...Boost incoming hadron to hadronic CM frame to determine rotations.
20911 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20912 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20913 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20915 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20917 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20924 C*********************************************************************
20927 C...Initializes treatment of new multiple interactions scenario,
20928 C...selects kinematics of hardest interaction if low-pT physics
20929 C...included in run, and generates all non-hardest interactions.
20931 SUBROUTINE PYMIGN(MMUL)
20933 C...Double precision and integer declarations.
20934 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20935 IMPLICIT INTEGER(I-N)
20936 INTEGER PYK,PYCHGE,PYCOMP
20938 DOUBLE PRECISION PYALPS
20940 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20942 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20943 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20944 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20945 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20946 COMMON/PYINT1/MINT(400),VINT(400)
20947 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20948 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20949 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20950 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20951 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20952 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20953 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20954 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20955 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20956 C...Local arrays and saved variables.
20957 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20958 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20959 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20960 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20961 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20963 C...Initialization of multiple interaction treatment.
20965 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20973 C...Loop over phase space points: xT2 choice in 20 bins.
20976 NMUL(IXT2)=MSTP(83)
20978 DO 110 ITRY=1,MSTP(83)
20979 RSCA=0.05D0*((21-IXT2)-PYR(0))
20980 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20981 XT2=MAX(0.01D0*VINT(149),XT2)
20984 C...Choose tau and y*. Calculate cos(theta-hat).
20985 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20986 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20987 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20989 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20995 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20996 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20997 CALL PYKMAP(2,MYST,PYR(0))
20998 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21000 C...Calculate differential cross-section.
21001 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21002 CALL PYSIGH(NCHN,SIGS)
21003 SIGM(IXT2)=SIGM(IXT2)+SIGS
21005 SIGSUM=SIGSUM+SIGM(IXT2)
21007 SIGSUM=SIGSUM/(20D0*MSTP(83))
21009 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
21010 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
21011 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
21012 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
21013 PARP(82)=0.9D0*PARP(82)
21014 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
21018 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
21019 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
21021 C...Start iteration to find k factor.
21022 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
21023 P83A=(1D0-PARP(83))**2
21024 P83B=2D0*PARP(83)*(1D0-PARP(83))
21026 CQ2I=1D0/PARP(84)**2
21027 CQ2R=2D0/(1D0+PARP(84)**2)
21035 130 IF(IIT.EQ.0) THEN
21037 ELSEIF(IIT.EQ.1) THEN
21040 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
21043 C...Evaluate overlap integrals. Find where to divide the b range.
21044 IF(MSTP(82).EQ.2) THEN
21045 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
21048 IF(MSTP(82).EQ.3) THEN
21050 ELSEIF(MSTP(82).EQ.4) THEN
21051 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
21053 POWIP=MAX(0.4D0,PARP(83))
21054 RPWIP=2D0/POWIP-1D0
21055 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
21065 IF(MSTP(82).EQ.3) THEN
21066 OV=EXP(-B**2)/PARU(2)
21067 ELSEIF(MSTP(82).EQ.4) THEN
21068 OV=(P83A*EXP(-MIN(50D0,B**2))+
21069 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21070 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21072 OV=EXP(-B**POWIP)/PARU(2)
21073 SO=SO+PARU(2)*B*DELTAB*OV
21075 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
21076 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
21077 SP=SP+PARU(2)*B*DELTAB*PACC
21078 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
21079 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
21080 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
21082 BDIV=B+0.5D0*DELTAB
21084 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
21086 YK=PARU(1)*XK*SO/SP
21088 C...Continue iteration until convergence.
21098 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
21100 C...Store some results for subsequent use.
21108 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
21109 PIK=(VNT146/VNT147)*YKE
21111 C...Find relative weight for low and high impact parameter..
21112 PLOWB=PARU(1)*BDIV**2
21113 IF(MSTP(82).EQ.3) THEN
21114 PHIGHB=PIK*0.5*EXP(-BDIV**2)
21115 ELSEIF(MSTP(82).EQ.4) THEN
21116 S4A=P83A*EXP(-BDIV**2)
21117 S4B=P83B*EXP(-BDIV**2*CQ2R)
21118 S4C=P83C*EXP(-BDIV**2*CQ2I)
21119 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
21120 ELSEIF(PARP(83).GE.1.999D0) THEN
21126 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
21130 C...Initialize iteration in xT2 for hardest interaction.
21131 ELSEIF(MMUL.EQ.2) THEN
21135 IF(MSTP(82).LE.0) THEN
21136 ELSEIF(MSTP(82).EQ.1) THEN
21138 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21139 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21140 & VINT(317)/(VINT(318)*VINT(320))
21141 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21142 ELSEIF(MSTP(82).EQ.2) THEN
21144 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
21145 & VINT(149)*(1D0+VINT(149))
21147 XC2=4D0*CKIN(3)**2/VINT(2)
21148 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
21151 C...Select impact parameter for hardest interaction.
21152 IF(MSTP(82).LE.2) RETURN
21153 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
21154 C...Treatment in low b region.
21156 B=BDIV*SQRT(PYR(0))
21157 IF(MSTP(82).EQ.3) THEN
21158 OV=EXP(-B**2)/PARU(2)
21159 ELSEIF(MSTP(82).EQ.4) THEN
21160 OV=(P83A*EXP(-MIN(50D0,B**2))+
21161 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21162 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21164 OV=EXP(-B**POWIP)/PARU(2)
21166 VINT(148)=OV/VNT147
21167 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
21169 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
21170 & VINT(149)*(1D0+VINT(149))
21172 C...Treatment in high b region.
21174 IF(MSTP(82).EQ.3) THEN
21175 B=SQRT(BDIV**2-LOG(PYR(0)))
21176 OV=EXP(-B**2)/PARU(2)
21177 ELSEIF(MSTP(82).EQ.4) THEN
21178 S4RNDM=PYR(0)*(S4A+S4B+S4C)
21179 IF(S4RNDM.LT.S4A) THEN
21180 B=SQRT(BDIV**2-LOG(PYR(0)))
21181 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
21182 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
21184 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
21186 OV=(P83A*EXP(-MIN(50D0,B**2))+
21187 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21188 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21189 ELSEIF(PARP(83).GE.1.999D0) THEN
21190 144 B2RPW=B2RPDV-LOG(PYR(0))
21191 ACCIP=(B2RPW/B2RPDV)**RPWIP
21192 IF(ACCIP.LT.PYR(0)) GOTO 144
21193 OV=EXP(-B2RPW)/PARU(2)
21194 B=B2RPW**(1D0/POWIP)
21196 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
21197 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
21198 IF(ACCIP.LT.PYR(0)) GOTO 146
21199 OV=EXP(-B2RPW)/PARU(2)
21200 B=B2RPW**(1D0/POWIP)
21202 VINT(148)=OV/VNT147
21203 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
21205 IF(PACC.LT.PYR(0)) GOTO 142
21208 ELSEIF(MMUL.EQ.3) THEN
21209 C...Low-pT or multiple interactions (first semihard interaction):
21210 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
21211 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
21216 IF(MSTP(82).LE.0) THEN
21218 ELSEIF(MSTP(82).EQ.1) THEN
21219 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21220 C...Use with "Sudakov" for low b values when impact parameter dependence.
21221 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
21222 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
21223 & VINT(149)))).GT.PYR(0)) XT2=1D0
21224 IF(XT2.GE.1D0) THEN
21225 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
21226 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
21229 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
21230 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
21233 XT2=MAX(0.01D0*VINT(149),XT2)
21234 C...Use without "Sudakov" for high b values when impact parameter dep.
21236 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
21237 & PYR(0)*(1D0-XC2))-VINT(149)
21238 XT2=MAX(0.01D0*VINT(149),XT2)
21242 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
21243 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
21244 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
21245 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
21248 VINT(21)=1D-12*VINT(149)
21251 VINT(25)=1D-12*VINT(149)
21254 C...Multiple interactions (first semihard interaction).
21255 C...Choose tau and y*. Calculate cos(theta-hat).
21256 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21257 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21258 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21260 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21266 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21267 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21268 CALL PYKMAP(2,MYST,PYR(0))
21269 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21271 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
21273 C...Store results of cross-section calculation.
21274 ELSEIF(MMUL.EQ.4) THEN
21280 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
21281 IF(ISET(ISUB).EQ.2)
21282 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21283 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
21284 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
21285 & (XTS+VINT(149))))
21286 IRBIN=INT(1D0+20D0*RBIN)
21287 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
21288 NMUL(IRBIN)=NMUL(IRBIN)+1
21289 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
21292 C...Choose impact parameter if not already done.
21293 ELSEIF(MMUL.EQ.5) THEN
21298 150 IF(MINT(39).GT.0) THEN
21299 ELSEIF(MSTP(82).EQ.3) THEN
21302 VINT(148)=EXPB2/(PARU(2)*VNT147)
21303 VINT(139)=SQRT(B2)/BAVG
21304 ELSEIF(MSTP(82).EQ.4) THEN
21306 IF(RTYPE.LT.P83A) THEN
21308 ELSEIF(RTYPE.LT.P83A+P83B) THEN
21309 B2=-LOG(PYR(0))/CQ2R
21311 B2=-LOG(PYR(0))/CQ2I
21313 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
21314 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
21315 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
21316 VINT(139)=SQRT(B2)/BAVG
21317 ELSEIF(PARP(83).GE.1.999D0) THEN
21318 POWIP=MAX(2D0,PARP(83))
21319 RPWIP=2D0/POWIP-1D0
21320 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
21321 160 IF(PYR(0).LT.PROB1) THEN
21322 B2RPW=PYR(0)**(0.5D0*POWIP)
21325 B2RPW=1D0-LOG(PYR(0))
21328 IF(ACCIP.LT.PYR(0)) GOTO 160
21329 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
21330 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
21332 POWIP=MAX(0.4D0,PARP(83))
21333 RPWIP=2D0/POWIP-1D0
21334 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
21335 170 IF(PYR(0).LT.PROB1) THEN
21336 B2RPW=2D0*RPWIP*PYR(0)
21337 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
21339 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
21340 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
21342 IF(ACCIP.LT .PYR(0)) GOTO 170
21343 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
21344 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
21347 C...Multiple interactions (variable impact parameter) : reject with
21348 C...probability exp(-overlap*cross-section above pT/normalization).
21349 C...Does not apply to low-b region, where "Sudakov" already included.
21351 IF(MINT(39).NE.1) THEN
21352 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
21353 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
21354 DO 180 IBIN=IRBIN+1,20
21355 RNCOR=RNCOR+NMUL(IBIN)
21356 SIGCOR=SIGCOR+SIGM(IBIN)
21358 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
21359 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
21360 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
21361 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
21363 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
21364 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
21365 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
21366 IF(VINT(150).LT.PYR(0)) GOTO 150
21370 C...Generate additional multiple semihard interactions.
21371 ELSEIF(MMUL.EQ.6) THEN
21373 C...Save data for hardest initeraction, to be restored.
21390 C...Store data on hardest interaction.
21397 C...Change process to generate; sum of x values so far.
21400 VINT(143)=1D0-VINT(141)
21401 VINT(144)=1D0-VINT(142)
21405 C...Initialize factors for PDF reshaping.
21409 KFSBM=ISIGN(1,KFBEAM)
21411 C...Zero flavour content of incoming beam particle.
21415 C...Flavour content of baryon.
21416 IF(KFABM.GT.1000) THEN
21417 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
21418 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
21419 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
21420 C...Flavour content of pi+-, K+-.
21421 ELSEIF(KFABM.EQ.211) THEN
21422 KFIVAL(JS,1)=KFSBM*2
21423 KFIVAL(JS,2)=-KFSBM
21424 ELSEIF(KFABM.EQ.321) THEN
21425 KFIVAL(JS,1)=-KFSBM*3
21426 KFIVAL(JS,2)=KFSBM*2
21427 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
21430 C...Zero initial valence and companion content.
21435 C...Initiate listing of all incoming partons from two sides.
21437 DO 210 I=MINT(84)+1,N
21438 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
21444 C...Decide whether quarks in hard scattering were valence or sea.
21445 IFL=K(IMI(JS,1,1),2)
21446 IF (IABS(IFL).GT.6) GOTO 230
21448 C...Get PDFs at X and Q2 of the parton shower initiator for the
21449 C...hard scattering.
21451 IF(MSTP(61).GE.1) THEN
21456 C...Note: XPSVC = x*pdf.
21459 C.... Store side in MINT(124)
21462 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21466 C...Decide (Extra factor x cancels in the division).
21467 RVCS=PYR(0)*(SEA+VAL)
21469 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21470 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21472 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21473 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21474 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21475 IF(KFIVAL(JS,1).EQ.0) THEN
21476 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21477 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21478 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21479 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21481 IF(IVNOW.EQ.0) GOTO 220
21484 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21485 IF(KFIVAL(JS,1).EQ.0) THEN
21486 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21489 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21491 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21492 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21496 C...If sea, add opposite sign companion parton. Store X and I.
21498 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21499 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21500 C...Set pointer to companion
21501 IMI(JS,1,2)=-NVC(JS,-IFL)
21505 C...Update counter number of multiple interactions.
21509 C...Set up starting values for iteration in xT2.
21510 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21511 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21512 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21513 & ISUBSV.NE.96)) THEN
21514 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21517 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21518 IF(ISET(ISUBSV).EQ.2)
21519 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21520 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21522 IF(MSTP(82).LE.1) THEN
21523 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21524 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21525 & VINT(317)/(VINT(318)*VINT(320))
21526 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21528 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21529 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21534 C...Iterate downwards in xT2.
21535 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21538 ELSEIF(MSTP(82).LE.1) THEN
21539 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21540 IF(XT2.LT.VINT(149)) GOTO 440
21542 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21543 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21544 & LOG(PYR(0)))-VINT(149)
21545 IF(XT2.LE.0D0) GOTO 440
21546 XT2=MAX(0.01D0*VINT(149),XT2)
21550 C...Choose tau and y*. Calculate cos(theta-hat).
21551 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21552 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21553 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21555 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21558 C...New: require shat > 1.
21559 IF(TAU*VINT(2).LT.1D0) GOTO 240
21563 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21564 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21565 CALL PYKMAP(2,MYST,PYR(0))
21566 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21568 C...Check that x not used up. Accept or reject kinematical variables.
21569 X1M=SQRT(TAU)*EXP(VINT(22))
21570 X2M=SQRT(TAU)*EXP(-VINT(22))
21571 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21572 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21573 CALL PYSIGH(NCHN,SIGS)
21574 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21575 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21576 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21578 C...Reset K, P and V vectors.
21586 PT=0.5D0*VINT(1)*SQRT(XT2)
21588 C...Choose flavour of reacting partons (and subprocess).
21593 ICONMI=ISIG(ICHN,3)
21594 RSIGS=RSIGS-SIGH(ICHN)
21595 IF(RSIGS.LE.0D0) GOTO 280
21598 C...Reassign to appropriate process codes.
21599 280 ISUBMI=ICONMI/10
21600 ICONMI=MOD(ICONMI,10)
21602 C...Choose new quark flavour for annihilation graphs
21603 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21605 CALL PYWIDT(21,SH,WDTP,WDTE)
21606 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21607 DO 300 I=1,MDCY(21,3)
21608 KFLF=KFDP(I+MDCY(21,2)-1,1)
21609 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21610 IF(RKFL.LE.0D0) GOTO 310
21612 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21613 IF(KFLF.GE.4) GOTO 290
21614 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21617 ELSEIF(ISUBMI.EQ.53) THEN
21623 C...Final state flavours and colour flow: default values
21630 IF(ISUBMI.EQ.11) THEN
21631 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21633 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21635 ELSEIF(ISUBMI.EQ.12) THEN
21636 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21637 KFL3=ISIGN(KFLF,KFL1)
21641 ELSEIF(ISUBMI.EQ.13) THEN
21642 C...f + fbar -> g + g; th arbitrary
21647 ELSEIF(ISUBMI.EQ.28) THEN
21648 C...f + g -> f + g; th = (p(f)-p(f))**2
21649 IF(KFL1.EQ.21) JS=2
21651 IF(KFL1.EQ.21) KCC=KCC+2
21652 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21653 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21655 ELSEIF(ISUBMI.EQ.53) THEN
21656 C...g + g -> f + fbar; th arbitrary
21657 KCS=(-1)**INT(1.5D0+PYR(0))
21658 KFL3=ISIGN(KFLF,KCS)
21662 ELSEIF(ISUBMI.EQ.68) THEN
21663 C...g + g -> g + g; th arbitrary
21665 KCS=(-1)**INT(1.5D0+PYR(0))
21668 C...Store flavours of scattering.
21676 C...Set flavours and mothers of scattering partons.
21685 K(N+1,3)=MINT(83)+1
21686 K(N+2,3)=MINT(83)+2
21690 C...Store colour connection indices.
21693 IF(KCS.EQ.-1) JC=3-J
21694 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21695 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21696 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21697 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21700 C...Store incoming and outgoing partons in their CM-frame.
21701 SHR=SQRT(TAU)*VINT(1)
21704 P(N+2,3)=-0.5D0*SHR
21706 P(N+3,5)=PYMASS(K(N+3,2))
21707 P(N+4,5)=PYMASS(K(N+4,2))
21708 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21709 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21710 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21711 P(N+4,4)=SHR-P(N+3,4)
21714 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21716 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21718 C...Set up default values before showers.
21719 MINT(31)=MINT(31)+1
21728 C...Showering of initial state partons (optional).
21729 C...Note: no showering of final state partons here; it comes later.
21730 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21737 KSAV(I,J)=K(N-4+I,J)
21738 PSAV(I,J)=P(N-4+I,J)
21741 CALL PYSSPA(IPU1,IPU2)
21743 C...If shower failed then restore to situation before shower.
21744 IF(MINT(51).GE.1) THEN
21748 K(N-4+I,J)=KSAV(I,J)
21749 P(N-4+I,J)=PSAV(I,J)
21759 C...Keep track of loose colour ends and information on scattering.
21760 370 IMI(1,MINT(31),1)=IPU1
21761 IMI(2,MINT(31),1)=IPU2
21762 IMI(1,MINT(31),2)=0
21763 IMI(2,MINT(31),2)=0
21764 XMI(1,MINT(31))=VINT(141)
21765 XMI(2,MINT(31))=VINT(142)
21766 PT2MI(MINT(31))=VINT(54)
21769 C...Decide whether quarks in last scattering were valence, companion or
21773 KFSBM=ISIGN(1,MINT(10+JS))
21774 IFL=K(IMI(JS,MINT(31),1),2)
21775 IMI(JS,MINT(31),2)=0
21776 IF (IABS(IFL).GT.6) GOTO 430
21778 C...Get PDFs at X and Q2 of the parton shower initiator for the
21779 C...last scattering. At this point VINT(143:144) do not yet
21780 C...include the scattered x values VINT(141:142).
21781 X=VINT(140+JS)/VINT(142+JS)
21782 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21787 C...Note: XPSVC = x*pdf.
21790 C.... Store side in MINT(124)
21793 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21797 DO 380 IVC=1,NVC(JS,IFL)
21798 CMP=CMP+XPSVC(IFL,IVC)
21801 C...Decide (Extra factor x cancels in the dvision).
21802 RVCS=PYR(0)*(SEA+VAL+CMP)
21804 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21805 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21807 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21808 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21809 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21810 IF(KFIVAL(JS,1).EQ.0) THEN
21811 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21812 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21813 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21814 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21816 DO 400 I1=1,NMI(JS)
21817 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21821 IF(IVNOW.EQ.0) GOTO 390
21823 IMI(JS,MINT(31),2)=0
21824 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21825 IF(KFIVAL(JS,1).EQ.0) THEN
21826 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21829 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21831 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21832 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21836 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21837 C...If sea, add opposite sign companion parton. Store X and I.
21838 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21839 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21840 C...Set pointer to companion
21841 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21843 C...If companion, decide which one.
21847 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21848 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21849 C...Find original sea (anti-)quark:
21851 DO 420 I1=1,NMI(JS)
21852 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21853 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21854 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21855 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21858 C...Change X to what associated companion had, so that the correct
21859 C...amount of momentum can be subtracted from the companion sum below.
21860 X=XASSOC(JS,IFL,ISEL)
21861 C...Mark companion read.
21862 XASSOC(JS,IFL,ISEL)=0D0
21866 C...Global statistics.
21867 MINT(351)=MINT(351)+1
21868 VINT(351)=VINT(351)+PT
21869 IF (MINT(351).EQ.1) VINT(356)=PT
21871 C...Update remaining energy and other counters.
21872 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21873 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21879 VINT(151)=VINT(151)+VINT(41)
21880 VINT(152)=VINT(152)+VINT(42)
21881 VINT(143)=VINT(143)-VINT(141)
21882 VINT(144)=VINT(144)-VINT(142)
21884 C...Iterate, with more interactions allowed.
21885 IF(MINT(31).LT.240) GOTO 240
21888 C...Restore saved quantities for hardest interaction.
21904 C...Format statements for printout.
21905 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21906 &'actions for MSTP(82) =',I2,' ******')
21907 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21908 &D9.2,' mb: rejected')
21909 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21910 &D9.2,' mb: accepted')
21915 C*********************************************************************
21918 C...Finds left-behind remnant flavour content and hooks up
21919 C...the colour flow between the hard scattering and remnants
21923 C...Double precision and integer declarations.
21924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21925 IMPLICIT INTEGER(I-N)
21926 INTEGER PYK,PYCHGE,PYCOMP
21927 C...The event record
21928 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21930 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21931 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21932 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21933 COMMON/PYINT1/MINT(400),VINT(400)
21934 C...The common block of dangling ends
21935 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21936 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21937 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21938 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21939 C...Local variables
21940 PARAMETER (NERSIZ=4000)
21941 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21943 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21944 SAVE /PYCBLS/,/PYCTAG/
21945 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21946 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21949 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)
21951 C...Set up error checkers
21954 C...Initialize colour arrays: MCO (Original) and MCT (New)
21955 DO 110 I=MINT(84)+1,NERSIZ
21960 C...Also zero colour tracing information, if existed.
21962 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21963 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21967 C...Initialize colour tag collapse arrays:
21968 C...JCCO (Original) and JCCN (New).
21969 DO 130 MG=MINT(84)+1,NERSIZ
21976 C...Zero gluon insertion array
21983 C...Compute hard scattering system rapidities
21984 IF (MSTP(89).EQ.1) THEN
21986 IF (IM.LE.MINT(31)) THEN
21987 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21989 C...Set (unsigned) rapidity = 100 for beam remnant systems.
21995 C...Treat each side separately
21998 C...Initialize side.
22001 KFS=ISIGN(1,MINT(10+JS))
22003 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
22004 IF(KFIVAL(JS,1).EQ.0) THEN
22005 IF(MINT(10+JS).EQ.111) THEN
22006 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
22007 KFIVAL(JS,2)=-KFIVAL(JS,1)
22008 ELSEIF(MINT(10+JS).EQ.22) THEN
22011 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
22012 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
22013 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
22014 KFIVAL(JS,2)=-KFIVAL(JS,1)
22015 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
22016 IF(PYR(0).GT.0.5D0) THEN
22026 C...Initialize beam remnant sea and valence content flavour by flavour.
22030 C...Count up original number of JFA valence quarks and antiquarks.
22035 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
22036 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
22038 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
22039 C...Subtract kicked out valence and determine sea from flavour cons.
22040 DO 180 IM=1,NMI(JS)
22041 IFL = K(IMI(JS,IM,1),2)
22044 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
22045 C...Subtract K.O. valence quark from remainder.
22047 JV=NVSUM(JS)-NVALQ-NVALQB
22048 IV(JS,JV)=IMI(JS,IM,1)
22049 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
22050 C...Subtract K.O. valence antiquark from remainder.
22052 JV=NVSUM(JS)-NVALQ-NVALQB
22053 IV(JS,JV)=IMI(JS,IM,1)
22054 ELSEIF (IFA.EQ.JFA) THEN
22055 C...Outside sea without companion: add opposite sea flavour inside.
22056 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
22059 C...Check if space left in PYJETS for additional BR flavours
22060 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
22061 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
22062 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
22063 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
22067 C...Add required val+sea content to beam remnant.
22068 IF (NFLSUM.GT.0) THEN
22070 C...Insert beam remnant quark as p.t. symbolic parton in ER.
22078 K(N,2)=ISIGN(JFA,NSEA)
22079 IF (IA.LE.NVALQ) K(N,2)=JFA
22080 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
22082 C...Also update NMI, IMI, and IV arrays.
22084 IMI(JS,NMI(JS),1)=N
22085 IMI(JS,NMI(JS),2)=-1
22086 IF (IA.LE.NVALQ+NVALQB) THEN
22087 IMI(JS,NMI(JS),2)=0
22089 IV(JS,JV)=IMI(JS,NMI(JS),1)
22097 IF (IM.LE.NMI(JS)) THEN
22098 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
22100 C...Add fictitious parent gluons for companion pairs.
22101 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
22102 C...Randomly assign companions to sea quarks which have none.
22103 IF (IMI(JS,IM,2).LT.0) THEN
22105 230 IMC=MOD(IMC,NMI(JS))+1
22106 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
22107 IF (IMI(JS,IMC,2).GE.0) GOTO 230
22108 IMI(JS, IM,2) = IMI(JS,IMC,1)
22109 IMI(JS,IMC,2) = IMI(JS, IM,1)
22111 C...Add fictitious parent gluon
22121 C...Set gluon (anti-)colour daughter pointers
22122 K(N,4)=IMI(JS, IM,1)
22123 K(N,5)=IMI(JS, IM,2)
22124 C...Set quark (anti-)colour parent pointers
22125 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
22126 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
22127 C...Add gluon to IMI
22129 IMI(JS,NMI(JS),1)=N
22130 IMI(JS,NMI(JS),2)=0
22135 C...If incoming (anti-)baryon, insert inside (anti-)junction.
22136 C...Set up initial v-v-j-v configuration. Otherwise set up
22137 C...mesonic v-vbar configuration
22138 IF (IABS(MINT(10+JS)).GT.1000) THEN
22139 C...Determine junction type (1: B=1 2: B=-1)
22140 ITJUNC(JS) = (3-KFS)/2
22141 C...Insert junction.
22148 C...Set special junction codes:
22151 C...Set parent to side.
22153 K(N,4)=ITJUNC(JS)*MSTU(5)
22155 C...Connect valence quarks to junction.
22158 C...Set (anti)colour mother = junction.
22160 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22162 C...Keep track of partons adjacent to junction:
22163 JST(JS,JV)=IV(JS,JV)
22166 C...Mesons: set up initial q-qbar topology
22168 IF (K(IV(JS,1),2).GT.0) THEN
22179 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22180 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22181 C...Special for mesons. Insert gluon if BR empty.
22182 IF (NBRTOT(JS).EQ.0) THEN
22196 C...Add gluon to IMI
22198 IMI(JS,NMI(JS),1)=N
22199 IMI(JS,NMI(JS),2)=0
22204 C...Count up number of valence quarks outside BR.
22206 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
22207 & MOUT(JS)=MOUT(JS)+1
22212 C...Now both sides have been prepared in an initial vvjv (baryonic) or
22213 C...v(g)vbar (mesonic) configuration.
22215 C...Create colour line tags starting from initiators.
22217 DO 320 IM=1,MINT(31)
22218 C...Consider each side in turn.
22223 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
22225 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
22228 CALL PYCTTR(I1,KCS,I2)
22229 IF(MINT(51).NE.0) RETURN
22236 C...Create colour tags for beam remnant partons.
22237 DO 330 IM=MINT(31)+1,NMI(JS)
22239 IF (K(IP,2).NE.21) THEN
22240 JC=(3-ISIGN(1,K(IP,2)))/2
22241 IF (MCT(IP,JC).EQ.0) THEN
22250 C...Fictituous gluons just inherit from their quark daughters.
22254 C...Real beam remnant gluons get their own colours
22265 C...Create colour tags for colour lines which are detached from the
22269 DO 350 I=MINT(84)+1,N
22271 C...Look for coloured string endpoint, or (later) leftover gluon.
22272 IF (K(I,1).NE.3) GOTO 350
22274 IF(KC.EQ.0) GOTO 350
22276 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
22278 C...Pick up loose string end with no previous tag.
22280 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
22281 IF(MCT(I,KCS-3).NE.0) GOTO 350
22283 CALL PYCTTR(I,KCS,I)
22284 IF(MINT(51).NE.0) RETURN
22289 C...Store original colour tags
22290 DO 370 I=MINT(84)+1,N
22295 C...Iteratively add gluons to already existing string pieces, enforcing
22296 C...various possible orderings, and rejecting insertions that would give
22297 C...rise to singlet gluons.
22298 C...<kappa tau> normalization.
22303 C...Set up simplified kinematics.
22304 C...Boost hard interaction systems.
22306 DO 380 IM=1,MINT(31)
22307 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22308 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22310 C...Assign preliminary beam remnant momenta.
22311 DO 390 I=MINT(53)+1,N
22315 IF (K(I,2).NE.88) THEN
22316 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
22318 IF (JS.EQ.2) P(I,3)=-P(I,3)
22320 C...Junctions are wildcards for the present.
22326 C...Reset colour processing information.
22327 400 DO 410 I=MINT(84)+1,N
22328 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22329 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22334 C...If meson, without gluon in BR, collapse q-qbar colour tags:
22335 IF (ITJUNC(JS).EQ.0) THEN
22336 JC1=MCT(JST(JS,1),1)
22337 JC2=MCT(JST(JS,2),2)
22339 JCCO(NCC,1)=MAX(JC1,JC2)
22340 JCCO(NCC,2)=MIN(JC1,JC2)
22341 C...Collapse colour tags in event record
22342 DO 420 I=MINT(84)+1,N
22343 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
22344 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
22350 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
22351 IF (NG(JS).GT.0) THEN
22354 C...Start at random gluon (optimizes speed for random attachments)
22356 IMGL=PYR(0)*NMI(JS)+1
22357 450 IMGL=MOD(IMGL,NMI(JS))+1
22359 C...Only loop through NMI once (with upper limit to save time)
22360 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
22361 IGL = IMI(JS,IMGL,1)
22362 C...If not gluon or if already connected, try next.
22363 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
22364 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
22365 C...Now loop through all possible insertions of this gluon.
22367 IMP1=PYR(0)*NMI(JS)+1
22368 460 IMP1=MOD(IMP1,NMI(JS))+1
22370 IF (IMP1.EQ.IMGL) GOTO 460
22371 C...Only loop through NMI once (with upper limit to save time).
22372 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
22373 IP1 = IMI(JS,IMP1,1)
22374 C...Try both colour mother and colour anti-mother.
22375 C...Randomly select which one to try first.
22378 470 MANTI=MOD(MANTI+1,2)
22380 IF (NANTI.LE.2) THEN
22381 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
22382 C...Reject if no appropriate mother (or if mother is fictitious
22384 IF (IP2.LE.0) GOTO 470
22385 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
22386 C...Also reject if this link has already been tried.
22387 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
22388 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
22389 C...Set flag to indicate that this link has now been tried for this
22390 C...gluon. IP2 may be junction, which has several mothers.
22391 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
22392 IF (K(IP2,2).NE.88) THEN
22393 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
22396 C...JCG1: Original colour tag of gluon on IP1 side
22397 C...JCG2: Original colour tag of gluon on IP2 side
22398 C...JCP1: Original colour tag of IP1 on gluon side
22399 C...JCP2: Original colour tag of IP2 on gluon side.
22400 JCG1=MCO(IGL,2-MANTI)
22401 JCG2=MCO(IGL,1+MANTI)
22402 JCP1=MCO(IP1,1+MANTI)
22403 JCP2=MCO(IP2,2-MANTI)
22405 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
22406 C...Reject gluon attachments that give rise to singlet gluons.
22407 IF (MACCPT.EQ.0) GOTO 470
22410 JCG1=MCT(IGL,2-MANTI)
22411 JCG2=MCT(IGL,1+MANTI)
22412 JCP1=MCT(IP1,1+MANTI)
22413 JCP2=MCT(IP2,2-MANTI)
22415 C...Select whether to accept this insertion
22416 IF (MSTP(89).EQ.0) THEN
22417 C...Random insertions: no measure.
22419 C...For random ordering, we want to suppress beam remnant breakups
22420 C...already at this point.
22421 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
22422 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
22427 ELSEIF (MSTP(89).EQ.1) THEN
22428 C...Rapidity ordering:
22429 C...YGL = Rapidity of gluon.
22431 C...If fictitious gluon
22432 IF (YGL.EQ.100D0) THEN
22434 IDA1=MOD(K(IGL,4),MSTU(5))
22435 IDA2=MOD(K(IGL,5),MSTU(5))
22436 DO 480 IMT=1,NMI(JS)
22437 C...Select (arbitrarily) the most central daughter.
22438 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
22440 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
22444 C...YP1 = Rapidity IP1
22446 C...If fictitious gluon
22447 IF (YP1.EQ.100D0) THEN
22449 IDA1=MOD(K(IP1,4),MSTU(5))
22450 IDA2=MOD(K(IP1,5),MSTU(5))
22451 DO 490 IMT=1,NMI(JS)
22452 C...Select (arbitrarily) the most central daughter.
22453 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
22455 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
22459 C...YP2 = Rapidity of mother system
22460 IF (K(IP2,2).NE.88) THEN
22461 DO 500 IMT=1,NMI(JS)
22462 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
22464 C...If fictitious gluon
22465 IF (YP2.EQ.100D0) THEN
22467 IDA1=MOD(K(IP2,4),MSTU(5))
22468 IDA2=MOD(K(IP2,5),MSTU(5))
22469 DO 510 IMT=1,NMI(JS)
22470 C...Select (arbitrarily) the most central daughter.
22471 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
22473 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
22477 C...Assign (arbitrarily) 100D0 to junction also
22481 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
22482 ELSEIF (MSTP(89).EQ.2) THEN
22483 C...Lambda ordering:
22484 C...Compute lambda measure for this insertion.
22489 C...If IP2 is junction, not caught below.
22490 IF (JCP2.EQ.0) THEN
22491 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22492 C...Anti-junction is colour endpoint et vv., always on JCG2.
22495 DO 530 I=MINT(84)+1,N
22496 IF (K(I,1).LT.10) THEN
22497 C...The new string pieces
22498 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22499 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22500 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22501 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22504 C...Also identify junctions as string endpoints.
22505 DO 540 I=MINT(84)+1,N
22506 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22507 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22508 C...Find partons adjacent to junctions.
22509 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22510 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22511 & .EQ.0) ISTR(2) = ICMO
22512 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22513 & .EQ.0) ISTR(4) = ICMO
22515 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22516 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22517 & .EQ.0) ISTR(1) = IAMO
22518 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22519 & .EQ.0) ISTR(3) = IAMO
22522 C...The old string piece
22523 ISTR(5)=ISTR(1+2*MANTI)
22524 ISTR(6)=ISTR(4-2*MANTI)
22525 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22526 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22527 C...If one or more of the colour tags for this connection is/are still
22528 C...dangling, skip this attempt for the time being.
22531 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22532 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22536 C...Allow some breadth to speed things up.
22537 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22539 ELSEIF (RL.GT.RLOPT) THEN
22545 C...INSR(NOPT,1)=Gluon colour mother
22546 C...INSR(NOPT,2)=Gluon
22547 C...INSR(NOPT,3)=Gluon anticolour mother
22548 IF (NOPT.GT.1000) GOTO 470
22549 INSR(NOPT,1+2*MANTI)=IP2
22551 INSR(NOPT,3-2*MANTI)=IP1
22552 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22554 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22556 C...Reset link test information.
22557 DO 550 I=MINT(84)+1,N
22558 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22559 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22561 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22563 C...Now we have a list of best gluon insertions, none of which cause
22564 C...singlets to arise. If list is empty, try again a few times. Note:
22565 C...this should never happen if we have a meson with a gluon inserted
22566 C...in the beam remnant, since that breaks up the colour line.
22567 IF (NOPT.EQ.0) THEN
22568 C...Abandon BR-g-BR suppression for retries. This is not serious, it
22569 C...just means we happened to start with trying a bad sequence.
22571 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22572 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22575 IF (ITJUNC(JS).NE.0) THEN
22579 C...Reset valence quark parent pointers
22580 DO 560 I=MINT(53)+1,N
22581 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22584 C...Set (anti)colour mother = junction.
22586 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22590 C...Same for mesons. JST unchanged, so needn't be restored.
22593 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22594 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22596 C...Also reset gluon parent pointers.
22598 DO 580 IM=1,NMI(JS)
22600 IF (K(I,2).EQ.21) THEN
22601 K(I,4)=MOD(K(I,4),MSTU(5))
22602 K(I,5)=MOD(K(I,5),MSTU(5))
22607 C...Reset colour tags
22608 DO 600 I=MINT(84)+1,N
22614 IF(NERRPR.LT.5) THEN
22617 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22618 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22620 C...Kill event and start another.
22625 C...Select between insertions, suppressing insertions wholly in the BR.
22627 610 IIN=MOD(IIN,NOPT)+1
22628 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22629 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22632 C...Now we know which gluon to insert where. Colour tags in JCCO and
22633 C...colour connection information should be updated, NG(JS) should be
22634 C...counted down, and a new loop performed if there are still gluons
22635 C...left on any side.
22639 C...JCG : Original gluon colour tag
22640 C...JCAG: Original gluon anticolour tag.
22641 C...JCM : Original anticolour tag of gluon colour mother
22642 C...JACM: Original colour tag of gluon anticolour mother
22648 CALL PYMIHG(JACM,JACG,JCM,JCG)
22649 IF (MACCPT.EQ.0) THEN
22650 IF(NERRPR.LT.5) THEN
22653 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22654 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22656 C...Kill event and start another.
22660 C...If everything went fine, store new JCCN in JCCO.
22663 JCCO(ICC,1)=JCCN(ICC,1)
22664 JCCO(ICC,2)=JCCN(ICC,2)
22668 C...One gluon attached is counted as equivalent to one end outside.
22670 C...Set IGL colour mother = ICM.
22671 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22672 C...Set ICM anticolour mother = IGL colour.
22673 IF (K(ICM,2).NE.88) THEN
22674 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22676 C...If ICM is junction, just update JST array for now.
22678 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22681 C...Set IGL anticolour mother = IACM.
22682 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22683 C...Set IACM anticolour mother = IGL anticolour.
22684 IF (K(IACM,2).NE.88) THEN
22685 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22687 C...If IACM is junction, just update JST array for now.
22689 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22692 C...Count down # unconnected gluons.
22695 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22698 C...Collapse fictitious gluons.
22699 DO 670 IGL=MINT(53)+1,N
22700 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22701 & K(IGL,1).EQ.14) THEN
22702 ICM=K(IGL,4)/MSTU(5)
22703 IAM=K(IGL,5)/MSTU(5)
22704 ICD=MOD(K(IGL,4),MSTU(5))
22705 IAD=MOD(K(IGL,5),MSTU(5))
22706 C...Set gluon daughters pointing to gluon mothers
22707 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22708 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22709 C...Set gluon mothers pointing to gluon daughters.
22710 IF (K(ICM,2).NE.88) THEN
22711 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22713 C...Special case: mother=junction. Just update JST array for now.
22715 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22718 IF (K(IAM,2).NE.88) THEN
22719 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22722 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22728 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22731 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22732 IF (IM.GT.MINT(31)) THEN
22734 DO 690 IMR=IM,NMI(JS)
22735 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22736 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22741 C...Finally, connect junction.
22742 IF (ITJUNC(JS).NE.0) THEN
22743 DO 700 I=MINT(53)+1,N
22744 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22746 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22751 C...Find jq with no glue inbetween inside beam remnant.
22752 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22755 C...Set IDQ = -I if q non-valence and = +I if q valence.
22756 IDQ(NBRJQ)=-JST(JS,MSJ)
22758 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22759 IDQ(NBRJQ)=JST(JS,MSJ)
22766 IF (MSJ.EQ.3) I45=4
22767 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22770 C...Check if diquark can be formed.
22771 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22773 C...If there is less than 2 valence quarks connected to junction
22774 C...and MSTP(88)>1, use random non-valence quarks to fill up.
22775 IF (NBRVQ.LE.1) THEN
22777 730 JFLIP=NBRJQ*PYR(0)+1
22778 IF (IDQ(JFLIP).LT.0) THEN
22779 IDQ(JFLIP)=-IDQ(JFLIP)
22782 IF (NDIQ.LE.1) GOTO 730
22784 C...Place selected quarks first in IDQ, ordered in flavour.
22786 IF (IDQ(JDQ).LE.0) THEN
22790 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22797 C...Choose diquark spin.
22798 IF (NBRVQ.EQ.2) THEN
22799 C...If the selected quarks are both valence, we may use SU(6) rules
22800 C...to figure out which spin the diquark has, by a subdivision of the
22801 C...original beam hadron into the selected diquark system plus a kicked
22802 C...out quark, IKO.
22806 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22810 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22812 C...If one or more of the selected quarks are not valence, we cannot use
22813 C...SU(6) subdivisions of the original beam hadron. Instead, with the
22814 C...flavours of the diquark already selected, we assume for now
22815 C...50:50 spin-1:spin-0 (where spin-0 possible).
22816 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22818 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22819 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22820 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22823 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22824 C...Note: third quark can per definition not also be valence,
22825 C...therefore we can only do this if we are allowed to use sea quarks.
22826 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22829 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22830 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22832 ELSEIF(NTRY.GT.100) THEN
22833 C...If no baryon can be found, give up and form diquark.
22837 C...Replace junction by baryon.
22840 K(IJU,3)=MINT(83)+JS
22843 P(IJU,5)=PYMASS(KFBAR)
22845 C...Prepare removal of participating quarks from ER.
22846 K(JST(JS,MSJ),1)=-1
22850 C...If collapse to baryon not possible or not allowed, replace junction
22851 C...by diquark. This way, collapsed gluons that were pointing at the
22852 C...junction will now point (correctly) at diquark.
22856 K(IJU,3)=MINT(83)+JS
22861 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22863 K(IJU,5-MANTI)=IP*MSTU(5)
22864 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22866 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22868 C...Prepare removal of participating quarks from ER.
22874 C...Update so ER pointers to collapsed quarks
22875 C...now go to collapsed object.
22876 DO 820 I=MINT(84)+1,N
22877 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22878 & .K(I,1).GT.0) THEN
22880 IMO=K(I,ISID)/MSTU(5)
22881 IDA=MOD(K(I,ISID),MSTU(5))
22883 IF (K(IMO,1).EQ.-1) IMO=IJU
22886 IF (K(IDA,1).EQ.-1) IDA=IJU
22888 K(I,ISID)=IDA+MSTU(5)*IMO
22895 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22896 C...(this only happens for baryons, where we want to force the gluon
22897 C...to sit next to the junction. Mesons handled above.)
22898 IF (NBRTOT(JS).EQ.0) THEN
22908 K(IGL,3)=MINT(83)+JS
22909 IF (ITJUNC(JS).NE.0) THEN
22910 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22911 JLEG=PYR(0)*NVSUM(JS)+1
22914 JCT=MCT(I1,ITJUNC(JS))
22915 MCT(IGL,3-ITJUNC(JS))=JCT
22917 MCT(IGL,ITJUNC(JS))=NCT
22920 C...Meson. Should not happen.
22921 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22922 IF(NERRPR.LT.5) THEN
22923 WRITE(MSTU(11),*) 'This should not have been possible!'
22930 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22931 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22932 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22933 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22934 IF (K(I2,2).NE.88) THEN
22935 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22937 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22938 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22939 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22940 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22942 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22948 C...Remove collapsed quarks and junctions from ER and update IMI.
22951 C...Also update beam remnant part of IMI.
22954 DO 850 I=MINT(53)+1,N
22955 IF (K(I,1).LE.0) GOTO 850
22956 C...Restore BR quark/diquark/baryon pointers in IMI.
22957 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22960 IMI(JS,NMI(JS),1)=I
22961 IMI(JS,NMI(JS),2)=0
22965 C...Restore companion information from collapsed gluons.
22966 DO 870 I=MINT(53)+1,N
22967 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22969 JCD=MOD(K(I,4),MSTU(5))
22970 JAD=MOD(K(I,5),MSTU(5))
22971 DO 860 IM=1,NMI(JS)
22972 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22973 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22975 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22976 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22980 C...Renumber colour lines (since some have disappeared)
22988 IF (MFOUND.EQ.0) JCD=JCD+1
22989 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22992 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22996 IF (I.LE.N) GOTO 890
22997 IF (JCT.LT.NCT) GOTO 880
23000 C...Reset hard interaction subsystems to their CM frames.
23001 IF (IBOOST.EQ.1) THEN
23002 DO 900 IM=1,MINT(31)
23003 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23004 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
23006 C...Zero beam remnant longitudinal momenta and energies
23007 DO 910 I=MINT(53)+1,N
23013 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
23014 C...Kill event and start another.
23021 C*********************************************************************
23024 C...Adapted from PYPREP.
23025 C...Assigns LHA1 colour tags to coloured partons based on
23026 C...K(I,4) and K(I,5) colour connection record.
23027 C...KCS negative signifies that a previous tracing should be continued.
23028 C...(in case the tag to be continued is empty, the routine exits)
23029 C...Starts at I and ends at I or IEND.
23030 C...Special considerations for systems with junctions.
23031 C...Special: if IEND=-1, means trace this parton to its color partner,
23032 C... then exit. If no partner found, exit with 0.
23034 SUBROUTINE PYCTTR(I,KCS,IEND)
23035 C...Double precision and integer declarations.
23036 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23037 INTEGER PYK,PYCHGE,PYCOMP
23039 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23041 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23042 COMMON/PYINT1/MINT(400),VINT(400)
23043 C...The common block of colour tags.
23044 COMMON/PYCTAG/NCT,MCT(4000,2)
23045 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
23049 C...Skip if parton not existing or does not have KCS
23050 IF (K(I,1).LE.0) GOTO 120
23052 IF (KC.EQ.0) GOTO 120
23054 IF (KQ.EQ.0) GOTO 120
23055 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
23060 C...Set colour tag of first parton.
23066 IF (NCS.EQ.0) GOTO 120
23072 IF(NSTP.GT.4*N) THEN
23073 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
23077 C...Finished if reached final-state triplet.
23078 IF(K(IA,1).EQ.3) THEN
23079 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
23082 C...Also finished if reached junction.
23083 IF(K(IA,1).EQ.42) THEN
23087 C...GOTO next parton in colour space.
23089 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
23090 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
23092 IA=MOD(K(IB,KCS),MSTU(5))
23093 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
23096 C...If KCS mother traced or KCS mother nonexistent, switch colour.
23097 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
23098 & MSTU(5)).EQ.0) THEN
23102 C...Assign new colour tag on other side of old parton.
23105 C...Goto (new) KCS mother, set mother traced tag
23106 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
23107 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
23110 IF(IA.LE.0.OR.IA.GT.N) THEN
23111 IF (IEND.EQ.-1) THEN
23115 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
23116 IF(NERRPR.LT.5) THEN
23117 write(*,*) 'began at ',I
23118 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
23119 & ' NCS=',NCS,' MREV=',MREV
23126 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
23127 & MSTU(5)).EQ.IB) THEN
23128 IF(MREV.EQ.1) KCS=9-KCS
23129 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
23130 C...Set KSC mother traced tag for IA
23131 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
23133 IF(MREV.EQ.0) KCS=9-KCS
23134 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
23135 C...Set KCS daughter traced tag for IA
23136 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
23138 C...Assign new colour tag
23140 C...Finish if IEND=-1 and found final-state color partner
23141 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
23145 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
23150 *********************************************************************
23153 C...Collapse JCP1 and connecting tags to JCG1.
23154 C...Collapse JCP2 and connecting tags to JCG2.
23156 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
23157 C...Double precision and integer declarations.
23158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23159 IMPLICIT INTEGER(I-N)
23160 INTEGER PYK,PYCHGE,PYCOMP
23161 C...The event record
23162 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23164 COMMON/PYINT1/MINT(400),VINT(400)
23165 SAVE /PYJETS/,/PYINT1/
23166 C...Local variables
23167 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
23168 COMMON /PYCTAG/NCT,MCT(4000,2)
23169 SAVE /PYCBLS/,/PYCTAG/
23171 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
23172 C...in temporary tag collapse array JCCN. Only break up one connection.
23176 JCCN(ICC,1)=JCCO(ICC,1)
23177 JCCN(ICC,2)=JCCO(ICC,2)
23178 C...If there was a mother, it was previously connected to JCP1.
23179 C...Should be changed to JCP2.
23180 IF (MCLPS.EQ.0) THEN
23181 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
23183 JCCN(ICC,1)=MAX(JCG2,JCP2)
23184 JCCN(ICC,2)=MIN(JCG2,JCP2)
23189 C...Also collapse colours on JCP1 side of JCG1
23190 IF (JCP1.NE.0) THEN
23191 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
23192 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
23194 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
23195 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
23198 C...Initialize event record colour tag array MCT array to MCO.
23199 DO 110 I=MINT(84)+1,N
23205 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
23206 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
23207 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
23208 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
23210 C...Skip if junction.
23211 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
23212 C...Define starting point in tag space.
23213 C...JCA = previous tag
23214 C...JCO = present tag
23216 IF (MOD(IS,2).EQ.1) THEN
23220 ELSEIF (MOD(IS,2).EQ.0) THEN
23226 120 ITRACE=ITRACE+1
23227 IF (ITRACE.GT.1000) THEN
23228 C...NB: Proper error message should be defined here.
23230 & ,'(PYMIHG:) Inf loop when collapsing colours.')
23231 MINT(57)=MINT(57)+1
23235 C...Collapse all JCN tags to JCALL
23236 DO 130 I=MINT(84)+1,N
23237 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
23238 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
23240 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
23241 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
23248 C...If possible, step from JCO to new tag JCN not equal to JCA.
23250 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
23252 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
23255 C...Iterate if new colour was arrived at, but don't go in circles.
23256 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
23257 C...Change all JCN tags in MCO to JCALL in MCT.
23258 DO 150 I=MINT(84)+1,N
23259 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
23260 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
23261 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23262 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
23267 DO 200 JCL=NCT,1,-1
23272 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
23274 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
23277 C...Overpaint all JCN with JCL
23278 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
23279 DO 190 I=MINT(84)+1,N
23280 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
23281 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
23282 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23283 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
23294 C*********************************************************************
23297 C...Picks primordial kT and shares longitudinal momentum among
23302 C...Double precision and integer declarations.
23303 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23304 IMPLICIT INTEGER(I-N)
23305 INTEGER PYK,PYCHGE,PYCOMP
23306 C...The event record
23307 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23309 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23310 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23311 COMMON/PYINT1/MINT(400),VINT(400)
23312 C...The common block of colour tags.
23313 COMMON/PYCTAG/NCT,MCT(4000,2)
23314 C...The common block of dangling ends
23315 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
23316 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
23317 & XMI(2,240),PT2MI(240),IMISEP(0:240)
23318 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
23319 C...Local variables
23320 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
23321 C...W(I,J)| J=0 | 1 | 2 |
23322 C... I=0 | Wrem**2 | W+ | W- |
23323 C... 1 | W1**2 | W1+ | W1- |
23324 C... 2 | W2**2 | W2+ | W2- |
23326 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)
23327 C...Tentative parametrization of <kT> as a function of Q.
23328 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
23329 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
23330 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
23331 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
23332 C...Lambda kinematic function.
23333 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
23335 C...Beginning and end of beam remnant partons
23339 C...Loopback point if kinematic choices gives impossible configuration.
23343 C...Assign kT values on each side separately.
23346 C...First zero all kT on this side. Skip if no kT to generate.
23347 DO 110 IM=1,NMI(JS)
23348 P(IMI(JS,IM,1),1)=0D0
23349 P(IMI(JS,IM,1),2)=0D0
23351 IF(MSTP(91).LE.0) GOTO 180
23353 C...Now assign kT to each (non-collapsed) parton in IMI.
23354 DO 170 IM=1,NMI(JS)
23356 C...Select kT according to truncated gaussian or 1/kt6 tails.
23357 C...For first interaction, either use rms width = PARP(91) or fitted.
23360 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
23365 C...For subsequent interactions and BR partons use fragmentation width.
23370 IF(NTRY.LE.100) THEN
23371 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
23375 ELSEIF (MSTP(91).EQ.2) THEN
23376 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
23377 & 'available, using MSTP(91)=1.')
23378 CALL PYGIVE('MSTP(91)=1')
23380 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
23381 C...Use distribution with kt**6 tails, rms width = PARP(91).
23382 EPS=SQRT(3D0/2D0)*SIGMA
23383 C...Generate PTX and PTY separately, each propto 1/KT**6
23385 C...Decide which interval to try
23386 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
23387 IF (PYR(0).LT.P12) THEN
23388 C...Use flat approx with accept/reject up to EPS.
23390 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
23391 IF (PYR(0).GT.WT) GOTO 112
23393 C...Above EPS, use 1/kt**6 approx with accept/reject.
23394 PT=EPS/(PYR(0)**(1D0/5D0))
23395 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
23396 IF (PYR(0).GT.WT) GOTO 112
23399 IF (PYR(0).GT.0.5D0) MSIGN=-1
23400 IF (IXY.EQ.1) PTX=MSIGN*PT
23401 IF (IXY.EQ.2) PTY=MSIGN*PT
23403 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
23404 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
23405 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
23407 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
23408 PT=SQRT(PTX**2+PTY**2)
23410 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
23411 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
23414 PT=SQRT(PTX**2+PTY**2)
23420 C...Compensation kicks, with varying degree of local anticorrelations.
23422 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
23423 PTCX=-PTX/(NMI(JS)-1)
23424 PTCY=-PTY/(NMI(JS)-1)
23425 IF(ISUB.EQ.95) THEN
23426 PTCX=-PTX/(NMI(JS)-2)
23427 PTCY=-PTY/(NMI(JS)-2)
23429 DO 120 IMC=1,NMI(JS)
23430 IF (IMC.EQ.IM) GOTO 120
23431 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
23432 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
23433 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
23435 ELSEIF (MCORR.GE.1) THEN
23438 C...Count up # of neighbours on either side
23440 130 IMO=K(IMO,MSID)/MSTU(5)
23441 IF (IMO.EQ.0) GOTO 140
23442 NNXT(MSID-3)=NNXT(MSID-3)+1
23443 C...Stop at quarks and junctions
23444 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
23446 C...How should compensation be shared when unequal numbers on the
23447 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
23448 NSUM=NNXT(1)+NNXT(2)
23451 C...Total momentum to be compensated on this side
23452 IF (NNXT(MSID-3).EQ.0) GOTO 160
23453 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
23454 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
23455 C...RS: compensation supression factor as we go out from parton I.
23456 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
23457 C...since (for now) MSTP(90) provides enough variability.
23459 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
23462 IMO=K(IMO,MSID)/MSTU(5)
23463 IF (IMO.EQ.0) GOTO 160
23465 IF (K(IMO,2).NE.88) THEN
23466 P(IMO,1)=P(IMO,1)+FAC*PTCX
23467 P(IMO,2)=P(IMO,2)+FAC*PTCY
23468 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
23469 C...If we reach junction, divide out the kT that would have been
23470 C...assigned to the junction on each of its other legs.
23472 L1=MOD(K(IMO,4),MSTU(5))
23473 L2=K(IMO,5)/MSTU(5)
23474 L3=MOD(K(IMO,5),MSTU(5))
23475 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
23476 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
23477 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
23478 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
23479 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
23480 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
23481 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
23482 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
23488 C...End assignment of kT values to initiators and remnants.
23491 C...Check kinematics constraints for non-BR partons.
23492 DO 190 IM=1,MINT(31)
23493 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23494 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23495 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23496 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23497 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23498 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23499 IF(NTRY.GE.100) THEN
23500 C...Kill this event and start another.
23502 & '(PYMIRM:) No consistent (x,kT) sets found')
23510 C...Calculate W+ and W- available for combined remnant system.
23513 DO 200 IM=1,MINT(31)
23514 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23515 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23516 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23517 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23518 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23520 C...Also store Wrem**2 = W+ * W-
23521 W(0,0)=W(0,1)*W(0,2)
23523 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23524 IF(NTRY.GE.100) THEN
23525 C...Kill this event and start another.
23527 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23534 C...Assign unscaled x values to partons/hadrons in each of the
23535 C...beam remnants and calculate unscaled W+ and W- from them.
23541 DO 270 IM=MINT(31)+1,NMI(JS)
23547 C...Skip collapsed gluons and junctions. Reset.
23548 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23549 IF (KFA.EQ.88) GOTO 270
23556 C...If gluon then only beam remnant, so takes all.
23559 C...If valence quark then use parametrized valence distribution.
23560 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23562 C...If companion quark then derive from companion x.
23563 ELSEIF(KFA.LE.6) THEN
23565 C...If valence diquark then use two parametrized valence distributions.
23566 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23568 IVALQ(1)=ISIGN(KFA/1000,KF)
23569 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23570 C...If valence+sea diquark then combine valence + companion choices.
23571 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23572 & ICOMP.LT.MSTU(5)) THEN
23573 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23574 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23576 IVALQ(1)=ISIGN(KFA/1000,KF)
23579 C...Extra code: workaround for diquark made out of two sea
23580 C...quarks, but where not (yet) ICOMP > MSTU(5).
23581 DO 220 IM1=1,MINT(31)
23582 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23583 ICOMQ(2)=IMI(JS,IM1,1)
23587 C...If sea diquark then sum of two derived from companion x.
23588 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23589 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23590 ICOMQ(2)=ICOMP/MSTU(5)
23591 C...If meson or baryon then use fragmentation function.
23592 C...Somewhat arbitrary split into old and new flavour, but OK normally.
23594 KFL3=MOD(KFA/10,10)
23595 IF(MOD(KFA/1000,10).EQ.0) THEN
23596 KFL1=MOD(KFA/100,10)
23598 KFL1=MOD(KFA,10000)-10*KFL3-1
23599 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23600 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23602 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23603 CALL PYZDIS(KFL1,KFL3,PR,X)
23607 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23608 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23609 C...In other baryons combine u and d from proton appropriately.
23610 IF(IVALQ(IQ).NE.0) THEN
23612 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23613 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23614 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23616 IF(KFIVAL(JS,3).EQ.0) THEN
23618 C...Baryon with three identical quarks: mix u and d forms.
23619 ELSEIF(NVAL.EQ.3) THEN
23620 MDU=INT(PYR(0)+5D0/3D0)
23621 C...Baryon, one of two identical quarks: u form.
23622 ELSEIF(NVAL.EQ.2) THEN
23624 C...Baryon with two identical quarks, but not the one picked: d form.
23625 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23626 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23628 C...Baryon with three nonidentical quarks: mix u and d forms.
23630 MDU=INT(PYR(0)+5D0/3D0)
23633 IF(MDU.EQ.1) XPOW=3.5D0
23634 IF(MDU.EQ.2) XPOW=2D0
23636 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23640 C...Calculation of x of companion quark.
23641 IF(ICOMQ(IQ).NE.0) THEN
23643 DO 240 IM1=1,MINT(31)
23644 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23646 NPOW=MAX(0,MIN(4,MSTP(87)))
23647 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23648 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23649 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23650 IF(CORR.LT.PYR(0)) GOTO 250
23655 C...Optionally enchance x of composite systems (e.g. diquarks)
23656 IF (KFA.GT.100) X=PARP(79)*X
23658 C...Store x. Also calculate light cone energies of each system.
23660 W(JS,JS)=W(JS,JS)+X
23661 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23663 W(JS,JS)=W(JS,JS)*W(0,JS)
23664 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23665 W(JS,0)=W(JS,1)*W(JS,2)
23668 C...Check W1 W2 < Wrem (can be done before rescaling, since W
23669 C...insensitive to global rescalings of the BR x values).
23670 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23673 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23675 ELSEIF (NTRYX.GT.100) THEN
23676 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23677 MINT(57)=MINT(57)+1
23682 C...Compute x rescaling factors
23683 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23684 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23685 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23687 IF (R1.LT.0.OR.R2.LT.0) THEN
23688 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23689 MINT(57)=MINT(57)+1
23693 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23699 C...Rescale BR x values.
23700 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23701 XMI(1,IM)=XMI(1,IM)*R1
23702 XMI(2,IM)=XMI(2,IM)*R2
23705 C...Now we have a consistent set of x and kT values.
23706 C...First set up the initiators and their daughters correctly.
23707 DO 300 IM=1,MINT(31)
23710 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23711 & (P(I1,2)+P(I2,2))**2
23712 PT12=P(I1,1)**2+P(I1,2)**2
23713 PT22=P(I2,1)**2+P(I2,2)**2
23715 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23717 C...Energies (masses should be zero at this stage)
23718 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23719 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23721 C...Transverse 12 system initiator velocity:
23722 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23723 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23724 C...Boost to overall initiator system rest frame
23725 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23726 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23728 C...Compute phi,theta coordinates of I1 and rotate z axis.
23729 PHI=PYANGL(P(I1,1),P(I1,2))
23730 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23731 IMIN=IMISEP(IM-1)+1
23732 C...(include documentation lines if MI = 1)
23733 IF (IM.EQ.1) IMIN=MINT(83)+5
23735 C...Rotate entire system in phi
23736 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23737 C...Only rotate 12 system in theta
23738 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23739 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23741 C...Now boost entire system back to LAB
23742 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23743 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23744 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23749 C...For the beam remnant partons/hadrons, we only need to set pz and E.
23751 DO 310 IM=MINT(31)+1,NMI(JS)
23753 C...Skip collapsed gluons and junctions.
23754 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23755 IF (KFA.EQ.88) GOTO 310
23756 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23757 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23758 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23759 IF (JS.EQ.2) P(I,3)=-P(I,3)
23764 C...Documentation lines
23770 K(IN,3)=MINT(83)+JS
23777 MCT(IN,1)=MCT(IO,1)
23778 MCT(IN,2)=MCT(IO,2)
23781 C...Final state colour reconnections.
23782 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23784 C...Number of colour tags for which a recoupling will be tried.
23786 C...Number of recouplings to try
23794 IF (IITER.LE.PARP(78)*NTOT) THEN
23795 C...Select two colour tags at random
23796 C...NB: jj strings do not have colour tags assigned to them,
23797 C...thus they are as yet not affected by anything done here.
23799 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23804 C...Find final state partons with this (anti)colour
23805 DO 370 I=MINT(84)+1,N
23806 IF (K(I,1).EQ.3) THEN
23807 IF (MCT(I,1).EQ.JCT) IJ1=I
23808 IF (MCT(I,2).EQ.JCT) IJ2=I
23809 IF (MCT(I,1).EQ.KCT) IK1=I
23810 IF (MCT(I,2).EQ.KCT) IK2=I
23813 C...Only consider recouplings not involving junctions for now.
23814 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23816 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23817 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23818 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23821 C...Count up number of reconnections
23822 MINT(34)=MINT(34)+1
23824 IF (MINT(34).LE.1000) THEN
23827 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23831 IF (NRECP.LT.MINT(34)) GOTO 350
23833 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23839 C*********************************************************************
23842 C...Performs colour annealing.
23843 C...MSTP(95) : CR Type
23844 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23845 C... = 2 : Type I(no gg loops); hadron-hadron only
23846 C... = 3 : Type I(no gg loops); all beams
23847 C... = 4 : Type II(gg loops) ; hadron-hadron only
23848 C... = 5 : Type II(gg loops) ; all beams
23849 C... = 6 : Type S ; hadron-hadron only
23850 C... = 7 : Type S ; all beams
23851 C... = 8 : Type P ; hadron-hadron only
23852 C... = 9 : Type P ; all beams
23853 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23854 C...Type S is driven by starting only from free triplets, not octets.
23855 C...Type P is also driven by free triplets, but the reconnect probability
23856 C...is computed from the string density per unit rapidity, where the axis
23857 C...with respect to which the rapidity is computed is the Thrust axis of the
23859 C...A string piece remains unchanged with probability
23860 C... PKEEP = (1-PARP(78))**N
23861 C...This scaling corresponds to each string piece having to go through
23862 C...N other ones, each with probability PARP(78) for reconnection.
23863 C...For types I, II, and S, N is chosen simply as the number of multiple
23864 C...interactions, for a rough scaling with the general level of activity.
23865 C...For type P, N is chosen to be the number of string pieces in a given
23866 C...interval of rapidity (minus one, since the string doesn't reconnect
23867 C...with itself), and the reconnect probability is interpreted as the
23868 C...probability per unit rapidity.
23869 C...It also also possible to apply a dampening factor to the CR strength,
23870 C...using PARP(77), which will cause reconnections among high-pT string
23871 C...pieces to be suppressed.
23873 SUBROUTINE PYFSCR(IP)
23874 C...Double precision and integer declarations.
23875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23876 INTEGER PYK,PYCHGE,PYCOMP
23878 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23879 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23880 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23882 COMMON/PYINT1/MINT(400),VINT(400)
23883 C...The common block of colour tags.
23884 COMMON/PYCTAG/NCT,MCT(4000,2)
23885 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23887 C...MCN: Temporary storage of new colour tags
23888 INTEGER MCN(4000,2)
23889 C...Arrays for storing color strings
23890 PARAMETER (NBINY=100)
23891 INTEGER ICR(4000),MSCR(4000)
23892 INTEGER IOPT(4000), NSTRY(NBINY)
23893 DOUBLE PRECISION RLOPTC(4000)
23895 C...Function to give four-product.
23896 FOUR(I,J)=P(I,4)*P(J,4)
23897 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23899 C...Check valid range of MSTP(95), local copy
23900 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23901 MSTP95=MOD(MSTP(95),10)
23902 C...Set whether CR allowed inside resonance systems or not
23903 C...(not implemented yet)
23905 C IF (MSTP(95).GE.10) MRESCR=0
23907 C...Check whether colour tags already defined
23908 IF (MINT(33).EQ.0) THEN
23909 C...Erase any existing colour tags for this event
23914 C...Create colour tags for this event
23916 IF (K(I,1).EQ.3) THEN
23919 IF (MCT(I,KCSIN-3).EQ.0) THEN
23920 CALL PYCTTR(I,KCSIN,I)
23925 C...Instruct PYPREP to use colour tags
23929 C...For MSTP(95) even, only apply to hadron-hadron
23932 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23934 C...Initialize new tag array (but do not delete old yet)
23936 DO 130 I=MAX(1,IP),N
23941 C...For Paquis type, determine thrust axis (default along Z axis)
23945 IF (MSTP95.GE.8) THEN
23946 CALL PYTHRU(THRDUM,OBLDUM)
23952 C...For each final-state dipole, check whether string should be
23963 DO 140 I=MAX(1,IP),N
23964 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23965 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23967 IF (IC.NE.0.AND.IA.NE.0) THEN
23968 C...Save smallest NCT value so far
23969 ICTMIN = MIN(ICTMIN,ICT)
23970 C...For Paquis algorithm, just store all string pieces for now
23971 IF (MSTP95.GE.8) THEN
23972 C... Add coloured parton
23977 C... Store rapidity (along Thrust axis) in RLOPT for the time being
23978 C... Add pion mass headroom to energy for this calculation
23979 EET = P(IC,4)*SQRT(1D0+(0.135D0/P(IC,4))**2)
23980 PZT = P(IC,1)*TX+P(IC,2)*TY+P(IC,3)*TZ
23981 RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
23982 C... Add anti-coloured parton
23987 C... Store rapidity (along Thrust axis) in RLOPT for the time being
23988 EET = P(IA,4)*SQRT(1D0+(0.135D0/P(IA,4))**2)
23989 PZT = P(IA,1)*TX+P(IA,2)*TY+P(IA,3)*TZ
23990 RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
23991 C... Keep track of largest endpoint "rapidity"
23992 RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR)))
23993 RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR-1)))
23996 C... Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23997 C... (so far ignores the possibility that the whole "muck" may be moving.)
23998 IF (PARP(77).GT.0D0) THEN
23999 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
24000 C... For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
24001 IF (KA1.LT.100.AND.KA2.LT.100) THEN
24002 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
24004 P2STR = 3D0/2D0 * PT2STR
24006 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
24007 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
24008 C... Estimate number of particles ~ log(M2), cut off at 1.
24009 RLOGM2=MAX(1D0,LOG(RM2STR))
24011 C... Supress reconnection probability by 1/(1+P77*P2AVG)
24012 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
24014 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
24015 IF (PYR(0).LE.PKEEP) THEN
24020 C... Add coloured parton
24026 C... Add anti-coloured parton
24038 IF (MSTP95.GE.8) THEN
24039 C... For Paquis type, make "histogram" of string densities along thrust axis
24041 DRAP = 2*RAPMAX/(1D0*NBINY)
24042 C... Explicitly zero histogram bin content
24043 DO 147 IBINY=1,NBINY
24046 DO 152 ISTR=1,NCR-1,2
24049 Y1 = MIN(RLOPTC(ISTR),RLOPTC(ISTR+1))
24050 Y2 = MAX(RLOPTC(ISTR),RLOPTC(ISTR+1))
24051 DO 153 IBINY=1,NBINY
24052 YBINLO = RAPMIN + (IBINY-1)*DRAP
24053 C... If bin inside string piece, add 1 in this bin
24054 C... (Strictly speaking: if it starts before midpoint and ends after midpoint)
24055 IF (Y1.LE.YBINLO+0.5*DRAP.AND.Y2.GE.YBINLO+0.5*DRAP)
24056 & NSTRY(IBINY) = NSTRY(IBINY) + 1
24059 C... Loop over pieces to find individual reconnect probability
24060 DO 167 IS=1,NCR-1,2
24063 C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX
24064 RBINLO = (MIN(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
24065 RBINHI = (MAX(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
24066 C...Make sure integer bin numbers lie inside proper range
24067 IBINLO = MAX(1,MIN(NBINY,NINT(RBINLO)))
24068 IBINHI = MAX(1,MIN(NBINY,NINT(RBINHI)))
24069 C...Size of rapidity bins (is < DRAP if piece smaller than one bin)
24070 C...(also smaller than DRAP if a one-unit wide piece is stretched
24071 C... over 2 bins, thus making the computation more accurate)
24072 DRAPAV = (RBINHI-RBINLO)/(IBINHI-IBINLO+1)*DRAP
24073 C... Decide whether to suppress reconnections in high-pT string pieces
24075 IF (PARP(77).GT.0D0) THEN
24076 C... Total string piece energy, momentum squared, and components
24077 EES = P(ICR(IS),4) + P(ICR(IS+1),4)
24078 PPS2 = (P(ICR(IS),1)+ P(ICR(IS+1),1))**2
24079 & + (P(ICR(IS),2)+ P(ICR(IS+1),2))**2
24080 & + (P(ICR(IS),3)+ P(ICR(IS+1),3))**2
24081 PZTS = P(ICR(IS),1)*TX+P(ICR(IS),2)*TY+P(ICR(IS),3)*TZ
24082 & + P(ICR(IS+1),1)*TX+P(ICR(IS+1),2)*TY+P(ICR(IS+1),3)*TZ
24083 PTTS = SQRT(PPS2 - PZTS**2)
24084 C... Mass of string piece in units of mpi (at least 1)
24086 RM2STR = MAX(RMPI2,EES**2 - PPS2)
24087 C... Estimate number of pions ~ log(M2) (at least 1)
24088 RNPI = LOG(RM2STR/RMPI2)+1D0
24089 PT2AVG = (PTTS / RNPI)**2
24090 C... Supress reconnection probability by 1/(1+P77*P2AVG)
24091 CRMODF=1D0/(1D0+PARP(77)**2*PT2AVG)
24094 DO 178 IBINY=IBINLO,IBINHI
24095 C DNSUM = DNSUM + 1D0
24096 DNOVL = MAX(0,NSTRY(IBINY)-1)
24097 PKEEP = PKEEP * (1D0-CRMODF*PARP(78))**(DRAPAV*DNOVL)
24098 C DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
24100 C DNAVG = DNAVG / DNSUM
24101 C... If keeping string piece, save
24102 IF (PYR(0).LE.PKEEP) THEN
24105 MCN(ICR(IS+1),2)=LCT
24110 C...Skip if there is only one possibility
24115 C...Reorder, so ordered in I (in order to correspond to old algorithm)
24126 MSCR(IC1)=MSCR(IC1+1)
24132 C...Max do 1000 reordering loops
24133 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
24135 C...PS: 03 May 2010
24136 C...For Seattle and Paquis types, check if there is a dangling tag
24137 C...Needed for special case when entire reconnected state was one or
24138 C...more gluon loops in original topology in which case these CR
24139 C...algorithms need to be told they shouldn't look for a dangling tag.
24141 IF (MSTP95.GE.6.AND.MSTP95.LE.9) THEN
24145 MCI=KCHG(PYCOMP(K(I1,2)),2)*ISIGN(1,K(I1,2))
24146 IF (MCI.EQ.1.AND.MCN(I1,1).EQ.0) M3FREE=1
24147 IF (MCI.EQ.-1.AND.MCN(I1,2).EQ.0) M3FREE=1
24149 IF (MCN(I1,1).NE.0.AND.MCN(I1,2).EQ.0) M3FREE=1
24150 IF (MCN(I1,2).NE.0.AND.MCN(I1,1).EQ.0) M3FREE=1
24155 C...Loop over CR partons
24156 C...(Ignore junctions for now.)
24161 C...Loop over coloured partons
24163 C...Retrieve parton Event Record index and Colour Side
24166 C...Skip already connected partons
24167 IF (MCN(I,MSI).NE.0) GOTO 230
24168 C...Shorthand for colour charge
24169 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
24170 C...For Seattle algorithm, only start from partons with one dangling
24171 C...colour tag (unless there aren't any, cf. M3FREE above.)
24172 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
24173 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0
24174 & .AND.M3FREE.EQ.1) THEN
24178 C...Retrieve saved optimal partner
24181 C...Reject saved optimal partner if latter is now connected
24182 C...(Also reject if using model S1, since saved partner may
24183 C...now give rise to gg loop.)
24184 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
24190 C...Search for new optimal partner if necessary
24191 IF (IOPT(IC1).EQ.0) THEN
24195 C...Loop over partons you can connect to
24199 C...Skip if already connected
24200 IF (MCN(J,MSJ).NE.0) GOTO 210
24201 C...Skip if this not colour-anticolour pair
24202 IF (MSI.EQ.MSJ) GOTO 210
24203 C...And do not let gluons connect to themselves
24204 IF (I.EQ.J) GOTO 210
24205 C...Suppress direct connections between partons in same Beam Remnant
24207 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
24209 C...Shorthand for colour charge
24210 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
24211 C...Check for gluon loops
24213 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
24214 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
24215 & MCN(I,2).NE.0) MGGSTR=1
24217 C...Save connection with smallest lambda measure
24219 C...If best so far was a BR string and this is not, also save.
24220 C...If best so far was a gg string and this is not, also save.
24221 C...NB: this is not fool-proof. If the algorithm finds a BR or gg
24222 C...string with a small Lambda measure as the last step, this connection
24223 C...will be saved regardless of whether other possibilities existed.
24224 C...I.e., there should really be a check whether another possibility has
24225 C...already been found, but since these models are now actively in use
24226 C...and uncertainties are anyway large, the algorithm is left as it is.
24227 C...(correction --> Pythia 8 ?)
24228 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
24229 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
24230 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
24231 C...Paquis type: fix problem above
24233 IF (MSTP95.GE.8.AND.RLOPT.LE.1D18) THEN
24234 IF (MBRSTR.EQ.1.AND.MBROPT.EQ.0) MPAQ=1
24235 IF (MGGSTR.EQ.1.AND.MGGOPT.EQ.0) MPAQ=1
24237 IF (MPAQ.EQ.0) THEN
24247 IF (IOPT(IC1).NE.0) THEN
24248 C...Save pair with largest RLOPT so far
24249 IF (RLOPT.GE.RLMAX) THEN
24255 C...Save and iterate
24257 IF (ICRMAX.GT.0) THEN
24263 MCN(ILMAX,ICMAX)=LCT
24264 MCN(JLMAX,JCMAX)=LCT
24265 IF (NLOOP.LE.2*(N-IP)) THEN
24268 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
24272 C...Save and exit. First check for leftover gluon(s)
24273 DO 260 I=MAX(1,IP),N
24274 C...Check colour charge
24275 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
24276 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
24277 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
24278 C...Decide where to put left-over gluon (minimal insertion)
24281 C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones
24282 DO 250 KCT=ICTMIN,LCT
24285 DO 240 IT=MAX(1,IP),N
24286 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
24287 IF (MCN(IT,1).EQ.KCT) IC=IT
24288 IF (MCN(IT,2).EQ.KCT) IA=IT
24290 C...Skip if this color tag no longer present in event record
24291 IF (IC.EQ.0.OR.IA.EQ.0) GOTO 250
24292 RL=FOUR(IC,I)*FOUR(IA,I)
24293 IF (RL.LT.RLMAX) THEN
24300 MCN(I,1)=MCN(ICMAX,1)
24305 C...Here we need to loop over entire event.
24306 DO 270 IZ=MAX(1,IP),N
24307 C...Do not erase parton shower colour history
24308 IF (K(IZ,1).NE.3) GOTO 270
24309 C...Check colour charge
24310 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
24311 IF (MCI.EQ.0) GOTO 270
24312 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
24313 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
24320 C*********************************************************************
24323 C...Handles diffractive and elastic scattering.
24327 C...Double precision and integer declarations.
24328 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24329 IMPLICIT INTEGER(I-N)
24330 INTEGER PYK,PYCHGE,PYCOMP
24332 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24334 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24335 COMMON/PYINT1/MINT(400),VINT(400)
24336 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
24338 C...Reset K, P and V vectors. Store incoming particles.
24339 DO 110 JT=1,MSTP(126)+10
24359 P(I,J)=VINT(285+5*JT+J)
24364 C...Subprocess; kinematics.
24365 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
24366 PZ=SQRT(SQLAM)/(2D0*VINT(1))
24369 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
24372 C...Elastically scattered particle. (Except elastic GVMD states.)
24373 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
24374 & MINT(106+JT).NE.3)) THEN
24379 P(N,3)=PZ*(-1)**(JT+1)
24381 P(N,5)=SQRT(VINT(62+JT))
24383 C...Decay rho from elastic scattering of gamma with sin**2(theta)
24384 C...distribution of decay products (in rho rest frame).
24385 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
24387 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
24391 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
24392 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
24393 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
24394 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
24395 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
24396 140 CTHE=2D0*PYR(0)-1D0
24397 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
24398 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
24400 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
24403 C...Diffracted particle: low-mass system to two particles.
24404 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
24410 PMMAS=SQRT(VINT(62+JT))
24413 IF(NTRY.LT.20) THEN
24414 MINT(105)=MINT(102+JT)
24415 MINT(109)=MINT(106+JT)
24416 CALL PYSPLI(KFH,21,KFL1,KFL2)
24417 CALL PYKFDI(KFL1,0,KFL3,KF1)
24418 IF(KF1.EQ.0) GOTO 150
24419 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
24420 IF(KF2.EQ.0) GOTO 150
24427 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
24432 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
24433 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
24436 P(N-1,4)=SQRT(PM1**2+PZP**2)
24437 P(N,4)=SQRT(PM2**2+PZP**2)
24438 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
24440 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
24441 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
24443 C...Diffracted particle: valence quark kicked out.
24444 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
24451 MINT(105)=MINT(102+JT)
24452 MINT(109)=MINT(106+JT)
24453 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
24454 P(N-1,5)=PYMASS(K(N-1,2))
24455 P(N,5)=PYMASS(K(N,2))
24456 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
24457 & 4D0*P(N-1,5)**2*P(N,5)**2
24458 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
24459 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
24460 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
24461 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
24462 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
24464 C...Diffracted particle: gluon kicked out.
24473 MINT(105)=MINT(102+JT)
24474 MINT(109)=MINT(106+JT)
24475 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
24477 P(N-2,5)=PYMASS(K(N-2,2))
24479 P(N,5)=PYMASS(K(N,2))
24480 C...Energy distribution for particle into two jets.
24482 IF(MOD(KFH/1000,10).NE.0) IMB=2
24483 CHIK=PARP(92+2*IMB)
24484 IF(MSTP(92).LE.1) THEN
24485 IF(IMB.EQ.1) CHI=PYR(0)
24486 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24487 ELSEIF(MSTP(92).EQ.2) THEN
24488 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
24489 ELSEIF(MSTP(92).EQ.3) THEN
24490 CUT=2D0*0.3D0/VINT(1)
24492 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
24494 ELSEIF(MSTP(92).EQ.4) THEN
24495 CUT=2D0*0.3D0/VINT(1)
24496 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
24497 180 CHIR=CUT*CUTR**PYR(0)
24498 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
24499 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
24501 CUT=2D0*0.3D0/VINT(1)
24502 CUTA=CUT**(1D0-PARP(98))
24503 CUTB=(1D0+CUT)**(1D0-PARP(98))
24504 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
24505 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
24506 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
24508 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
24509 & VINT(62+JT)) GOTO 160
24510 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
24511 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
24512 & (2D0*VINT(62+JT))
24513 PEI=SQRT(PZI**2+SQM)
24514 PQQP=(1D0-CHI)*(PEI+PZI)
24515 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
24516 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
24517 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
24518 P(N-1,3)=P(N-1,4)*(-1)**JT
24519 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
24520 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
24523 C...Documentation lines.
24525 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
24526 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
24527 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
24529 P(I+2,3)=PZ*(-1)**(JT+1)
24531 P(I+2,5)=SQRT(VINT(62+JT))
24534 C...Rotate outgoing partons/particles using cos(theta).
24535 IF(VINT(23).LT.0.9D0) THEN
24536 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
24538 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
24544 C*********************************************************************
24547 C...Set up a DIS process as gamma* + f -> f, with beam remnant
24548 C...and showering added consecutively. Photon flux by the PYGAGA
24549 C...routine (if at all).
24553 C...Double precision and integer declarations.
24554 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24555 IMPLICIT INTEGER(I-N)
24556 INTEGER PYK,PYCHGE,PYCOMP
24557 C...Parameter statement to help give large particle numbers.
24558 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24559 &KEXCIT=4000000,KDIMEN=5000000)
24561 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24562 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24563 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24564 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24565 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24566 COMMON/PYINT1/MINT(400),VINT(400)
24567 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
24571 C...Choice of subprocess, number of documentation lines
24579 IF(MINT(107).EQ.4) ISIDE=2
24581 C...Reset K, P and V vectors. Store incoming particles
24582 DO 110 JT=1,MSTP(126)+20
24595 P(I,J)=VINT(285+5*JT+J)
24600 C...Store incoming partons in hadronic CM-frame
24605 K(I,3)=MINT(83)+2+JT
24607 IF(MINT(15).EQ.22) THEN
24608 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
24609 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
24610 P(MINT(84)+1,5)=-SQRT(VINT(307))
24611 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
24612 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
24616 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
24617 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
24618 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
24619 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
24620 P(MINT(84)+1,5)=-SQRT(VINT(308))
24624 SIDESG=(-1D0)**(ISIDE-1)
24626 C...Copy incoming partons to documentation lines.
24637 C...Second copy for partons before ISR shower, since no such.
24647 C...Define initial partons.
24650 IF(NTRY.GT.100) THEN
24655 C...Scattered quark in hadronic CM frame.
24660 P(IPU3,5)=PYMASS(KFRES)
24661 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24662 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24666 K(I,3)=MINT(83)+4+ISIDE
24674 C...No primordial kT, or chosen according to truncated Gaussian or
24675 C...exponential, or (for photon) predetermined or power law.
24676 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24677 IF(MSTP(91).LE.0) THEN
24679 ELSEIF(MSTP(91).EQ.1) THEN
24680 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24684 PT=-PARP(92)*LOG(RPT1*RPT2)
24686 IF(PT.GT.PARP(93)) GOTO 190
24687 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24688 PTA=SQRT(VINT(282+ISIDE))
24690 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24691 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24692 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24695 PTB=-PARP(99)*LOG(RPT1*RPT2)
24697 IF(PTB.GT.PARP(100)) GOTO 190
24698 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24699 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24700 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24701 IF(MSTP(93).LE.0) THEN
24703 ELSEIF(MSTP(93).EQ.1) THEN
24704 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24705 ELSEIF(MSTP(93).EQ.2) THEN
24708 PT=-PARP(99)*LOG(RPT1*RPT2)
24709 ELSEIF(MSTP(93).EQ.3) THEN
24712 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24716 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24717 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24719 IF(PT.GT.PARP(100)) GOTO 190
24725 P(IPU3,1)=PT*COS(PHI)
24726 P(IPU3,2)=PT*SIN(PHI)
24727 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24728 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24729 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24731 C...Find one or two beam remnants.
24732 MINT(105)=MINT(102+ISIDE)
24733 MINT(109)=MINT(106+ISIDE)
24734 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24735 IF(MINT(51).NE.0) THEN
24740 C...Store first remnant parton, with colour info and kinematics.
24744 K(I,3)=MINT(83)+ISIDE
24745 P(I,5)=PYMASS(K(I,2))
24746 KCOL=KCHG(PYCOMP(KFLSP),2)
24749 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24750 K(I,KFLS+3)=MSTU(5)*IPU3
24751 K(IPU3,6-KFLS)=MSTU(5)*I
24754 IF(KFLCH.EQ.0) THEN
24757 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24759 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24760 PRP=P(I,4)+ABS(P(I,3))
24762 C...When extra remnant parton or hadron: store extra remnant.
24767 K(I,3)=MINT(83)+ISIDE
24768 P(I,5)=PYMASS(K(I,2))
24769 KCOL=KCHG(PYCOMP(KFLCH),2)
24772 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24773 K(I,KFLS+3)=MSTU(5)*IPU3
24774 K(IPU3,6-KFLS)=MSTU(5)*I
24778 C...Relative transverse momentum when two remnants.
24781 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24782 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24783 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24784 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24785 P(I,1)=-P(IPU3,1)-P(I-1,1)
24786 P(I,2)=-P(IPU3,2)-P(I-1,2)
24787 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24789 C...Relative distribution of energy for particle into jet plus particle.
24791 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24792 IF(MSTP(94).LE.1) THEN
24793 IF(IMB.EQ.1) CHI=PYR(0)
24794 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24795 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24796 ELSEIF(MSTP(94).EQ.2) THEN
24797 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24798 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24799 ELSEIF(MSTP(94).EQ.3) THEN
24800 CALL PYZDIS(1,0,PMS(4),ZZ)
24803 CALL PYZDIS(1000,0,PMS(4),ZZ)
24807 C...Construct total transverse mass; reject if too large.
24808 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24809 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24810 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24811 IF(LOOP.LT.10) GOTO 200
24814 VINT(158+ISIDE)=CHI
24816 C...Subdivide longitudinal momentum according to value selected above.
24817 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24819 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24820 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24822 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24823 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24827 C...Boost current and remnant systems to correct frame.
24828 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24829 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24830 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24832 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24834 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24835 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24836 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24837 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24839 C...Let current quark shower; recoil but no showering by colour partner.
24840 QMAX=2D0*SQRT(VINT(309-ISIDE))
24845 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24852 C*********************************************************************
24855 C...Handles the documentation of the process in MSTI and PARI,
24856 C...and also computes cross-sections based on accumulated statistics.
24860 C...Double precision and integer declarations.
24861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24862 IMPLICIT INTEGER(I-N)
24863 INTEGER PYK,PYCHGE,PYCOMP
24865 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24867 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24868 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24869 COMMON/PYINT1/MINT(400),VINT(400)
24870 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24871 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24872 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24875 C...Calculate Monte Carlo estimates of cross-sections.
24877 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24878 NGEN(0,3)=NGEN(0,3)+1
24881 IF(I.EQ.96.OR.I.EQ.97) THEN
24883 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24884 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24885 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24886 & DBLE(NGEN(96,2)))
24887 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24888 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24889 & DBLE(NGEN(96,2)))
24890 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24892 ELSEIF(NGEN(I,2).EQ.0) THEN
24893 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24896 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24899 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24902 C...Rescale to known low-pT cross-section for standard QCD processes.
24903 IF(MSUB(95).EQ.1) THEN
24904 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24905 & XSEC(68,3)+XSEC(95,3)
24906 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24907 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24909 XSEC(11,3)=FAC*XSEC(11,3)
24910 XSEC(12,3)=FAC*XSEC(12,3)
24911 XSEC(13,3)=FAC*XSEC(13,3)
24912 XSEC(28,3)=FAC*XSEC(28,3)
24913 XSEC(53,3)=FAC*XSEC(53,3)
24914 XSEC(68,3)=FAC*XSEC(68,3)
24915 XSEC(95,3)=FAC*XSEC(95,3)
24916 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24920 C...Save information for gamma-p and gamma-gamma.
24921 IF(MINT(121).GT.1) THEN
24927 C...Reset information on hard interaction.
24933 C...Copy integer valued information from MINT into MSTI.
24937 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24939 C...Store cross-section variables in PARI.
24941 PARI(2)=XSEC(0,3)/MINT(5)
24945 VINT(98)=VINT(98)+VINT(100)
24946 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24948 C...Store kinematics variables in PARI.
24951 IF(ISUB.NE.95) THEN
24961 PARI(35)=PARI(33)-PARI(34)
24968 PARI(42)=2D0*VINT(47)/VINT(1)
24971 C...Store information on scattered partons in PARI.
24972 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24975 PARI(36+IS)=P(I,3)/VINT(1)
24976 PARI(38+IS)=P(I,4)/VINT(1)
24977 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24978 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24979 & SQRT(PR),1D20)),P(I,3))
24980 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24981 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24982 & SQRT(PR),1D20)),P(I,3))
24983 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24984 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24985 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24989 C...Store sum up transverse and longitudinal momenta.
24990 PARI(65)=2D0*PARI(17)
24991 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24992 DO 150 I=MSTP(126)+1,N
24993 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24994 PT=SQRT(P(I,1)**2+P(I,2)**2)
24995 PARI(69)=PARI(69)+PT
24996 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24997 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
25009 C...Store various other pieces of information into PARI.
25017 C...Store information on lepton -> lepton + gamma in PYGAGA.
25020 PARI(101)=VINT(301)
25021 PARI(102)=VINT(302)
25023 PARI(I)=VINT(I+202)
25026 C...Set information for PYTABU.
25027 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
25030 ELSEIF(ISET(ISUB).EQ.5) THEN
25041 C*********************************************************************
25044 C...Performs transformations between different coordinate frames.
25046 SUBROUTINE PYFRAM(IFRAME)
25048 C...Double precision and integer declarations.
25049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25050 IMPLICIT INTEGER(I-N)
25051 INTEGER PYK,PYCHGE,PYCOMP
25053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25054 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25055 COMMON/PYINT1/MINT(400),VINT(400)
25056 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
25058 C...Check that transformation can and should be done.
25059 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
25060 &MINT(91).EQ.1)) THEN
25061 IF(IFRAME.EQ.MINT(6)) RETURN
25063 WRITE(MSTU(11),5000) IFRAME,MINT(6)
25067 IF(MINT(6).EQ.1) THEN
25068 C...Transform from fixed target or user specified frame to
25069 C...overall CM frame.
25070 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
25071 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
25072 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
25073 ELSEIF(MINT(6).EQ.3) THEN
25074 C...Transform from hadronic CM frame in DIS to overall CM frame.
25075 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
25079 IF(IFRAME.EQ.1) THEN
25080 C...Transform from overall CM frame to fixed target or user specified
25082 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
25083 ELSEIF(IFRAME.EQ.3) THEN
25084 C...Transform from overall CM frame to hadronic CM frame in DIS.
25085 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
25086 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
25087 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
25090 C...Set information about new frame.
25094 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
25095 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
25101 C*********************************************************************
25104 C...Calculates full and partial widths of resonances.
25106 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
25108 C...Double precision and integer declarations.
25109 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25110 IMPLICIT INTEGER(I-N)
25111 INTEGER PYK,PYCHGE,PYCOMP
25112 C...Parameter statement to help give large particle numbers.
25113 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25114 &KEXCIT=4000000,KDIMEN=5000000)
25116 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25117 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25118 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25119 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
25120 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25121 COMMON/PYINT1/MINT(400),VINT(400)
25122 COMMON/PYINT4/MWID(500),WIDS(500,5)
25123 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25124 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25125 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
25126 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25127 COMMON/PYPUED/IUED(0:99),RUED(0:99)
25128 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
25129 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
25130 C...Local arrays and saved variables.
25131 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
25132 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
25133 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
25134 C...UED: equivalences between ordered particles (451->475)
25135 C...and UED particle code (5 000 000 + id)
25136 PARAMETER(KKFLMI=451,KKFLMA=475)
25137 DIMENSION CHIDEL(3), IUEDPR(25)
25138 DIMENSION IUEDEQ(KKFLMA),MUED(2)
25139 COMMON/SW1/SW21,CW21
25140 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
25141 & 6100001,6100002,6100003,6100004,6100005,6100006,
25142 & 5100001,5100002,5100003,5100004,5100005,5100006,
25143 & 6100011,6100013,6100015,
25144 & 5100012,5100011,5100014,5100013,5100016,5100015,
25145 & 5100021,5100022,5100023,5100024/
25146 C...Save local variables
25147 SAVE MOFSV,WIDWSV,WID2SV
25149 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
25150 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
25152 C...UED: inline functions used in kk width calculus
25153 FKAC1(X,Y)=1.-X**2/Y**2
25154 FKAC2(X,Y)=2.+X**2/Y**2
25156 C...Compressed code and sign; mass.
25163 C...Reset width information.
25164 DO 110 I=0,MDCY(KC,3)
25171 C...Allow for fudge factor to rescale resonance width.
25173 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
25174 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
25175 IF(MSTP(110).EQ.KFLA) THEN
25177 ELSEIF(MSTP(110).EQ.-1) THEN
25178 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
25179 ELSEIF(MSTP(110).EQ.-2) THEN
25184 C...Not to be treated as a resonance: return.
25185 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
25194 C...Treatment as a resonance based on tabulated branching ratios.
25195 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
25196 C...Loop over possible decay channels; skip irrelevant ones.
25197 DO 120 I=1,MDCY(KC,3)
25199 IF(MDME(IDC,1).LT.0) GOTO 120
25201 C...Read out decay products and nominal masses.
25204 C...Skip dummy modes or unrecognized particles
25205 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
25206 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
25210 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
25216 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
25220 C...Naive partial width and alternative threshold factors.
25221 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
25222 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
25223 & PM1+PM2+PM3.GE.SHR) THEN
25225 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
25226 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
25227 & 4D0*PM1**2*PM2**2))/SH
25228 ELSEIF(MDME(IDC,2).EQ.52) THEN
25229 PMA=MAX(PM1,PM2,PM3)
25230 PMC=MIN(PM1,PM2,PM3)
25231 PMB=PM1+PM2+PM3-PMA-PMC
25232 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
25237 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
25238 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25239 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25240 & ((SHR-PMA)**2-(PMB+PMC)**2)*
25241 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
25242 & ((1D0-PMBCN)*PMBCN*SH)
25243 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
25244 WDTP(I)=WDTP(I)*SQRT(
25245 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
25246 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
25247 ELSEIF(MDME(IDC,2).EQ.53) THEN
25248 PMA=MAX(PM1,PM2,PM3)
25249 PMC=MIN(PM1,PM2,PM3)
25250 PMB=PM1+PM2+PM3-PMA-PMC
25251 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
25256 FACACT=SQRT(MAX(0D0,
25257 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25258 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25259 & ((SHR-PMA)**2-(PMB+PMC)**2)*
25260 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
25261 & ((1D0-PMBCN)*PMBCN*SH)
25262 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
25266 PMBCN=PMBC**2/PMR**2
25267 FACNOM=SQRT(MAX(0D0,
25268 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25269 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25270 & ((PMR-PMA)**2-(PMB+PMC)**2)*
25271 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
25272 & ((1D0-PMBCN)*PMBCN*PMR**2)
25273 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
25275 WDTP(I)=FUDGE*WDTP(I)
25276 WDTP(0)=WDTP(0)+WDTP(I)
25278 C...Calculate secondary width (at most two identical/opposite).
25280 IF(MDME(IDC,1).GT.0) THEN
25281 IF(KFD2.EQ.KFD1) THEN
25282 IF(KCHG(KFC1,3).EQ.0) THEN
25284 ELSEIF(KFD1.GT.0) THEN
25290 WID2=WID2*WIDS(KFC3,2)
25291 ELSEIF(KFD3.LT.0) THEN
25292 WID2=WID2*WIDS(KFC3,3)
25294 ELSEIF(KFD2.EQ.-KFD1) THEN
25297 WID2=WID2*WIDS(KFC3,2)
25298 ELSEIF(KFD3.LT.0) THEN
25299 WID2=WID2*WIDS(KFC3,3)
25301 ELSEIF(KFD3.EQ.KFD1) THEN
25302 IF(KCHG(KFC1,3).EQ.0) THEN
25304 ELSEIF(KFD1.GT.0) THEN
25310 WID2=WID2*WIDS(KFC2,2)
25311 ELSEIF(KFD2.LT.0) THEN
25312 WID2=WID2*WIDS(KFC2,3)
25314 ELSEIF(KFD3.EQ.-KFD1) THEN
25317 WID2=WID2*WIDS(KFC2,2)
25318 ELSEIF(KFD2.LT.0) THEN
25319 WID2=WID2*WIDS(KFC2,3)
25321 ELSEIF(KFD3.EQ.KFD2) THEN
25322 IF(KCHG(KFC2,3).EQ.0) THEN
25324 ELSEIF(KFD2.GT.0) THEN
25330 WID2=WID2*WIDS(KFC1,2)
25331 ELSEIF(KFD1.LT.0) THEN
25332 WID2=WID2*WIDS(KFC1,3)
25334 ELSEIF(KFD3.EQ.-KFD2) THEN
25337 WID2=WID2*WIDS(KFC1,2)
25338 ELSEIF(KFD1.LT.0) THEN
25339 WID2=WID2*WIDS(KFC1,3)
25348 WID2=WID2*WIDS(KFC2,2)
25350 WID2=WID2*WIDS(KFC2,3)
25353 WID2=WID2*WIDS(KFC3,2)
25354 ELSEIF(KFD3.LT.0) THEN
25355 WID2=WID2*WIDS(KFC3,3)
25359 C...Store effective widths according to case.
25360 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25361 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25362 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25363 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25373 C...Here begins detailed dynamical calculation of resonance widths.
25374 C...Shared treatment of Higgs states.
25377 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25382 C...Common electroweak and strong constants.
25385 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
25388 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
25390 RADC=1D0+AS/PARU(1)
25394 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25395 RADCT=1D0-2.5D0*AS/PARU(1)
25396 DO 140 I=1,MDCY(KC,3)
25398 IF(MDME(IDC,1).LT.0) GOTO 140
25399 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25400 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25401 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
25403 IF(I.GE.4.AND.I.LE.7) THEN
25404 C...t -> W + q; including approximate QCD correction factor.
25405 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
25406 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25407 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25410 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
25413 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
25415 ELSEIF(I.EQ.9) THEN
25417 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25418 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25419 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
25420 & 4D0*SQRT(RM2R*RM2))
25422 IF(KFLR.LT.0) WID2=WIDS(37,3)
25424 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
25425 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
25428 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25431 KFC1=PYCOMP(KFDP(IDC,1))
25432 KFC2=PYCOMP(KFDP(IDC,2))
25433 PMNCHI=PMAS(KFC1,1)
25434 PMSTOP=PMAS(KFC2,1)
25435 IF(SHR.GT.PMNCHI+PMSTOP) THEN
25438 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
25440 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
25441 AR=-ET*ZMIXC(IZ,1)*TANW
25442 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
25444 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
25445 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
25446 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
25447 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
25448 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
25449 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
25450 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
25452 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
25454 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
25457 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
25459 KFC1=PYCOMP(KFDP(IDC,1))
25460 KFC2=PYCOMP(KFDP(IDC,2))
25461 PMNCHI=PMAS(KFC1,1)
25462 PMSTOP=PMAS(KFC2,1)
25463 IF(SHR.GT.PMNCHI+PMSTOP) THEN
25466 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
25467 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
25468 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
25469 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
25471 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
25473 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
25476 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
25477 C...t -> ~gravitino + ~t
25479 KFC1=PYCOMP(KFDP(IDC,1))
25480 XMGR2=PMAS(KFC1,1)**2
25481 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
25482 KFC2=PYCOMP(KFDP(IDC,2))
25484 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
25487 WDTP(I)=FUDGE*WDTP(I)
25488 WDTP(0)=WDTP(0)+WDTP(I)
25489 IF(MDME(IDC,1).GT.0) THEN
25490 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25491 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25492 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25493 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25497 ELSEIF(KFLA.EQ.7) THEN
25499 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25500 DO 150 I=1,MDCY(KC,3)
25502 IF(MDME(IDC,1).LT.0) GOTO 150
25503 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25504 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25505 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
25507 IF(I.GE.4.AND.I.LE.7) THEN
25509 WDTP(I)=FAC*VCKM(I-3,4)*
25510 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25511 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25514 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
25515 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
25518 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
25519 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
25522 IF(KFLR.LT.0) WID2=WIDS(24,2)
25523 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
25525 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25526 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
25529 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
25532 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
25535 WDTP(I)=FUDGE*WDTP(I)
25536 WDTP(0)=WDTP(0)+WDTP(I)
25537 IF(MDME(IDC,1).GT.0) THEN
25538 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25539 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25540 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25541 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25545 ELSEIF(KFLA.EQ.8) THEN
25547 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25548 DO 160 I=1,MDCY(KC,3)
25550 IF(MDME(IDC,1).LT.0) GOTO 160
25551 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25552 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25553 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
25555 IF(I.GE.4.AND.I.LE.7) THEN
25557 WDTP(I)=FAC*VCKM(4,I-3)*
25558 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25559 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25562 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
25565 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
25567 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
25569 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25570 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25573 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
25576 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
25579 WDTP(I)=FUDGE*WDTP(I)
25580 WDTP(0)=WDTP(0)+WDTP(I)
25581 IF(MDME(IDC,1).GT.0) THEN
25582 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25583 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25584 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25585 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25589 ELSEIF(KFLA.EQ.17) THEN
25591 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25592 DO 170 I=1,MDCY(KC,3)
25594 IF(MDME(IDC,1).LT.0) GOTO 170
25595 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25596 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25597 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
25600 C...tau' -> W + nu'_tau.
25601 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25602 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25605 WID2=WID2*WIDS(18,2)
25608 WID2=WID2*WIDS(18,3)
25610 ELSEIF(I.EQ.5) THEN
25611 C...tau' -> H + nu'_tau.
25612 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25613 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
25616 WID2=WID2*WIDS(18,2)
25619 WID2=WID2*WIDS(18,3)
25622 WDTP(I)=FUDGE*WDTP(I)
25623 WDTP(0)=WDTP(0)+WDTP(I)
25624 IF(MDME(IDC,1).GT.0) THEN
25625 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25626 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25627 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25628 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25632 ELSEIF(KFLA.EQ.18) THEN
25633 C...nu'_tau neutrino.
25634 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25635 DO 180 I=1,MDCY(KC,3)
25637 IF(MDME(IDC,1).LT.0) GOTO 180
25638 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25639 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25640 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
25643 C...nu'_tau -> W + tau'.
25644 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25645 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25648 WID2=WID2*WIDS(17,2)
25651 WID2=WID2*WIDS(17,3)
25653 ELSEIF(I.EQ.3) THEN
25654 C...nu'_tau -> H + tau'.
25655 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25656 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25659 WID2=WID2*WIDS(17,2)
25662 WID2=WID2*WIDS(17,3)
25665 WDTP(I)=FUDGE*WDTP(I)
25666 WDTP(0)=WDTP(0)+WDTP(I)
25667 IF(MDME(IDC,1).GT.0) THEN
25668 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25669 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25670 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25671 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25675 ELSEIF(KFLA.EQ.21) THEN
25677 C***Note that widths are not given in dimensional quantities here.
25678 DO 190 I=1,MDCY(KC,3)
25680 IF(MDME(IDC,1).LT.0) GOTO 190
25681 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25682 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25683 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25686 C...QCD -> q + qbar
25687 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25688 IF(I.EQ.6) WID2=WIDS(6,1)
25689 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25691 WDTP(I)=FUDGE*WDTP(I)
25692 WDTP(0)=WDTP(0)+WDTP(I)
25693 IF(MDME(IDC,1).GT.0) THEN
25694 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25695 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25696 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25697 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25701 ELSEIF(KFLA.EQ.22) THEN
25703 C***Note that widths are not given in dimensional quantities here.
25704 DO 200 I=1,MDCY(KC,3)
25706 IF(MDME(IDC,1).LT.0) GOTO 200
25707 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25708 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25709 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25712 C...QED -> q + qbar.
25715 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25716 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25717 IF(I.EQ.6) WID2=WIDS(6,1)
25718 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25719 ELSEIF(I.LE.12) THEN
25720 C...QED -> l+ + l-.
25721 EF=KCHG(9+2*(I-8),1)/3D0
25722 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25723 IF(I.EQ.12) WID2=WIDS(17,1)
25725 WDTP(I)=FUDGE*WDTP(I)
25726 WDTP(0)=WDTP(0)+WDTP(I)
25727 IF(MDME(IDC,1).GT.0) THEN
25728 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25729 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25730 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25731 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25735 ELSEIF(KFLA.EQ.23) THEN
25738 XWC=1D0/(16D0*XW*XW1)
25739 FAC=(AEM*XWC/3D0)*SHR
25741 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25746 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25748 IF(KFI.GT.20) KFI=IABS(MINT(16))
25754 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25755 IF(MSTP(43).EQ.3) VINT(112)=
25756 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25757 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25758 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25760 DO 220 I=1,MDCY(KC,3)
25762 IF(MDME(IDC,1).LT.0) GOTO 220
25763 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25764 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25765 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25770 AF=SIGN(1D0,EF+0.1D0)
25773 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25774 IF(I.EQ.6) WID2=WIDS(6,1)
25775 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25776 ELSEIF(I.LE.16) THEN
25777 C...Z0 -> l+ + l-, nu + nubar
25779 AF=SIGN(1D0,EF+0.1D0)
25782 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25784 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25785 IF(ICASE.EQ.1) THEN
25786 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25788 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25789 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25790 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25791 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25792 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25793 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25794 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25795 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25797 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25798 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25799 IF(MDME(IDC,1).GT.0) THEN
25800 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25801 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25802 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25803 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25804 & WDTE(I,MDME(IDC,1))
25805 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25806 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25808 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25809 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25810 & VINT(111)+FGGF*WID2
25811 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25812 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25813 & VINT(114)+FZZF*WID2
25817 IF(MINT(61).GE.1) ICASE=3-ICASE
25818 IF(ICASE.EQ.2) GOTO 210
25820 ELSEIF(KFLA.EQ.24) THEN
25822 FAC=(AEM/(24D0*XW))*SHR
25823 DO 230 I=1,MDCY(KC,3)
25825 IF(MDME(IDC,1).LT.0) GOTO 230
25826 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25827 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25828 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25831 C...W+/- -> q + qbar'
25832 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25834 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25835 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25836 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25838 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25839 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25840 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25842 ELSEIF(I.LE.20) THEN
25843 C...W+/- -> l+/- + nu
25846 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25848 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25851 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25852 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25853 WDTP(I)=FUDGE*WDTP(I)
25854 WDTP(0)=WDTP(0)+WDTP(I)
25855 IF(MDME(IDC,1).GT.0) THEN
25856 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25857 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25858 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25859 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25863 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25864 C...h0 (or H0, or A0):
25866 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25867 DO 270 I=1,MDCY(KFHIGG,3)
25868 IDC=I+MDCY(KFHIGG,2)-1
25869 IF(MDME(IDC,1).LT.0) GOTO 270
25870 KFC1=PYCOMP(KFDP(IDC,1))
25871 KFC2=PYCOMP(KFDP(IDC,2))
25872 RM1=PMAS(KFC1,1)**2/SH
25873 RM2=PMAS(KFC2,1)**2/SH
25874 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25880 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25881 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25882 C...A0 behaves like beta, ho and H0 like beta**3.
25883 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25884 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25885 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25886 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25887 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25888 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25889 IF(IHIGG.NE.3) THEN
25890 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25891 & PARU(151+10*IHIGG))**2
25895 IF(I.EQ.6) WID2=WIDS(6,1)
25896 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25897 ELSEIF(I.LE.12) THEN
25899 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25900 C...A0 behaves like beta, ho and H0 like beta**3.
25901 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25902 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25903 & PARU(153+10*IHIGG)**2
25904 IF(I.EQ.12) WID2=WIDS(17,1)
25906 ELSEIF(I.EQ.13) THEN
25907 C...h0 -> g + g; quark loop contribution only
25910 DO 240 J=1,2*MSTP(1)
25911 EPS=(2D0*PMAS(J,1))**2/SH
25912 C...Loop integral; function of eps=4m^2/shat; different for A0.
25913 IF(EPS.LE.1D0) THEN
25914 IF(EPS.GT.1D-4) THEN
25916 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25918 RLN=LOG(4D0/EPS-2D0)
25920 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25921 PHIIM=0.5D0*PARU(1)*RLN
25923 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25926 IF(IHIGG.LE.2) THEN
25927 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25928 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25930 ETAREJ=-0.5D0*EPS*PHIRE
25931 ETAIMJ=-0.5D0*EPS*PHIIM
25933 C...Couplings (=1 for standard model Higgs).
25934 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25935 IF(MOD(J,2).EQ.1) THEN
25936 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25937 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25939 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25940 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25946 ETA2=ETARE**2+ETAIM**2
25947 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25949 ELSEIF(I.EQ.14) THEN
25950 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25954 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25956 IF(J.LE.2*MSTP(1)) THEN
25958 EPS=(2D0*PMAS(J,1))**2/SH
25959 ELSEIF(J.LE.3*MSTP(1)) THEN
25960 JL=2*(J-2*MSTP(1))-1
25961 EJ=KCHG(10+JL,1)/3D0
25962 EPS=(2D0*PMAS(10+JL,1))**2/SH
25963 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25964 EPS=(2D0*PMAS(24,1))**2/SH
25966 EPS=(2D0*PMAS(37,1))**2/SH
25968 C...Loop integral; function of eps=4m^2/shat.
25969 IF(EPS.LE.1D0) THEN
25970 IF(EPS.GT.1D-4) THEN
25972 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25974 RLN=LOG(4D0/EPS-2D0)
25976 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25977 PHIIM=0.5D0*PARU(1)*RLN
25979 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25982 IF(J.LE.3*MSTP(1)) THEN
25983 C...Fermion loops: loop integral different for A0; charges.
25984 IF(IHIGG.LE.2) THEN
25985 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25986 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25988 PHIPRE=-0.5D0*EPS*PHIRE
25989 PHIPIM=-0.5D0*EPS*PHIIM
25991 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25993 EJH=PARU(151+10*IHIGG)
25994 ELSEIF(J.LE.2*MSTP(1)) THEN
25996 EJH=PARU(152+10*IHIGG)
25999 EJH=PARU(153+10*IHIGG)
26001 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
26002 ETAREJ=EJC*EJH*PHIPRE
26003 ETAIMJ=EJC*EJH*PHIPIM
26004 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
26005 C...W loops: loop integral and charges.
26006 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
26007 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
26008 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
26009 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
26010 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
26013 C...Charged H loops: loop integral and charges.
26014 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
26015 & PARU(158+10*IHIGG+2*(IHIGG/3))
26016 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
26017 ETAIMJ=-EPS**2*PHIIM*FACHHH
26022 ETA2=ETARE**2+ETAIM**2
26023 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
26025 ELSEIF(I.EQ.15) THEN
26026 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
26030 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
26032 IF(J.LE.2*MSTP(1)) THEN
26034 AJ=SIGN(1D0,EJ+0.1D0)
26036 EPS=(2D0*PMAS(J,1))**2/SH
26037 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
26038 ELSEIF(J.LE.3*MSTP(1)) THEN
26039 JL=2*(J-2*MSTP(1))-1
26040 EJ=KCHG(10+JL,1)/3D0
26041 AJ=SIGN(1D0,EJ+0.1D0)
26043 EPS=(2D0*PMAS(10+JL,1))**2/SH
26044 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
26046 EPS=(2D0*PMAS(24,1))**2/SH
26047 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
26049 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
26050 IF(EPS.LE.1D0) THEN
26052 IF(EPS.GT.1D-4) THEN
26053 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
26055 RLN=LOG(4D0/EPS-2D0)
26057 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
26058 PHIIM=0.5D0*PARU(1)*RLN
26059 PSIRE=0.5D0*ROOT*RLN
26060 PSIIM=-0.5D0*ROOT*PARU(1)
26062 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
26064 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
26067 IF(EPSP.LE.1D0) THEN
26068 ROOT=SQRT(1D0-EPSP)
26069 IF(EPSP.GT.1D-4) THEN
26070 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
26072 RLN=LOG(4D0/EPSP-2D0)
26074 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
26075 PHIIMP=0.5D0*PARU(1)*RLN
26076 PSIREP=0.5D0*ROOT*RLN
26077 PSIIMP=-0.5D0*ROOT*PARU(1)
26079 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
26081 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
26084 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
26085 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
26086 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
26087 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
26088 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
26089 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
26090 IF(J.LE.3*MSTP(1)) THEN
26091 C...Fermion loops: loop integral different for A0; charges.
26092 IF(IHIGG.EQ.3) FXYRE=0D0
26093 IF(IHIGG.EQ.3) FXYIM=0D0
26094 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
26096 EJH=PARU(151+10*IHIGG)
26097 ELSEIF(J.LE.2*MSTP(1)) THEN
26099 EJH=PARU(152+10*IHIGG)
26102 EJH=PARU(153+10*IHIGG)
26104 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
26105 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
26106 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
26107 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
26108 C...W loops: loop integral and charges.
26109 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
26110 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
26111 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
26112 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
26113 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
26114 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
26117 C...Charged H loops: loop integral and charges.
26118 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
26119 & PARU(158+10*IHIGG+2*(IHIGG/3))
26120 ETAREJ=FACHHH*FXYRE
26121 ETAIMJ=FACHHH*FXYIM
26126 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
26127 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
26130 ELSEIF(I.LE.17) THEN
26131 C...h0 -> Z0 + Z0, W+ + W-
26132 PM1=PMAS(IABS(KFDP(IDC,1)),1)
26133 PG1=PMAS(IABS(KFDP(IDC,1)),2)
26134 IF(MINT(62).GE.1) THEN
26135 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
26136 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
26137 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
26138 MOFSV(IHIGG,I-15)=0
26139 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
26143 MOFSV(IHIGG,I-15)=1
26144 RMAS=SQRT(MAX(0D0,SH))
26145 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
26147 WIDWSV(IHIGG,I-15)=WIDW
26148 WID2SV(IHIGG,I-15)=WID2
26151 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
26152 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
26156 WIDW=WIDWSV(IHIGG,I-15)
26157 WID2=WID2SV(IHIGG,I-15)
26160 WDTP(I)=FAC*WIDW/(2D0*(18-I))
26161 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
26162 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
26163 & PARU(138+I+10*IHIGG)**2
26164 WID2=WID2*WIDS(7+I,1)
26166 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
26167 C...H0 -> Z0 + h0, A0-> Z0 + h0
26168 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
26169 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26170 IF(IHIGG.EQ.2) THEN
26171 WDTP(I)=WDTP(I)*PARU(179)**2
26172 ELSEIF(IHIGG.EQ.3) THEN
26173 WDTP(I)=WDTP(I)*PARU(186)**2
26175 WID2=WIDS(23,2)*WIDS(25,2)
26177 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
26178 C...H0 -> h0 + h0, A0-> h0 + h0
26179 WDTP(I)=FAC*0.25D0*
26180 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26181 IF(IHIGG.EQ.2) THEN
26182 WDTP(I)=WDTP(I)*PARU(176)**2
26183 ELSEIF(IHIGG.EQ.3) THEN
26184 WDTP(I)=WDTP(I)*PARU(169)**2
26187 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
26188 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
26189 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
26190 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26191 & *PARU(195+IHIGG)**2
26193 WID2=WIDS(24,2)*WIDS(37,3)
26194 ELSEIF(I.EQ.21) THEN
26195 WID2=WIDS(24,3)*WIDS(37,2)
26198 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
26200 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
26201 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26202 WID2=WIDS(36,2)*WIDS(23,2)
26204 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
26206 WDTP(I)=FAC*0.5D0*PARU(180)**2*
26207 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26208 WID2=WIDS(25,2)*WIDS(36,2)
26210 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
26212 WDTP(I)=FAC*0.25D0*PARU(177)**2*
26213 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26218 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26221 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
26222 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
26223 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
26228 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
26230 IF(KFC2.EQ.KFC1) THEN
26234 IF(KFDP(IDC,1).LT.0) KSGN1=3
26236 IF(KFDP(IDC,2).LT.0) KSGN2=3
26237 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
26240 WDTP(I)=FUDGE*WDTP(I)
26241 WDTP(0)=WDTP(0)+WDTP(I)
26242 IF(MDME(IDC,1).GT.0) THEN
26243 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26244 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26245 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26246 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26250 ELSEIF(KFLA.EQ.32) THEN
26253 XWC=1D0/(16D0*XW*XW1)
26254 FAC=(AEM*XWC/3D0)*SHR
26257 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
26265 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26266 KFAI=IABS(MINT(15))
26267 EI=KCHG(KFAI,1)/3D0
26268 AI=SIGN(1D0,EI+0.1D0)
26271 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
26272 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
26273 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
26274 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
26275 VPI=PARU(119+2*KFAIC)
26276 API=PARU(120+2*KFAIC)
26277 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
26278 VPI=PARJ(178+2*KFAIC)
26279 API=PARJ(179+2*KFAIC)
26281 VPI=PARJ(186+2*KFAIC)
26282 API=PARJ(187+2*KFAIC)
26286 SQMZP=PMAS(32,1)**2
26288 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
26289 & MSTP(44).EQ.7) VINT(111)=1D0
26290 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
26291 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
26292 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
26293 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
26294 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
26295 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
26296 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
26297 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
26298 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
26299 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
26300 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
26302 DO 290 I=1,MDCY(KC,3)
26304 IF(MDME(IDC,1).LT.0) GOTO 290
26305 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26306 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26307 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
26311 C...Z'0 -> q + qbar
26313 AF=SIGN(1D0,EF+0.1D0)
26316 VPF=PARU(123-2*MOD(I,2))
26317 APF=PARU(124-2*MOD(I,2))
26318 ELSEIF(I.LE.4) THEN
26319 VPF=PARJ(182-2*MOD(I,2))
26320 APF=PARJ(183-2*MOD(I,2))
26322 VPF=PARJ(190-2*MOD(I,2))
26323 APF=PARJ(191-2*MOD(I,2))
26326 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26327 & PYHFTH(SH,SH*RM1,1D0)
26328 IF(I.EQ.6) WID2=WIDS(6,1)
26329 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
26330 ELSEIF(I.LE.16) THEN
26331 C...Z'0 -> l+ + l-, nu + nubar
26333 AF=SIGN(1D0,EF+0.1D0)
26336 VPF=PARU(127-2*MOD(I,2))
26337 APF=PARU(128-2*MOD(I,2))
26338 ELSEIF(I.LE.12) THEN
26339 VPF=PARJ(186-2*MOD(I,2))
26340 APF=PARJ(187-2*MOD(I,2))
26342 VPF=PARJ(194-2*MOD(I,2))
26343 APF=PARJ(195-2*MOD(I,2))
26346 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
26348 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
26349 IF(ICASE.EQ.1) THEN
26350 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
26351 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
26352 & APF**2*(1D0-4D0*RM1))*BE34
26353 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26354 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
26355 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
26356 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
26357 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
26358 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
26359 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
26360 ELSEIF(MINT(61).EQ.2) THEN
26361 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
26362 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
26363 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
26364 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
26365 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
26367 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
26370 ELSEIF(I.EQ.17) THEN
26372 WDTPZP=PARU(129)**2*XW1**2*
26373 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26374 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
26375 IF(ICASE.EQ.1) THEN
26378 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26379 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
26380 ELSEIF(MINT(61).EQ.2) THEN
26389 ELSEIF(I.EQ.18) THEN
26391 CZC=2D0*(1D0-2D0*XW)
26392 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
26393 IF(ICASE.EQ.1) THEN
26394 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
26395 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
26396 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26397 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
26398 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
26399 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
26400 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
26401 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
26402 ELSEIF(MINT(61).EQ.2) THEN
26404 FGZF=0.25D0*PARU(142)*CZC*BE34C
26405 FGZPF=0.25D0*PARU(143)*CZC*BE34C
26406 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
26407 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
26408 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
26411 ELSEIF(I.EQ.19) THEN
26412 C...Z'0 -> Z0 + gamma.
26413 ELSEIF(I.EQ.20) THEN
26415 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26416 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
26417 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
26418 IF(ICASE.EQ.1) THEN
26421 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26422 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
26423 ELSEIF(MINT(61).EQ.2) THEN
26431 WID2=WIDS(23,2)*WIDS(25,2)
26432 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
26433 C...Z' -> h0 + A0 or H0 + A0.
26434 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26442 IF(ICASE.EQ.1) THEN
26443 WDTPZ=CZAH**2*BE34C
26444 WDTP(I)=FAC*CZPAH**2*BE34C
26445 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26446 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
26447 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
26449 ELSEIF(MINT(61).EQ.2) THEN
26454 FZZPF=CZAH*CZPAH*BE34C
26455 FZPZPF=CZPAH**2*BE34C
26457 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
26458 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
26460 IF(ICASE.EQ.1) THEN
26461 VINT(117)=VINT(117)+FAC*WDTPZ
26462 WDTP(I)=FUDGE*WDTP(I)
26463 WDTP(0)=WDTP(0)+WDTP(I)
26465 IF(MDME(IDC,1).GT.0) THEN
26466 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
26467 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
26468 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26469 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
26470 & WDTE(I,MDME(IDC,1))
26471 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26472 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26474 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
26475 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
26476 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
26477 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
26479 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
26481 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
26482 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
26483 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
26485 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
26486 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
26490 IF(MINT(61).GE.1) ICASE=3-ICASE
26491 IF(ICASE.EQ.2) GOTO 280
26493 ELSEIF(KFLA.EQ.34) THEN
26495 FAC=(AEM/(24D0*XW))*SHR
26496 DO 300 I=1,MDCY(KC,3)
26498 IF(MDME(IDC,1).LT.0) GOTO 300
26499 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26500 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26501 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
26505 C...W'+/- -> q + qbar'
26506 CKMFAC = VCKM((I-1)/4+1,MOD(I-1,4)+1)
26507 FCOF=3D0*CKMFAC*RADC*(PARU(131)**2+PARU(132)**2)
26508 FCOF2=3D0*CKMFAC*RADC*(PARU(131)**2-PARU(132)**2)
26510 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
26511 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
26512 IF(I.GE.13) WID2=WID2*WIDS(7,3)
26514 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
26515 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
26516 IF(I.GE.13) WID2=WID2*WIDS(7,2)
26518 ELSEIF(I.LE.20) THEN
26519 C...W'+/- -> l+/- + nu
26520 FCOF=PARU(133)**2+PARU(134)**2
26521 FCOF2=PARU(133)**2-PARU(134)**2
26523 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26525 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26528 WDTP(I)=FAC*0.5*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)
26529 & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26530 IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN
26532 C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov
26533 WDTP(I)=WDTP(I) + FAC*0.5*6D0*FCOF2*SQRT(RM1*RM2)
26534 & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26536 ELSEIF(I.EQ.21) THEN
26537 C...W'+/- -> W+/- + Z0
26538 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
26539 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26540 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
26541 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
26542 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
26543 ELSEIF(I.EQ.23) THEN
26544 C...W'+/- -> W+/- + h0
26545 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26546 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
26547 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
26548 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
26550 WDTP(I)=FUDGE*WDTP(I)
26551 WDTP(0)=WDTP(0)+WDTP(I)
26552 IF(MDME(IDC,1).GT.0) THEN
26553 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26554 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26555 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26556 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26560 ELSEIF(KFLA.EQ.37) THEN
26562 C IF(MSTP(49).EQ.0) THEN
26565 C SHFS=PMAS(37,1)**2
26567 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
26568 DO 310 I=1,MDCY(KC,3)
26570 IF(MDME(IDC,1).LT.0) GOTO 310
26571 KFC1=PYCOMP(KFDP(IDC,1))
26572 KFC2=PYCOMP(KFDP(IDC,2))
26573 RM1=PMAS(KFC1,1)**2/SH
26574 RM2=PMAS(KFC2,1)**2/SH
26575 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
26578 C...H+/- -> q + qbar'
26579 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
26580 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
26581 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
26582 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
26583 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
26585 IF(I.EQ.3) WID2=WIDS(6,2)
26586 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
26588 IF(I.EQ.3) WID2=WIDS(6,3)
26589 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
26591 ELSEIF(I.LE.8) THEN
26592 C...H+/- -> l+/- + nu
26593 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
26594 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
26595 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
26597 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
26599 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
26601 ELSEIF(I.EQ.9) THEN
26602 C...H+/- -> W+/- + h0.
26603 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
26604 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26605 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
26606 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
26610 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26613 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
26614 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
26615 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
26620 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
26623 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
26625 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
26626 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
26628 WDTP(I)=FUDGE*WDTP(I)
26629 WDTP(0)=WDTP(0)+WDTP(I)
26630 IF(MDME(IDC,1).GT.0) THEN
26631 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26632 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26633 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26634 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26638 ELSEIF(KFLA.EQ.41) THEN
26640 FAC=(AEM/(12D0*XW))*SHR
26641 DO 320 I=1,MDCY(KC,3)
26643 IF(MDME(IDC,1).LT.0) GOTO 320
26644 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26645 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26646 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
26651 ELSEIF(I.LE.9) THEN
26655 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26656 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26658 IF(I.EQ.4) WID2=WIDS(6,3)
26659 IF(I.EQ.5) WID2=WIDS(7,3)
26660 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26661 IF(I.EQ.9) WID2=WIDS(17,3)
26663 IF(I.EQ.4) WID2=WIDS(6,2)
26664 IF(I.EQ.5) WID2=WIDS(7,2)
26665 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26666 IF(I.EQ.9) WID2=WIDS(17,2)
26668 WDTP(I)=FUDGE*WDTP(I)
26669 WDTP(0)=WDTP(0)+WDTP(I)
26670 IF(MDME(IDC,1).GT.0) THEN
26671 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26672 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26673 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26674 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26678 ELSEIF(KFLA.EQ.42) THEN
26679 C...LQ (leptoquark).
26680 FAC=(AEM/4D0)*PARU(151)*SHR
26681 DO 330 I=1,MDCY(KC,3)
26683 IF(MDME(IDC,1).LT.0) GOTO 330
26684 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26685 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26686 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26687 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26689 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26690 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26691 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26692 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26693 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26694 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26695 WDTP(I)=FUDGE*WDTP(I)
26696 WDTP(0)=WDTP(0)+WDTP(I)
26697 IF(MDME(IDC,1).GT.0) THEN
26698 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26699 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26700 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26701 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26705 C...UED: kk state width decays : flav: 451 476
26706 ELSEIF(IUED(1).EQ.1.AND.
26707 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26708 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26710 C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26711 RMFLAS=PMAS(KCLA,1)
26712 FACSH=SH/PMAS(KCLA,1)**2
26713 ALPHEM=PYALEM(RMFLAS**2)
26714 ALPHS=PYALPS(RMFLAS**2)
26716 C...uedcor parameters (alpha_s is calculated at mkk scale)
26717 C...alpha_em is calculated at z pole !
26721 DO 1070 I=1,MDCY(KCLA,3)
26722 IDC=I+MDCY(KCLA,2)-1
26724 IF(MDME(IDC,1).LT.0) GOTO 1070
26725 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26726 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26727 RM1=PMAS(KFC1,1)**2/SH
26728 RM2=PMAS(KFC2,1)**2/SH
26729 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26733 C...N.B. RINV=RUED(1)
26739 KKCLA=KCLA-KKFLMI+1
26740 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26741 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26742 IF(KKCLA.LE.6) THEN
26743 C...q*_S -> q + gamma* (in first time sw21=0)
26744 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26745 C...Eventually change the following by enabling a choice of open or closed.
26746 C...Only the gamma_kk channel is open.
26748 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26749 WDTP(I)=FACSH*WDTP(I)
26751 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26752 C...q*_D -> q + Z*/W*
26753 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26754 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26764 WDTP(I)=FACSH*WDTP(I)
26765 C...q*_D -> q + gamma* is closed
26766 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26767 C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26768 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26770 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26771 + FKAC1(RMGAKK,RMFLAS)**2
26772 WDTP(I)=FACSH*WDTP(I)
26774 ELSEIF(KKCLA.EQ.22)THEN
26775 RMQST=PMAS(KKPART,1)
26776 WID2=WIDS(KKPART,2)
26777 C...g* -> q*_S/q*_D + q
26778 FAC=10.*ALPHS/12.*RMFLAS
26779 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26780 WDTP(I)=FACSH*WDTP(I)
26781 ELSEIF(KKCLA.EQ.23)THEN
26782 C...gamma* decays to graviton + gamma : initial value is used
26784 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26786 ELSEIF(KKCLA.EQ.24)THEN
26787 C...Z* -> l*_S + l is closed
26788 C... Z* -> l*_D + l
26789 IF(I.LE.3)GOTO 1070
26790 c... After closing the channels for a Z* decaying into positively charged
26791 C... KK lepton singlets, close the channels for a Z* decaying into negatively
26792 C... charged KK lepton singlets + positively charged SM particles
26793 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26794 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26795 RMLST=PMAS(KKPART,1)
26796 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26797 WDTP(I)=FACSH*WDTP(I)
26798 WID2=WIDS(KKPART,2)
26799 ELSEIF(KKCLA.EQ.25)THEN
26800 C...W* -> l*_D lbar
26801 FAC=3.*ALPHEM/12./SW2*RMWKK
26802 RMLST=PMAS(KKPART,1)
26803 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26804 WDTP(I)=FACSH*WDTP(I)
26805 WID2=WIDS(KKPART,2)
26807 WDTP(0)=WDTP(0)+WDTP(I)
26808 IF(MDME(IDC,1).GT.0) THEN
26809 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26810 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26811 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26812 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26817 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26818 C...Techni-pi0 and techni-pi0':
26819 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26820 DO 340 I=1,MDCY(KC,3)
26822 IF(MDME(IDC,1).LT.0) GOTO 340
26823 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26824 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26827 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26831 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26832 & /(8D0*PARU(1))*SH*SHR
26833 IF(KFLA.EQ.KTECHN+111) THEN
26840 C...pi_tc -> f + fbar.
26842 IKA=IABS(KFDP(IDC,1))
26843 IF(IKA.LT.10) FCOF=3D0*RADC
26846 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26847 FCOF=FCOF*RTCM(1+IKA)**2
26848 HM1=PYMRUN(KFDP(IDC,1),SH)
26849 HM2=PYMRUN(KFDP(IDC,2),SH)
26850 ELSEIF(IKA.EQ.15) THEN
26851 FCOF=FCOF*RTCM(8)**2
26853 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26854 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26856 WDTP(I)=FUDGE*WDTP(I)
26857 WDTP(0)=WDTP(0)+WDTP(I)
26858 IF(MDME(IDC,1).GT.0) THEN
26859 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26860 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26861 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26862 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26866 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26868 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26869 DO 350 I=1,MDCY(KC,3)
26871 IF(MDME(IDC,1).LT.0) GOTO 350
26872 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26873 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26875 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26879 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26881 C...pi_tc -> f + f'.
26883 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26884 C...pi_tc+ -> W b b~
26885 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26887 XMT2=PMAS(6,1)**2/SH
26888 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26889 KFC3=PYCOMP(KFDP(IDC,3))
26890 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26892 T0 = (1D0-CHECK**2)*
26893 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26894 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26895 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26896 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26897 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26898 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26907 IKA=IABS(KFDP(IDC,1))
26908 IF(IKA.LT.10) FCOF=3D0*RADC
26911 IF(I.GE.1.AND.I.LE.5) THEN
26913 FCOF=FCOF*RTCM(5)**2
26914 ELSEIF(I.LE.4) THEN
26915 FCOF=FCOF*RTCM(6)**2
26916 ELSEIF(I.EQ.5) THEN
26917 FCOF=FCOF*RTCM(7)**2
26919 HM1=PYMRUN(KFDP(IDC,1),SH)
26920 HM2=PYMRUN(KFDP(IDC,2),SH)
26921 ELSEIF(I.EQ.8) THEN
26922 FCOF=FCOF*RTCM(8)**2
26924 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26925 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26927 WDTP(I)=FUDGE*WDTP(I)
26928 WDTP(0)=WDTP(0)+WDTP(I)
26929 IF(MDME(IDC,1).GT.0) THEN
26930 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26931 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26932 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26933 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26937 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26939 FAC=(SH/PARP(46)**2)*SHR
26940 DO 360 I=1,MDCY(KC,3)
26942 IF(MDME(IDC,1).LT.0) GOTO 360
26943 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26944 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26945 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26948 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26949 IF(I.EQ.2) WID2=WIDS(6,1)
26951 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26953 WDTP(I)=FUDGE*WDTP(I)
26954 WDTP(0)=WDTP(0)+WDTP(I)
26955 IF(MDME(IDC,1).GT.0) THEN
26956 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26957 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26958 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26959 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26963 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26965 ALPRHT=2.16D0*(3D0/ITCM(1))
26966 FAC=(ALPRHT/12D0)*SHR
26967 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26971 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26973 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26974 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26975 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26976 DO 370 I=1,MDCY(KC,3)
26978 IF(MDME(IDC,1).LT.0) GOTO 370
26979 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26980 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26981 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26984 C...rho_tc0 -> W+ + W-.
26985 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26986 WDTP(I)=FAC*RTCM(3)**4*
26987 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26988 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26989 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26990 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26992 ELSEIF(I.EQ.2) THEN
26993 C...rho_tc0 -> W+ + pi_tc-.
26994 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26995 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26996 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26997 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26998 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26999 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27000 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27001 ELSEIF(I.EQ.3) THEN
27002 C...rho_tc0 -> pi_tc+ + W-.
27003 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27004 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27005 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27006 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
27007 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27008 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
27009 ELSEIF(I.EQ.4) THEN
27010 C...rho_tc0 -> pi_tc+ + pi_tc-.
27011 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
27012 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27013 WID2=WIDS(PYCOMP(KTECHN+211),1)
27014 ELSEIF(I.EQ.5) THEN
27015 C...rho_tc0 -> gamma + pi_tc0
27016 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27017 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27019 WID2=WIDS(PYCOMP(KTECHN+111),2)
27020 ELSEIF(I.EQ.6) THEN
27021 C...rho_tc0 -> gamma + pi_tc0'
27022 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27023 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
27024 WID2=WIDS(PYCOMP(KTECHN+221),2)
27025 ELSEIF(I.EQ.7) THEN
27026 C...rho_tc0 -> Z0 + pi_tc0
27027 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27028 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27030 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
27031 ELSEIF(I.EQ.8) THEN
27032 C...rho_tc0 -> Z0 + pi_tc0'
27033 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27034 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
27036 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27037 ELSEIF(I.EQ.9) THEN
27038 C...rho_tc0 -> gamma + Z0
27039 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27040 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27042 ELSEIF(I.EQ.10) THEN
27043 C...rho_tc0 -> Z0 + Z0
27044 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27045 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
27049 C...rho_tc0 -> f + fbar.
27054 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27058 IF(IA.GE.17) WID2=WIDS(IA,1)
27061 AI=SIGN(1D0,EI+0.1D0)
27065 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27066 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
27067 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27068 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
27070 WDTP(I)=FUDGE*WDTP(I)
27071 WDTP(0)=WDTP(0)+WDTP(I)
27072 IF(MDME(IDC,1).GT.0) THEN
27073 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27074 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27075 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27076 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27080 ELSEIF(KFLA.EQ.KTECHN+213) THEN
27082 ALPRHT=2.16D0*(3D0/ITCM(1))
27083 FAC=(ALPRHT/12D0)*SHR
27087 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27089 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27090 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27091 DO 380 I=1,MDCY(KC,3)
27093 IF(MDME(IDC,1).LT.0) GOTO 380
27094 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27095 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27096 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
27098 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27099 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27102 C...rho_tc+ -> W+ + Z0.
27104 WDTP(I)=FAC*RTCM(3)**4*
27105 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27106 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
27107 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
27109 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
27112 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
27114 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27117 WID2=WIDS(24,2)*WIDS(23,2)
27119 WID2=WIDS(24,3)*WIDS(23,2)
27121 ELSEIF(I.EQ.2) THEN
27122 C...rho_tc+ -> W+ + pi_tc0.
27123 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27124 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27125 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27126 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
27127 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27129 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
27131 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
27133 ELSEIF(I.EQ.3) THEN
27134 C...rho_tc+ -> pi_tc+ + Z0.
27135 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27136 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27137 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27138 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
27139 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
27140 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27141 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27144 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
27146 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
27148 ELSEIF(I.EQ.4) THEN
27149 C...rho_tc+ -> pi_tc+ + pi_tc0.
27150 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
27151 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27153 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
27155 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
27157 ELSEIF(I.EQ.5) THEN
27158 C...rho_tc+ -> pi_tc+ + gamma
27159 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27160 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27163 WID2=WIDS(PYCOMP(KTECHN+211),2)
27165 WID2=WIDS(PYCOMP(KTECHN+211),3)
27167 ELSEIF(I.EQ.6) THEN
27168 C...rho_tc+ -> W+ + pi_tc0'
27169 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27170 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
27172 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
27174 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
27176 ELSEIF(I.EQ.7) THEN
27177 C...rho_tc+ -> W+ + gamma
27178 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27179 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27186 C...rho_tc+ -> f + fbar'.
27190 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27192 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27193 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27194 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27196 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27197 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27198 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27203 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27205 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27208 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27209 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27211 WDTP(I)=FUDGE*WDTP(I)
27212 WDTP(0)=WDTP(0)+WDTP(I)
27213 IF(MDME(IDC,1).GT.0) THEN
27214 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27215 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27216 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27217 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27221 ELSEIF(KFLA.EQ.KTECHN+223) THEN
27223 ALPRHT=2.16D0*(3D0/ITCM(1))
27224 FAC=(ALPRHT/12D0)*SHR
27225 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
27228 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27230 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27231 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27232 DO 390 I=1,MDCY(KC,3)
27234 IF(MDME(IDC,1).LT.0) GOTO 390
27235 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27236 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27237 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
27240 C...omega_tc0 -> gamma + pi_tc0.
27241 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
27242 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
27243 WID2=WIDS(PYCOMP(KTECHN+111),2)
27244 ELSEIF(I.EQ.2) THEN
27245 C...omega_tc0 -> Z0 + pi_tc0
27246 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27247 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
27249 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
27250 ELSEIF(I.EQ.3) THEN
27251 C...omega_tc0 -> gamma + pi_tc0'
27252 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27253 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
27255 WID2=WIDS(PYCOMP(KTECHN+221),2)
27256 ELSEIF(I.EQ.4) THEN
27257 C...omega_tc0 -> Z0 + pi_tc0'
27258 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27259 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
27261 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27262 ELSEIF(I.EQ.5) THEN
27263 C...omega_tc0 -> W+ + pi_tc-
27264 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27265 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
27266 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
27267 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27268 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27269 ELSEIF(I.EQ.6) THEN
27270 C...omega_tc0 -> pi_tc+ + W-
27271 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27272 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
27273 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
27274 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27275 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27276 ELSEIF(I.EQ.7) THEN
27277 C...omega_tc0 -> W+ + W-.
27278 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
27279 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
27280 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27281 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27282 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
27284 ELSEIF(I.EQ.8) THEN
27285 C...omega_tc0 -> pi_tc+ + pi_tc-.
27286 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
27287 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27288 WID2=WIDS(PYCOMP(KTECHN+211),1)
27289 C...omega_tc0 -> gamma + Z0
27290 ELSEIF(I.EQ.9) THEN
27291 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27292 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27294 C...omega_tc0 -> Z0 + Z0
27295 ELSEIF(I.EQ.10) THEN
27296 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27297 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
27298 & /24D0/RTCM(12)**2*SHR**3
27301 C...omega_tc0 -> f + fbar.
27306 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27310 IF(IA.GE.17) WID2=WIDS(IA,1)
27313 AI=SIGN(1D0,EI+0.1D0)
27315 VALI=-0.5D0*(VI+AI)
27316 VARI=-0.5D0*(VI-AI)
27317 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27318 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
27319 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27320 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
27322 WDTP(I)=FUDGE*WDTP(I)
27323 WDTP(0)=WDTP(0)+WDTP(I)
27324 IF(MDME(IDC,1).GT.0) THEN
27325 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27326 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27327 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27328 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27332 C.....V8 -> quark anti-quark
27333 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
27336 IF(ITCM(2).EQ.0) THEN
27338 ELSEIF(ITCM(2).EQ.1) THEN
27341 DO 400 I=1,MDCY(KC,3)
27343 IF(MDME(IDC,1).LT.0) GOTO 400
27344 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27346 IF(RM1.GT.0.25D0) GOTO 400
27348 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
27353 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
27354 IF(I.EQ.6) WID2=WIDS(6,1)
27355 WDTP(I)=FUDGE*WDTP(I)
27356 WDTP(0)=WDTP(0)+WDTP(I)
27357 IF(MDME(IDC,1).GT.0) THEN
27358 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27359 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27360 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27361 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27365 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
27366 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
27368 DO 410 I=1,MDCY(KC,3)
27370 IF(MDME(IDC,1).LT.0) GOTO 410
27371 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27372 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27373 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
27377 IF(KFLA.EQ.KTECHN+100111) THEN
27382 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
27383 & /(2D0*PARU(1))*SH*SHR*CLEBG
27386 C...pi_tc -> f + fbar.
27387 IF(I.EQ.6) WID2=WIDS(6,1)
27389 IKA=IABS(KFDP(IDC,1))
27390 IF(IKA.LT.10) FCOF=3D0*RADC
27391 HM1=PYMRUN(KFDP(IDC,1),SH)
27392 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
27393 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27395 WDTP(I)=FUDGE*WDTP(I)
27396 WDTP(0)=WDTP(0)+WDTP(I)
27397 IF(MDME(IDC,1).GT.0) THEN
27398 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27399 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27400 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27401 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27405 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
27407 ALPRHT=2.16D0*(3D0/ITCM(1))
27409 SIN2T=2D0*TANT3/(TANT3**2+1D0)
27410 SINT3=TANT3/SQRT(TANT3**2+1D0)
27413 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
27414 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
27415 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
27416 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
27417 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
27419 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
27421 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
27423 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
27425 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
27426 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
27427 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
27428 IF(ITCM(2).EQ.0) THEN
27433 DO 420 I=1,MDCY(KC,3)
27434 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
27435 & KFLA.EQ.KTECHN+300113)) GOTO 420
27437 IF(MDME(IDC,1).LT.0) GOTO 420
27438 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27439 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27440 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
27443 IF(I.EQ.6) WID2=WIDS(6,1)
27445 IF(KFLA.EQ.KTECHN+200113) THEN
27448 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
27451 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
27456 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
27457 FMIX=1D0/TANT3/SIN2T
27461 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
27462 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
27463 ELSEIF(I.EQ.7) THEN
27464 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
27465 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
27466 PSH=SHR*(1D0-RM1)/2D0
27467 WDTP(I)=AS/9D0*PSH**3/RM82
27469 WDTP(I)=2D0*WDTP(I)*CSXPP**2
27470 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
27472 WDTP(I)=5D0*WDTP(I)
27473 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
27476 WDTP(I)=FUDGE*WDTP(I)
27477 WDTP(0)=WDTP(0)+WDTP(I)
27478 IF(MDME(IDC,1).GT.0) THEN
27479 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27480 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27481 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27482 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27486 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
27487 C...d* excited quark.
27488 FAC=(SH/RTCM(41)**2)*SHR
27489 DO 430 I=1,MDCY(KC,3)
27491 IF(MDME(IDC,1).LT.0) GOTO 430
27492 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27493 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27494 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
27498 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
27500 ELSEIF(I.EQ.2) THEN
27501 C...d* -> gamma + d.
27502 QF=-RTCM(43)/2D0+RTCM(44)/6D0
27503 WDTP(I)=FAC*AEM*QF**2/4D0
27505 ELSEIF(I.EQ.3) THEN
27507 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
27508 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27509 & (1D0-RM1)**2*(2D0+RM1)
27511 ELSEIF(I.EQ.4) THEN
27513 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27514 & (1D0-RM1)**2*(2D0+RM1)
27515 IF(KFLR.GT.0) WID2=WIDS(24,3)
27516 IF(KFLR.LT.0) WID2=WIDS(24,2)
27518 WDTP(I)=FUDGE*WDTP(I)
27519 WDTP(0)=WDTP(0)+WDTP(I)
27520 IF(MDME(IDC,1).GT.0) THEN
27521 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27522 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27523 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27524 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27528 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
27529 C...u* excited quark.
27530 FAC=(SH/RTCM(41)**2)*SHR
27531 DO 440 I=1,MDCY(KC,3)
27533 IF(MDME(IDC,1).LT.0) GOTO 440
27534 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27535 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27536 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
27540 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
27542 ELSEIF(I.EQ.2) THEN
27543 C...u* -> gamma + u.
27544 QF=RTCM(43)/2D0+RTCM(44)/6D0
27545 WDTP(I)=FAC*AEM*QF**2/4D0
27547 ELSEIF(I.EQ.3) THEN
27549 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
27550 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27551 & (1D0-RM1)**2*(2D0+RM1)
27553 ELSEIF(I.EQ.4) THEN
27555 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27556 & (1D0-RM1)**2*(2D0+RM1)
27557 IF(KFLR.GT.0) WID2=WIDS(24,2)
27558 IF(KFLR.LT.0) WID2=WIDS(24,3)
27560 WDTP(I)=FUDGE*WDTP(I)
27561 WDTP(0)=WDTP(0)+WDTP(I)
27562 IF(MDME(IDC,1).GT.0) THEN
27563 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27564 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27565 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27566 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27570 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
27571 C...e* excited lepton.
27572 FAC=(SH/RTCM(41)**2)*SHR
27573 DO 450 I=1,MDCY(KC,3)
27575 IF(MDME(IDC,1).LT.0) GOTO 450
27576 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27577 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27578 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
27581 C...e* -> gamma + e.
27582 QF=-RTCM(43)/2D0-RTCM(44)/2D0
27583 WDTP(I)=FAC*AEM*QF**2/4D0
27585 ELSEIF(I.EQ.2) THEN
27587 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
27588 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27589 & (1D0-RM1)**2*(2D0+RM1)
27591 ELSEIF(I.EQ.3) THEN
27593 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27594 & (1D0-RM1)**2*(2D0+RM1)
27595 IF(KFLR.GT.0) WID2=WIDS(24,3)
27596 IF(KFLR.LT.0) WID2=WIDS(24,2)
27598 WDTP(I)=FUDGE*WDTP(I)
27599 WDTP(0)=WDTP(0)+WDTP(I)
27600 IF(MDME(IDC,1).GT.0) THEN
27601 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27602 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27603 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27604 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27608 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
27609 C...nu*_e excited neutrino.
27610 FAC=(SH/RTCM(41)**2)*SHR
27611 DO 460 I=1,MDCY(KC,3)
27613 IF(MDME(IDC,1).LT.0) GOTO 460
27614 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27615 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27616 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
27619 C...nu*_e -> Z0 + nu*_e.
27620 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
27621 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27622 & (1D0-RM1)**2*(2D0+RM1)
27624 ELSEIF(I.EQ.2) THEN
27625 C...nu*_e -> W+ + e.
27626 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27627 & (1D0-RM1)**2*(2D0+RM1)
27628 IF(KFLR.GT.0) WID2=WIDS(24,2)
27629 IF(KFLR.LT.0) WID2=WIDS(24,3)
27631 WDTP(I)=FUDGE*WDTP(I)
27632 WDTP(0)=WDTP(0)+WDTP(I)
27633 IF(MDME(IDC,1).GT.0) THEN
27634 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27635 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27636 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27637 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27641 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
27642 C...G* (graviton resonance):
27643 FAC=(PARP(50)**2/PARU(1))*SHR
27644 DO 470 I=1,MDCY(KC,3)
27646 IF(MDME(IDC,1).LT.0) GOTO 470
27647 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27648 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27649 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
27654 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
27655 & PYHFTH(SH,SH*RM1,1D0)
27656 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27657 & (1D0+8D0*RM1/3D0)/320D0
27658 IF(I.EQ.6) WID2=WIDS(6,1)
27659 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27660 ELSEIF(I.LE.16) THEN
27661 C...G* -> l+ + l-, nu + nubar
27663 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27664 & (1D0+8D0*RM1/3D0)/320D0
27665 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27666 ELSEIF(I.EQ.17) THEN
27669 ELSEIF(I.EQ.18) THEN
27670 C...G* -> gamma + gamma.
27672 ELSEIF(I.EQ.19) THEN
27674 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27675 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27677 ELSEIF(I.EQ.20) THEN
27679 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27680 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27683 WDTP(I)=FUDGE*WDTP(I)
27684 WDTP(0)=WDTP(0)+WDTP(I)
27685 IF(MDME(IDC,1).GT.0) THEN
27686 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27687 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27688 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27689 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27693 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27694 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27695 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27696 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27697 DO 480 I=1,MDCY(KC,3)
27699 IF(MDME(IDC,1).LT.0) GOTO 480
27700 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27701 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27702 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27703 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27706 C...nu_lR -> l- qbar q'
27707 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27708 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27709 ELSEIF(I.LE.18) THEN
27710 C...nu_lR -> l+ q qbar'
27711 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27712 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27714 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27716 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27718 X=(PM1+PM2+PM3)/SHR
27719 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27721 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27722 WDTP(I)=FAC*FCOF*FX*FY
27723 WDTP(I)=FUDGE*WDTP(I)
27724 WDTP(0)=WDTP(0)+WDTP(I)
27725 IF(MDME(IDC,1).GT.0) THEN
27726 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27727 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27728 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27729 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27733 ELSEIF(KFLA.EQ.9900023) THEN
27735 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27736 DO 490 I=1,MDCY(KC,3)
27738 IF(MDME(IDC,1).LT.0) GOTO 490
27739 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27740 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27741 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27745 C...Z_R0 -> q + qbar
27747 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27748 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27750 IF(I.EQ.6) WID2=WIDS(6,1)
27751 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27752 C...Z_R0 -> l+ + l-
27756 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27757 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27762 ELSEIF(I.LE.15) THEN
27763 C...Z0 -> nu_R + nu_R, assumed Majorana.
27767 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27770 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27771 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27772 WDTP(I)=FUDGE*WDTP(I)
27773 WDTP(0)=WDTP(0)+WDTP(I)
27774 IF(MDME(IDC,1).GT.0) THEN
27775 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27776 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27777 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27778 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27782 ELSEIF(KFLA.EQ.9900024) THEN
27784 FAC=(AEM/(24D0*XW))*SHR
27785 DO 500 I=1,MDCY(KC,3)
27787 IF(MDME(IDC,1).LT.0) GOTO 500
27788 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27789 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27790 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27793 C...W_R+/- -> q + qbar'
27794 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27796 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27798 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27800 ELSEIF(I.LE.12) THEN
27801 C...W_R+/- -> l+/- + nu_R
27804 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27805 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27806 WDTP(I)=FUDGE*WDTP(I)
27807 WDTP(0)=WDTP(0)+WDTP(I)
27808 IF(MDME(IDC,1).GT.0) THEN
27809 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27810 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27811 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27812 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27816 ELSEIF(KFLA.EQ.9900041) THEN
27818 FAC=(1D0/(8D0*PARU(1)))*SHR
27819 DO 510 I=1,MDCY(KC,3)
27821 IF(MDME(IDC,1).LT.0) GOTO 510
27822 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27823 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27824 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27827 C...H_L++/-- -> l+/- + l'+/-
27828 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27829 & (IABS(KFDP(IDC,2))-9)/2)**2
27830 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27831 ELSEIF(I.EQ.7) THEN
27832 C...H_L++/-- -> W_L+/- + W_L+/-
27833 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27834 & (3D0*RM1+0.25D0/RM1-1D0)
27835 WID2=WIDS(24,4+(1-KFLS)/2)
27838 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27839 WDTP(I)=FUDGE*WDTP(I)
27840 WDTP(0)=WDTP(0)+WDTP(I)
27841 IF(MDME(IDC,1).GT.0) THEN
27842 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27843 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27844 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27845 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27849 ELSEIF(KFLA.EQ.9900042) THEN
27851 FAC=(1D0/(8D0*PARU(1)))*SHR
27852 DO 520 I=1,MDCY(KC,3)
27854 IF(MDME(IDC,1).LT.0) GOTO 520
27855 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27856 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27857 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27860 C...H_R++/-- -> l+/- + l'+/-
27861 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27862 & (IABS(KFDP(IDC,2))-9)/2)**2
27863 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27864 ELSEIF(I.EQ.7) THEN
27865 C...H_R++/-- -> W_R+/- + W_R+/-
27866 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27867 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27870 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27871 WDTP(I)=FUDGE*WDTP(I)
27872 WDTP(0)=WDTP(0)+WDTP(I)
27873 IF(MDME(IDC,1).GT.0) THEN
27874 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27875 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27876 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27877 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27881 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27883 C...Need to update to alpha_rho
27884 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27885 FAC=(ALPRHT/12D0)*SHR
27886 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27890 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27892 XWRHT=1D0/(4D0*XW*(1D0-XW))
27893 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27894 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27895 DO 530 I=1,MDCY(KC,3)
27897 IF(MDME(IDC,1).LT.0) GOTO 530
27898 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27899 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27900 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27902 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27905 FACPA=PCM**2+1.5D0*RM1
27908 C...a2_tc0 -> W+ + W-
27910 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27911 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27913 C...a2_tc0 -> W+ + pi_tc- + c.c.
27914 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27915 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27917 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27919 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27921 ELSEIF(I.EQ.4) THEN
27922 C...a2_tc0 -> Z0 + pi_tc0'
27923 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27924 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27926 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27927 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27928 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27929 FACPA=PCM**2*(1D0+RM1+RM2)
27933 C...a_T^0 -> gamma rho_T^0
27934 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27935 WID2=WIDS(PYCOMP(KTECHN+113),2)
27936 ELSEIF(I.EQ.6) THEN
27937 C...a_T^0 -> gamma omega_T
27938 VA2=1D0/RTCM(50)**4
27939 WID2=WIDS(PYCOMP(KTECHN+223),2)
27940 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27941 C...a_T^0 -> W^+- rho_T^-+
27942 AA2=.25D0/XW/RTCM(51)**4
27944 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27946 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27948 ELSEIF(I.EQ.9) THEN
27949 C...a_T^0 -> Z^0 rho_T^0
27950 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27951 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27952 ELSEIF(I.EQ.10) THEN
27953 C...a_T^0 -> Z^0 omega_T
27954 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27955 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27957 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27959 C...a2_tc0 -> f + fbar.
27964 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27968 IF(IA.GE.17) WID2=WIDS(IA,1)
27971 AI=SIGN(1D0,EI+0.1D0)
27975 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27976 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27977 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27978 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27980 WDTP(I)=FUDGE*WDTP(I)
27981 WDTP(0)=WDTP(0)+WDTP(I)
27982 IF(MDME(IDC,1).GT.0) THEN
27983 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27984 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27985 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27986 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27990 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27992 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27993 FAC=(ALPRHT/12D0)*SHR
27997 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27999 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
28000 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
28001 DO 540 I=1,MDCY(KC,3)
28003 IF(MDME(IDC,1).LT.0) GOTO 540
28004 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
28005 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
28006 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
28008 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28017 C...a2_tc+ -> gamma + W+.
28019 AA2=RTCM(3)**2/RTCM(49)**2
28020 WID2=WIDS(24,ICHANN)
28021 C...a2_tc+ -> gamma + pi_tc+.
28022 ELSEIF(I.EQ.2) THEN
28023 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
28024 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
28025 C...a2_tc+ -> W+ + Z
28026 ELSEIF(I.EQ.3) THEN
28027 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
28028 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
28029 WID2=WIDS(24,ICHANN)*WIDS(23,2)
28030 C...a2_tc+ -> W+ + pi_tc0.
28031 ELSEIF(I.EQ.4) THEN
28032 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
28033 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
28034 C...a2_tc+ -> W+ + pi_tc'0.
28035 ELSEIF(I.EQ.5) THEN
28036 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
28037 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
28038 C...a2_tc+ -> Z0 + pi_tc+.
28039 ELSEIF(I.EQ.6) THEN
28040 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
28042 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
28044 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
28046 ELSEIF(I.LE.10) THEN
28047 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
28048 FACPA=PCM**2*(1D0+RM1+RM2)
28051 C...a2_tc+ -> gamma + rho_tc+
28053 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
28054 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
28055 C...a2_tc+ -> W+ + rho_T^0
28056 ELSEIF(I.EQ.8) THEN
28057 AA2=1D0/(4D0*XW)/RTCM(51)**4
28058 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
28059 C...a2_tc+ -> W+ + omega_T
28060 ELSEIF(I.EQ.9) THEN
28061 VA2=.25D0/XW/RTCM(50)**4
28062 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
28063 C...a2_tc+ -> Z^0 + rho_T^+
28064 ELSEIF(I.EQ.10) THEN
28065 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
28066 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
28067 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
28069 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
28071 C...a2_tc+ -> f + fbar'.
28075 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
28077 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
28078 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
28079 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
28081 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
28082 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
28083 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
28088 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
28090 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
28093 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
28094 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28096 WDTP(I)=FUDGE*WDTP(I)
28097 WDTP(0)=WDTP(0)+WDTP(I)
28098 IF(MDME(IDC,1).GT.0) THEN
28099 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
28100 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
28101 WDTE(I,0)=WDTE(I,MDME(IDC,1))
28102 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
28113 C***********************************************************************
28116 C...Calculates partial width and differential cross-section maxima
28117 C...of channels/processes not allowed on mass-shell, and selects
28118 C...masses in such channels/processes.
28120 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
28122 C...Double precision and integer declarations.
28123 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28124 IMPLICIT INTEGER(I-N)
28125 INTEGER PYK,PYCHGE,PYCOMP
28127 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28128 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28129 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28130 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28131 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28132 COMMON/PYINT1/MINT(400),VINT(400)
28133 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28134 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28135 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
28138 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
28139 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
28140 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
28143 C...Find if particles equal, maximum mass, matrix elements, etc.
28149 IF(KFD(1).EQ.KFD(2)) MEQL=1
28151 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
28152 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
28158 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
28161 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
28162 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
28163 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
28164 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
28165 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
28166 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
28169 C...Find where Breit-Wigners are required, else select discrete masses.
28171 KFCA=PYCOMP(KFD(I))
28173 PMD(I)=PMAS(KFCA,1)
28174 PGD(I)=PMAS(KFCA,2)
28179 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
28182 RMG(I)=(PMG(I)/PMMX)**2
28188 C...Find allowed mass range and Breit-Wigner parameters.
28190 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
28192 PMU(I)=PMMX-PARP(42)
28193 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
28194 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28195 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
28197 IF(MLM.EQ.2) ILM=3-I
28198 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
28199 IF(MBW(3-I).EQ.0) THEN
28200 PMU(I)=PMMX-PMD(3-I)
28202 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
28204 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
28205 & MIN(PMU(I),CKIN(NOFF+2*ILM))
28206 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
28207 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
28208 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28209 IF(MBW(I).EQ.1) THEN
28210 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28211 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28212 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
28215 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
28217 IF(MLM.EQ.2) ILM=3-I
28218 PML(I)=MAX(CKIN(48+I),PARP(42))
28219 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
28220 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
28221 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
28222 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
28223 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28224 IF(MBW(I).EQ.1) THEN
28225 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28226 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28227 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
28232 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
28234 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
28239 C...Calculation of partial width of resonance.
28240 IF(MOFSH.EQ.1) THEN
28242 C..If only one integration, pick that to be the inner.
28243 IF(MBW(1).EQ.0) THEN
28249 ELSEIF(MBW(2).EQ.0) THEN
28253 C...Start outer loop of integration.
28254 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28255 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
28256 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
28262 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28263 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
28264 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
28268 C...Start inner loop of integration.
28270 PMU1=MIN(PMU(1),PMMX-PM2)
28271 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
28272 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
28273 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
28274 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
28282 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
28283 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
28286 C...Evaluate function value - inner loop.
28287 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28288 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
28289 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
28290 & RM2**2+10D0*RM1*RM2)
28291 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
28294 C...Go to next position in inner loop.
28300 ELSEIF(NPT1.LE.8) THEN
28302 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
28304 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
28305 INX1(NPT1)=INX1(ISH1)
28308 ELSEIF(NPT1.LT.100) THEN
28311 IF(ISH1.GT.NPT1) ISH1=2
28312 IF(ISH1.EQ.ISN1) GOTO 160
28313 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
28314 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
28316 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
28317 INX1(NPT1)=INX1(ISH1)
28322 C...Calculate integral over inner loop.
28325 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
28326 & (XPT1(INX1(IPT1))-XPT1(IPT1))
28328 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
28329 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28330 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
28333 C...Go to next position in outer loop.
28339 ELSEIF(NPT2.LE.8) THEN
28341 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
28343 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
28344 INX2(NPT2)=INX2(ISH2)
28347 ELSEIF(NPT2.LT.100) THEN
28350 IF(ISH2.GT.NPT2) ISH2=2
28351 IF(ISH2.EQ.ISN2) GOTO 200
28352 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
28353 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
28355 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
28356 INX2(NPT2)=INX2(ISH2)
28361 C...Calculate integral over outer loop.
28364 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
28365 & (XPT2(INX2(IPT2))-XPT2(IPT2))
28367 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
28368 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
28373 C...Save result; second integration for user-selected mass range.
28374 IF(LOOP.EQ.1) WIDW=FSUM2
28376 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
28377 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
28384 C...Select two decay product masses of a resonance.
28385 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
28387 IF(MBW(I).EQ.0) GOTO 230
28388 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
28390 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
28391 RMG(I)=(PMG(I)/PMMX)**2
28393 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
28394 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
28396 C...Weight with matrix element (if none known, use beta factor).
28397 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
28399 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
28400 ELSEIF(MMED.EQ.2) THEN
28401 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
28402 & RMG(2)**2+10D0*RMG(1)*RMG(2))
28403 ELSEIF(MMED.EQ.3) THEN
28404 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
28408 IF(WTBE.LT.PYR(0)) GOTO 220
28412 C...Find suitable set of masses for initialization of 2 -> 2 processes.
28413 ELSEIF(MOFSH.EQ.3) THEN
28414 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
28415 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
28417 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
28419 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
28423 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
28424 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
28425 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
28430 C...Evaluate importance of excluded tails of Breit-Wigners.
28431 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
28432 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
28436 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
28440 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
28441 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
28443 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
28444 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
28445 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
28446 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
28448 C...Pick one particle to be the lighter (if improves efficiency).
28449 ELSEIF(MOFSH.EQ.4) THEN
28450 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
28451 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
28452 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
28454 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
28456 IF(MBW(I).EQ.0) GOTO 270
28458 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
28460 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
28462 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
28463 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
28464 IF(RBR.LT.0.8D0) THEN
28465 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
28466 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
28467 ELSEIF(RBR.LT.0.9D0) THEN
28468 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
28469 ELSEIF(RBR.LT.1.5D0) THEN
28470 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
28472 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
28473 & (PMV**2-PML(I)**2))))
28476 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
28477 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
28478 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
28479 NGEN(0,1)=NGEN(0,1)+1
28480 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
28490 C...Give weight for selected mass distribution.
28493 IF(MBW(I).EQ.0) GOTO 280
28495 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
28497 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
28498 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
28499 & (PMD(I)*PGD(I))**2)/PARU(1)
28503 FI0=(ATV-ATL(I))/PARU(1)
28504 FI1=PMV**2-PML(I)**2
28505 FI2=2D0*LOG(PMV/PML(I))
28506 FI3=1D0/PML(I)**2-1D0/PMV**2
28507 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
28508 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
28509 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
28512 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
28514 VINT(80)=VINT(80)*FI0
28516 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
28522 C***********************************************************************
28525 C...Handles the possibility of colour reconnection in W+W- events,
28526 C...Based on the main scenarios of the Sjostrand and Khoze study:
28527 C...I, II, II', intermediate and instantaneous; plus one model
28528 C...along the lines of the Gustafson and Hakkinen: GH.
28529 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
28530 C...is as if first resonance is W+ and second W-.
28532 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
28534 C...Double precision and integer declarations.
28535 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28536 IMPLICIT INTEGER(I-N)
28537 INTEGER PYK,PYCHGE,PYCOMP
28538 C...Parameter value; number of points in MC integration.
28539 PARAMETER (NPT=100)
28541 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28542 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28543 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28544 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28545 COMMON/PYINT1/MINT(400),VINT(400)
28546 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28548 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
28549 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
28550 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
28551 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
28552 &TMC(20),IJOIN(100)
28554 C...Functions to give four-product and to do determinants.
28555 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)
28556 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
28557 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
28558 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
28560 C...Only allow fraction of recoupling for GH, intermediate and
28562 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28563 IF(PYR(0).GT.PARP(120)) RETURN
28567 C...Common part for scenarios I, II, II', and GH.
28568 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
28569 &MSTP(115).EQ.5) THEN
28571 C...Read out frequently-used parameters.
28575 IF(ISUB.EQ.22) PMW=PMAS(23,1)
28577 IF(ISUB.EQ.22) PGW=PMAS(23,2)
28584 C...Find range of decay products of the W's.
28585 C...Background: the W's are stored in IW1 and IW2.
28586 C...Their direct decay products in NSD1+1 through NSD1+4.
28587 C...Products after shower (if any) in NSD1+5 through NAFT1
28588 C...for first W and in NAFT1+1 through N for the second.
28589 IF(NAFT1.GT.NSD1+4) THEN
28596 IF(N.GT.NAFT1) THEN
28604 C...Rearrange parton shower products along strings.
28606 CALL PYPREP(NSD1+1)
28607 IF(MINT(51).NE.0) RETURN
28609 C...Find partons pointing back to W+ and W-; store them with quark
28610 C...end of string first.
28616 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
28617 IF(IABS(K(I,2)).GE.22) GOTO 120
28618 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
28619 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
28629 IF(K(I,1).EQ.1) ISGP=0
28630 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
28631 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
28641 IF(K(I,1).EQ.1) ISGM=0
28645 C...Boost to W+W- rest frame (not strictly needed).
28647 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
28649 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28650 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28651 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28653 C...Select decay vertices of W+ and W-.
28654 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
28655 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
28656 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
28657 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28660 XP(J)=TP*P(IW1,J)/P(IW1,4)
28661 XM(J)=TM*P(IW2,J)/P(IW2,4)
28664 C...Begin scenario I specifics.
28665 IF(MSTP(115).EQ.1) THEN
28667 C...Reconstruct velocity and direction of W+ string pieces.
28669 IF(K(INP(IIP),2).LT.0) GOTO 170
28672 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28673 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28677 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28678 DIRP(IIP,J)=V1(J)-V2(J)
28680 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28682 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28684 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28688 C...Reconstruct velocity and direction of W- string pieces.
28690 IF(K(INM(IIM),2).LT.0) GOTO 200
28693 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28694 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28698 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28699 DIRM(IIM,J)=V1(J)-V2(J)
28701 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28703 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28705 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28709 C...Loop over number of space-time points.
28714 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28715 R=SQRT(-LOG(PYR(0)))
28717 X=BLOWR*RHAD*R*COS(PHI)
28718 Y=BLOWR*RHAD*R*SIN(PHI)
28719 R=SQRT(-LOG(PYR(0)))
28721 Z=BLOWR*RHAD*R*COS(PHI)
28722 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28724 C...Reject impossible points. Weight for sample distribution.
28725 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28726 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28727 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28729 C...Loop over W+ string pieces and find one with largest weight.
28737 IF(K(INP(IIP),2).LT.0) GOTO 220
28738 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28739 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28741 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28743 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28744 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28745 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28746 & DIRP(IIP,3)*XB(3))**2
28747 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28749 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28750 IF(WTP.GT.WTMAXP) THEN
28756 C...Loop over W- string pieces and find one with largest weight.
28764 IF(K(INM(IIM),2).LT.0) GOTO 240
28765 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28766 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28768 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28770 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28771 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28772 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28773 & DIRM(IIM,3)*XB(3))**2
28774 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28776 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28777 IF(WTM.GT.WTMAXM) THEN
28783 C...Result of integration.
28785 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28786 WT=WTMAXP*WTMAXM/WTSMP
28794 RES=BLOWR**3*BLOWT*SUM/NPT
28796 C...Decide whether to reconnect and, if so, where.
28798 PREC=1D0-EXP(-FACT*RES)
28799 IF(PREC.GT.PYR(0)) THEN
28804 IF(RSUM.LE.0D0) GOTO 270
28810 C...Begin scenario II and II' specifics.
28811 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28813 C...Loop through all string pieces, one from W+ and one from W-.
28817 IF(K(INP(IIP),2).LT.0) GOTO 340
28821 IF(K(INM(IIM),2).LT.0) GOTO 330
28825 C...Find endpoint velocity vectors.
28827 V1P(J)=P(I1P,J)/P(I1P,4)
28828 V2P(J)=P(I2P,J)/P(I2P,4)
28829 V1M(J)=P(I1M,J)/P(I1M,4)
28830 V2M(J)=P(I2M,J)/P(I2M,4)
28833 C...Define q matrix and find t.
28835 Q(1,J)=V2P(J)-V1P(J)
28836 Q(2,J)=-(V2M(J)-V1M(J))
28837 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28838 Q(4,J)=V1P(J)-V1M(J)
28840 T=-DETER(1,2,3)/DETER(1,2,4)
28842 C...Find alpha and beta; i.e. coordinates of crossing point.
28845 S13=Q(3,1)+Q(4,1)*T
28848 S23=Q(3,2)+Q(4,2)*T
28849 DEN=S11*S22-S12*S21
28850 ALP=(S12*S23-S22*S13)/DEN
28851 BET=(S21*S13-S11*S23)/DEN
28853 C...Check if solution acceptable.
28855 IF(T.LT.GTMAX) IANSW=0
28856 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28857 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28859 C...Find point of crossing and check that not inconsistent.
28861 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28862 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28864 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28865 & (XPP(3)-XMM(3))**2
28866 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28867 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28868 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28870 C...Find string eigentimes at crossing.
28871 IF(IANSW.EQ.1) THEN
28872 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28873 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28874 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28875 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28881 C...Order crossings by time. End loop over crossings.
28882 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28884 DO 310 I1=NCROSS,1,-1
28885 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28905 C...Loop over crossings; find first (if any) acceptable one.
28907 IF(NCROSS.GE.1) THEN
28909 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28910 IF(PNFRAG.GT.PYR(0)) THEN
28911 C...Scenario II: only compare with fragmentation time.
28912 IF(MSTP(115).EQ.2) THEN
28917 C...Scenario II': also require that string length decreases.
28925 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28926 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28927 IF(ELNEW.LT.ELOLD) THEN
28939 C...Begin scenario GH specifics.
28940 ELSEIF(MSTP(115).EQ.5) THEN
28942 C...Loop through all string pieces, one from W+ and one from W-.
28946 IF(K(INP(IIP),2).LT.0) GOTO 380
28950 IF(K(INM(IIM),2).LT.0) GOTO 370
28954 C...Look for largest decrease of (exponent of) Lambda measure.
28955 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28956 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28957 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28958 IF(ELDIF.LT.ELMIN) THEN
28970 C...Common for scenarios I, II, II' and GH: reconnect strings.
28974 DO 390 IS=1,NNP+NNM
28978 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28980 ELSEIF(IS.LE.IIP+NNM) THEN
28981 I=INM(IS-IIP-NNM+IIM)
28986 IF(K(I,2).LT.0) THEN
28987 CALL PYJOIN(NJOIN,IJOIN)
28992 C...Restore original event record if no reconnection.
28994 DO 400 I=NSD1+1,NOLD
28995 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28996 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28997 K(I,5)=MOD(K(I,5),MSTU(5)**2)
29006 C...Boost back system.
29007 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
29008 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
29009 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
29010 & BEWW(1),BEWW(2),BEWW(3))
29012 C...Common part for intermediate and instantaneous scenarios.
29013 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
29016 C...Remove old shower products and reset showering ones.
29018 DO 420 I=NSD1+1,NSD1+4
29020 K(I,4)=MOD(K(I,4),MSTU(5)**2)
29021 K(I,5)=MOD(K(I,5),MSTU(5)**2)
29024 C...Identify quark-antiquark pairs.
29028 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
29031 C...Reconnect strings.
29034 CALL PYJOIN(2,IJOIN)
29037 CALL PYJOIN(2,IJOIN)
29039 C...Do new parton showers in intermediate scenario.
29040 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
29043 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
29044 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
29047 C...Do new parton showers in instantaneous scenario.
29048 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
29049 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
29050 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
29051 PPM=SQRT(MAX(0D0,PPM2))
29052 CALL PYSHOW(IQ1,IQ4,PPM)
29053 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
29054 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
29055 PPM=SQRT(MAX(0D0,PPM2))
29056 CALL PYSHOW(IQ3,IQ2,PPM)
29063 C***********************************************************************
29066 C...Checks generated variables against pre-set kinematical limits;
29067 C...also calculates limits on variables used in generation.
29069 SUBROUTINE PYKLIM(ILIM)
29071 C...Double precision and integer declarations.
29072 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29073 IMPLICIT INTEGER(I-N)
29074 INTEGER PYK,PYCHGE,PYCOMP
29076 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29079 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29080 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29081 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29082 COMMON/PYINT1/MINT(400),VINT(400)
29083 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29084 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29087 C...Common kinematical expressions.
29091 IF(ISUB.EQ.96) GOTO 100
29095 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
29096 CKIN09=MAX(CKIN(9),CKIN(13))
29097 CKIN10=MIN(CKIN(10),CKIN(14))
29098 CKIN11=MAX(CKIN(11),CKIN(15))
29099 CKIN12=MIN(CKIN(12),CKIN(16))
29101 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
29102 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
29103 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
29104 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
29109 RM3=SQM3/(TAU*VINT(2))
29110 RM4=SQM4/(TAU*VINT(2))
29111 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29114 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
29115 &PTHMIN=MAX(CKIN(3),CKIN(5))
29118 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
29119 C...pre-set kinematical limits.
29124 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29125 X1=SQRT(TAUE)*EXP(YST)
29126 X2=SQRT(TAUE)*EXP(-YST)
29128 IF(MINT(47).NE.1) THEN
29129 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
29130 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
29131 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
29132 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
29134 IF(MINT(45).NE.1) THEN
29135 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
29137 IF(MINT(46).NE.1) THEN
29138 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
29140 IF(MINT(45).EQ.2) THEN
29141 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
29143 IF(MINT(46).EQ.2) THEN
29144 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
29146 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29147 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
29148 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
29149 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
29150 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
29151 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
29152 Y3=YST+0.5D0*LOG(EXPY3)
29153 Y4=YST+0.5D0*LOG(EXPY4)
29158 STH=SQRT(MAX(0D0,1D0-CTH**2))
29159 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
29160 & CTH)**2-4D0*RM3))
29161 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
29162 & CTH)**2-4D0*RM4))
29163 IF(STH.GE.1D-10) THEN
29164 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
29166 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
29168 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
29169 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
29170 ETALAR=MAX(ETA3,ETA4)
29171 ETASMA=MIN(ETA3,ETA4)
29173 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
29174 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
29175 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
29176 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
29178 RPTS=4D0*VINT(71)**2/SH
29179 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29180 RM34=MAX(1D-20,2D0*RM3*RM4)
29181 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
29182 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
29183 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29184 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
29185 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29186 IF(PTH.LT.PTHMIN) MINT(51)=1
29187 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
29188 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
29189 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
29190 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
29191 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
29192 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
29193 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
29194 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
29195 IF(THA.LT.CKIN(35)) MINT(51)=1
29196 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
29197 IF(UHA.LT.CKIN(37)) MINT(51)=1
29198 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
29200 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29201 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
29202 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
29205 C...Additional cuts on W2 (approximately) in DIS.
29206 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
29208 IF(IABS(MINT(12)).LT.20) XBJ=X1
29210 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
29211 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
29212 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
29215 ELSEIF(ILIM.EQ.1) THEN
29216 C...Calculate limits on tau
29217 C...0) due to definition
29220 C...1) due to limits on subsystem mass
29221 TAUMN1=CKIN(1)**2/VINT(2)
29223 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
29224 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
29225 TM3=SQRT(SQM3+PTHMIN**2)
29226 TM4=SQRT(SQM4+PTHMIN**2)
29228 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
29229 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
29231 C...3) due to limits on pT-hat and cos(theta-hat)
29232 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
29233 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
29235 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
29236 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
29237 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
29239 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
29240 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
29241 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
29242 C...4) due to limits on x1 and x2
29243 TAUMN4=CKIN(21)*CKIN(23)
29244 TAUMX4=CKIN(22)*CKIN(24)
29245 C...5) due to limits on xF
29247 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
29248 C...6) due to limits on that and uhat
29249 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
29251 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
29252 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
29254 C...Net effect of all separate limits.
29255 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
29256 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
29257 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
29260 ELSEIF(MINT(47).EQ.5) THEN
29261 VINT(31)=MIN(VINT(31),1D0-2D-10)
29262 ELSEIF(MINT(47).GE.6) THEN
29263 VINT(31)=MIN(VINT(31),1D0-1D-10)
29265 IF(VINT(31).LE.VINT(11)) MINT(51)=1
29267 ELSEIF(ILIM.EQ.2) THEN
29268 C...Calculate limits on y*
29270 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
29272 C...0) due to kinematics
29275 C...1) due to explicit limits
29278 C...2) due to limits on x1
29279 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
29280 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
29281 C...3) due to limits on x2
29282 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
29283 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
29284 C...4) due to limits on xF
29285 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
29286 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
29287 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
29288 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
29289 C...5) due to simultaneous limits on y-large and y-small
29290 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
29291 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
29292 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
29293 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
29294 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
29295 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
29296 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
29298 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
29299 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
29300 RZMX=BE34*MIN(CKIN(28),CTHLIM)
29301 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
29302 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
29303 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
29304 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
29305 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
29306 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
29308 C...Net effect of all separate limits.
29309 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
29310 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
29311 IF(MINT(47).EQ.1) THEN
29314 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
29315 VINT(12)=(1D0-1D-9)*YSTMX0
29316 VINT(32)=(1D0+1D-9)*YSTMX0
29317 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
29318 VINT(12)=-(1D0+1D-9)*YSTMX0
29319 VINT(32)=-(1D0-1D-9)*YSTMX0
29320 ELSEIF(MINT(47).EQ.5) THEN
29321 YSTEE=LOG((1D0-1D-10)/TAURT)
29322 VINT(12)=MAX(VINT(12),-YSTEE)
29323 VINT(32)=MIN(VINT(32),YSTEE)
29325 IF(VINT(32).LE.VINT(12)) MINT(51)=1
29327 ELSEIF(ILIM.EQ.3) THEN
29328 C...Calculate limits on cos(theta-hat)
29330 C...0) due to definition
29335 C...1) due to explicit limits
29336 CTNMN1=MIN(0D0,CKIN(27))
29337 CTNMX1=MIN(0D0,CKIN(28))
29338 CTPMN1=MAX(0D0,CKIN(27))
29339 CTPMX1=MAX(0D0,CKIN(28))
29340 C...2) due to limits on pT-hat
29341 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
29345 IF(CKIN(4).GE.0D0) THEN
29346 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
29347 & (BE34**2*TAU*VINT(2))))
29350 C...3) due to limits on y-large and y-small
29351 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
29352 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
29353 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
29354 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
29355 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
29356 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
29357 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
29358 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
29359 C...4) due to limits on that
29365 IF(CKIN(35).GT.0D0) THEN
29366 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
29367 IF(CTLIM.GT.0D0) THEN
29374 IF(CKIN(36).GT.0D0) THEN
29375 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
29376 IF(CTLIM.LT.0D0) THEN
29383 C...5) due to limits on uhat
29388 IF(CKIN(37).GT.0D0) THEN
29389 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
29390 IF(CTLIM.LT.0D0) THEN
29397 IF(CKIN(38).GT.0D0) THEN
29398 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
29399 IF(CTLIM.GT.0D0) THEN
29407 C...Net effect of all separate limits.
29408 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
29409 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
29410 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
29411 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
29412 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
29414 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
29415 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
29417 ELSEIF(ILIM.EQ.4) THEN
29418 C...Calculate limits on tau'
29419 C...0) due to kinematics
29421 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
29422 PQRAT=(VINT(201)+VINT(206))/VINT(1)
29423 TAPMN0=(SQRT(TAU)+PQRAT)**2
29426 C...1) due to explicit limits
29427 TAPMN1=CKIN(31)**2/VINT(2)
29429 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
29431 C...Net effect of all separate limits.
29432 VINT(16)=MAX(TAPMN0,TAPMN1)
29433 VINT(36)=MIN(TAPMX0,TAPMX1)
29434 IF(MINT(47).EQ.1) THEN
29437 ELSEIF(MINT(47).EQ.5) THEN
29438 VINT(36)=MIN(VINT(36),1D0-2D-10)
29439 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
29440 VINT(36)=MIN(VINT(36),1D0-1D-10)
29442 IF(VINT(36).LE.VINT(16)) MINT(51)=1
29447 C...Special case for low-pT and multiple interactions:
29448 C...effective kinematical limits for tau, y*, cos(theta-hat).
29449 100 IF(ILIM.EQ.0) THEN
29450 ELSEIF(ILIM.EQ.1) THEN
29451 IF(MSTP(82).LE.1) THEN
29452 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
29455 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
29458 ELSEIF(ILIM.EQ.2) THEN
29459 VINT(12)=0.5D0*LOG(VINT(21))
29461 ELSEIF(ILIM.EQ.3) THEN
29462 IF(MSTP(82).LE.1) THEN
29463 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
29464 & (VINT(21)*VINT(2))
29466 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
29467 & (VINT(21)*VINT(2))
29469 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
29478 C*********************************************************************
29481 C...Maps a uniform distribution into a distribution of a kinematical
29482 C...variable according to one of the possibilities allowed. It is
29483 C...assumed that kinematical limits have been set by a PYKLIM call.
29485 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
29487 C...Double precision and integer declarations.
29488 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29489 IMPLICIT INTEGER(I-N)
29490 INTEGER PYK,PYCHGE,PYCOMP
29492 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29493 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29494 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29495 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29496 COMMON/PYINT1/MINT(400),VINT(400)
29497 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29498 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
29500 C...Convert VVAR to tau variable.
29506 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
29509 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
29512 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
29516 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
29518 ELSEIF(MVAR.EQ.1) THEN
29519 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
29520 ELSEIF(MVAR.EQ.2) THEN
29521 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
29522 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
29523 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
29524 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
29525 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
29526 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
29527 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
29528 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
29529 ELSEIF(MINT(47).EQ.5) THEN
29530 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
29531 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
29532 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29534 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
29535 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
29536 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29538 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
29540 C...Convert VVAR to y* variable.
29541 ELSEIF(IVAR.EQ.2) THEN
29545 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
29546 IF(MINT(47).EQ.1) THEN
29548 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
29549 YST=-0.5D0*LOG(TAUE)
29550 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
29551 YST=0.5D0*LOG(TAUE)
29552 ELSEIF(MVAR.EQ.1) THEN
29553 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
29554 ELSEIF(MVAR.EQ.2) THEN
29555 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
29556 ELSEIF(MVAR.EQ.3) THEN
29557 AUPP=ATAN(EXP(YSTMAX))
29558 ALOW=ATAN(EXP(YSTMIN))
29559 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
29560 ELSEIF(MVAR.EQ.4) THEN
29561 YST0=-0.5D0*LOG(TAUE)
29562 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
29563 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29564 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
29566 YST0=-0.5D0*LOG(TAUE)
29567 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29568 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
29569 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
29571 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
29573 C...Convert VVAR to cos(theta-hat) variable.
29574 ELSEIF(IVAR.EQ.3) THEN
29575 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
29577 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
29578 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
29586 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29587 VCTN=VVAR*(ANEG+APOS)/ANEG
29588 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
29590 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29591 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
29593 ELSEIF(MVAR.EQ.2) THEN
29594 RMNMIN=MAX(RM34,RSQM-CTNMIN)
29595 RMNMAX=MAX(RM34,RSQM-CTNMAX)
29596 RMPMIN=MAX(RM34,RSQM-CTPMIN)
29597 RMPMAX=MAX(RM34,RSQM-CTPMAX)
29598 ANEG=LOG(RMNMIN/RMNMAX)
29599 APOS=LOG(RMPMIN/RMPMAX)
29600 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29601 VCTN=VVAR*(ANEG+APOS)/ANEG
29602 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
29604 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29605 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
29607 ELSEIF(MVAR.EQ.3) THEN
29608 RMNMIN=MAX(RM34,RSQM+CTNMIN)
29609 RMNMAX=MAX(RM34,RSQM+CTNMAX)
29610 RMPMIN=MAX(RM34,RSQM+CTPMIN)
29611 RMPMAX=MAX(RM34,RSQM+CTPMAX)
29612 ANEG=LOG(RMNMAX/RMNMIN)
29613 APOS=LOG(RMPMAX/RMPMIN)
29614 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29615 VCTN=VVAR*(ANEG+APOS)/ANEG
29616 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
29618 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29619 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
29621 ELSEIF(MVAR.EQ.4) THEN
29622 RMNMIN=MAX(RM34,RSQM-CTNMIN)
29623 RMNMAX=MAX(RM34,RSQM-CTNMAX)
29624 RMPMIN=MAX(RM34,RSQM-CTPMIN)
29625 RMPMAX=MAX(RM34,RSQM-CTPMAX)
29626 ANEG=1D0/RMNMAX-1D0/RMNMIN
29627 APOS=1D0/RMPMAX-1D0/RMPMIN
29628 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29629 VCTN=VVAR*(ANEG+APOS)/ANEG
29630 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
29632 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29633 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
29635 ELSEIF(MVAR.EQ.5) THEN
29636 RMNMIN=MAX(RM34,RSQM+CTNMIN)
29637 RMNMAX=MAX(RM34,RSQM+CTNMAX)
29638 RMPMIN=MAX(RM34,RSQM+CTPMIN)
29639 RMPMAX=MAX(RM34,RSQM+CTPMAX)
29640 ANEG=1D0/RMNMIN-1D0/RMNMAX
29641 APOS=1D0/RMPMIN-1D0/RMPMAX
29642 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29643 VCTN=VVAR*(ANEG+APOS)/ANEG
29644 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
29646 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29647 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
29650 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
29651 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
29654 C...Convert VVAR to tau' variable.
29655 ELSEIF(IVAR.EQ.4) THEN
29659 IF(MINT(47).EQ.1) THEN
29661 ELSEIF(MVAR.EQ.1) THEN
29662 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29663 ELSEIF(MVAR.EQ.2) THEN
29664 AUPP=(1D0-TAU/TAUPMX)**4
29665 ALOW=(1D0-TAU/TAUPMN)**4
29666 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29667 ELSEIF(MINT(47).EQ.5) THEN
29668 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29669 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29670 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29672 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29673 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29674 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29676 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29678 C...Selection of extra variables needed in 2 -> 3 process:
29679 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29680 C...Since no options are available, the functions of PYKLIM
29681 C...and PYKMAP are joint for these choices.
29682 ELSEIF(IVAR.EQ.5) THEN
29684 C...Read out total energy and particle masses.
29687 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29688 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29690 SHP=VINT(26)*VINT(2)
29694 PM3=SQRT(VINT(21))*VINT(1)
29695 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29702 C...Specify coefficients of pT choice; upper and lower limits.
29703 IF(MPTPK.EQ.1) THEN
29711 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29713 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29715 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29717 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29720 C...Select transverse momenta according to
29721 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29724 IF(HMX.LT.1.0001D0*HMN) THEN
29730 IF(RPT.LT.HWT1) THEN
29731 PTS1=PTSMN1+PYR(0)*HDE
29732 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29733 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29735 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29737 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29738 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29741 IF(HMX.LT.1.0001D0*HMN) THEN
29747 IF(RPT.LT.HWT1) THEN
29748 PTS2=PTSMN2+PYR(0)*HDE
29749 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29750 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29752 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29754 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29755 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29757 C...Select azimuthal angles and check pT choice.
29758 PHI1=PARU(2)*PYR(0)
29759 PHI2=PARU(2)*PYR(0)
29761 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29762 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29763 & CKIN(56)**2)) THEN
29768 C...Calculate transverse masses and check phase space not closed.
29775 PM12=(PMT1+PMT2)**2
29776 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29781 C...Select rapidity for particle 3 and check phase space not closed.
29782 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29783 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29784 IF(Y3MAX.LT.1D-6) THEN
29788 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29792 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29795 PMS12=PE12**2-PZ12**2
29796 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29797 IF(SQL12.LT.1D-6*SHP) THEN
29801 PMM1=PMS12+PMS1-PMS2
29802 PMM2=PMS12+PMS2-PMS1
29803 TFAC=-SHPR/(2D0*PMS12)
29804 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29805 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29806 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29807 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29809 C...Construct relative mirror weights and make choice.
29810 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29814 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29815 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29817 WTP=WTPU/(WTPU+WTNU)
29818 WTN=WTNU/(WTPU+WTNU)
29820 IF(WTN.GT.PYR(0)) EPS=-1D0
29822 C...Store result of variable choice and associated weights.
29832 IF(EPS.GT.0D0) THEN
29841 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29842 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29843 VINT(219)=0.5D0*(PMS12-PTS3)
29850 C***********************************************************************
29853 C...Differential matrix elements for all included subprocesses
29854 C...Note that what is coded is (disregarding the COMFAC factor)
29855 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29856 C...when d(sigma-hat) is given in the zero-width limit, the delta
29857 C...function in tau is replaced by a (modified) Breit-Wigner:
29858 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29859 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29860 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29861 C...i.e., dimensionless quantities
29862 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29863 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29864 C...(2pi)^4 delta^4(P - sum p_i)
29865 C...COMFAC contains the factor pi/s (or equivalent) and
29866 C...the conversion factor from GeV^-2 to mb
29868 SUBROUTINE PYSIGH(NCHN,SIGS)
29870 C...Double precision and integer declarations
29871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29872 IMPLICIT INTEGER(I-N)
29873 INTEGER PYK,PYCHGE,PYCOMP
29874 C...Parameter statement to help give large particle numbers.
29875 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29876 &KEXCIT=4000000,KDIMEN=5000000)
29878 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29879 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29880 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29881 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29882 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29883 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29884 COMMON/PYINT1/MINT(400),VINT(400)
29885 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29886 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29887 COMMON/PYINT4/MWID(500),WIDS(500,5)
29888 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29889 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29890 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29891 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29892 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29893 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29894 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29895 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29896 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29897 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29898 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29899 COMMON/PYTCCO/COEFX(194:380,2)
29900 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29901 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29902 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29903 C...Local arrays and complex variables
29904 DIMENSION XPQ(-25:25)
29906 C...Map of processes onto which routine to call
29907 C...in order to evaluate cross section:
29908 C...0 = not implemented;
29909 C...1 = standard QCD (including photons);
29910 C...2 = heavy flavours;
29912 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29914 C...6 = Technicolor;
29915 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29916 C...8 = Universal Extra Dimensions
29917 DIMENSION MAPPR(500)
29918 DATA (MAPPR(I),I=1,180)/
29919 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29920 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29921 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29922 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29923 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29924 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29925 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29926 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29927 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29928 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29929 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29930 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29931 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29932 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29933 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29934 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29935 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29936 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29937 DATA (MAPPR(I),I=181,500)/
29938 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29939 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29941 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29942 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29944 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29945 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29946 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29947 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29948 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29949 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29951 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29952 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29954 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29955 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29958 C...Reset number of channels and cross-section
29962 C...Read process to consider.
29967 C...Read kinematical variables and limits
29985 C...Derive kinematical quantities
29987 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29988 X(1)=SQRT(TAUE)*EXP(YST)
29989 X(2)=SQRT(TAUE)*EXP(-YST)
29990 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29991 IF(X(1).GT.1D0-1D-7) RETURN
29992 ELSEIF(MINT(45).EQ.3) THEN
29993 X(1)=MIN(1D0-1.1D-10,X(1))
29995 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29996 IF(X(2).GT.1D0-1D-7) RETURN
29997 ELSEIF(MINT(46).EQ.3) THEN
29998 X(2)=MIN(1D0-1.1D-10,X(2))
30000 SH=MAX(1D0,TAU*VINT(2))
30005 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
30006 RPTS=4D0*VINT(71)**2/SH
30007 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
30008 RM34=MAX(1D-20,2D0*RM3*RM4)
30010 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
30011 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
30012 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
30013 IF(ISTSB.EQ.0) THEN
30015 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
30016 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
30018 C...Kinematics with incoming masses tricky: now depends on how
30019 C...subprocess has been set up w.r.t. order of incoming partons.
30021 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
30023 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
30024 IF(ISUB.EQ.35) THEN
30028 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
30029 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
30030 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
30032 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
30034 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
30041 C...Choice of Q2 scale for hard process (e.g. alpha_s).
30042 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
30044 ELSEIF(ISTSB.EQ.8) THEN
30045 IF(MINT(107).EQ.4) Q2=VINT(307)
30046 IF(MINT(108).EQ.4) Q2=VINT(308)
30047 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
30049 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
30051 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
30052 IF(MSTP(32).EQ.1) THEN
30053 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
30054 ELSEIF(MSTP(32).EQ.2) THEN
30055 Q2=SQPTH+0.5D0*(SQM3+SQM4)
30056 ELSEIF(MSTP(32).EQ.3) THEN
30058 ELSEIF(MSTP(32).EQ.4) THEN
30060 ELSEIF(MSTP(32).EQ.5) THEN
30062 ELSEIF(MSTP(32).EQ.6) THEN
30064 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
30066 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
30067 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
30068 & (SQPTH+0.5D0*(SQM3+SQM4))
30069 ELSEIF(MSTP(32).EQ.7) THEN
30070 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
30071 ELSEIF(MSTP(32).EQ.8) THEN
30072 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
30073 ELSEIF(MSTP(32).EQ.9) THEN
30074 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
30075 ELSEIF(MSTP(32).EQ.10) THEN
30078 ELSEIF(MSTP(32).EQ.11) THEN
30079 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
30080 ELSEIF(MSTP(32).EQ.12) THEN
30083 ELSEIF(MSTP(32).EQ.13) THEN
30086 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
30087 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
30088 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
30091 C...Choice of Q2 scale for parton densities.
30094 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
30095 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
30098 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
30100 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
30101 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
30102 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
30103 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
30104 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
30105 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
30106 IF(MSTP(39).EQ.2) Q2SF=
30107 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
30108 IF(MSTP(39).EQ.3) Q2SF=SH
30109 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
30110 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
30112 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
30113 IF(MSTP(39).EQ.7) Q2SF=
30114 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
30115 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
30119 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
30123 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
30124 IF(MSTP(69).GE.2) Q2SF=VINT(2)
30126 C...Identify to which class(es) subprocess belongs
30130 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
30131 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
30132 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
30133 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
30134 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
30135 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
30136 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
30137 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
30138 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
30139 IF (ISTSB.EQ.9) ISQCD=1
30140 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
30141 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
30142 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
30143 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
30144 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
30145 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
30146 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
30147 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
30148 C...WBF is special case of ISJETS
30149 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
30150 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
30151 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
30152 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
30153 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
30154 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
30155 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
30156 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
30157 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
30158 C...Some processes with photons also belong here.
30159 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
30160 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
30161 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
30162 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
30163 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
30164 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
30166 C...Choice of Q2 scale for parton-shower activity.
30167 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
30168 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
30170 IF(MINT(43).EQ.3) XBJ=X(1)
30171 IF(MSTP(22).EQ.1) THEN
30173 ELSEIF(MSTP(22).EQ.2) THEN
30174 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
30175 ELSEIF(MSTP(22).EQ.3) THEN
30176 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
30178 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
30181 C...For multiple interactions, start from scale defined above
30182 C...For all other QCD or "+jets"-type events, start shower from pThard.
30183 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
30184 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
30185 C...Max shower scale = s for ME corrected processes.
30186 C...(pT-ordering: max pT2 is s/4)
30188 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
30189 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
30190 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
30191 C...(pT-ordering: max pT2 is s/4)
30193 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
30195 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
30197 C...Elastic and diffractive events not associated with scales so set 0.
30198 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
30203 C...Store derived kinematical quantities
30210 IF(ISTSB.NE.8) VINT(48)=SQPTH
30211 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
30212 VINT(50)=TAUP*VINT(2)
30213 VINT(49)=SQRT(MAX(0D0,VINT(50)))
30217 VINT(53)=SQRT(Q2SF)
30219 VINT(55)=SQRT(Q2PS)
30221 C...Set starting scale for multiple interactions
30222 IF (ISUBSV.EQ.95) THEN
30224 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
30225 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
30226 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
30227 & ISUBSV.NE.96)) THEN
30228 C...All accessible phase space allowed.
30229 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
30231 C...Scale of hard process sets limit.
30232 C...2 -> 1. Limit is tau = x1*x2.
30233 C...2 -> 2. Limit is XT2 for hard process + FS masses.
30234 C...2 -> n > 2. Limit is tau' = tau of outer process.
30236 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
30238 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
30239 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
30241 VINT(62)=0.25D0*XT2GMX*VINT(2)
30242 VINT(61)=SQRT(MAX(0D0,VINT(62)))
30244 C...Calculate parton distributions
30245 IF(ISTSB.LE.0) GOTO 160
30246 IF(MINT(47).GE.2) THEN
30247 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
30249 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
30250 IF(ISUB.EQ.99) THEN
30251 IF(MINT(140+I).EQ.0) THEN
30252 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
30254 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
30259 MINT(105)=MINT(102+I)
30260 MINT(109)=MINT(106+I)
30261 VINT(120)=VINT(2+I)
30262 C...Default is to use standard PDFs, but for interactions after the first
30263 C...in the new multiple-parton-interactions framework, set which side to
30264 C...evaluate the MPI-modified PDFs on.
30266 IF (MINT(31).GE.1) MINT(30)=I
30268 C.... Store side in MINT(124)
30271 IF(MSTP(57).LE.1) THEN
30272 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
30274 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
30276 C...Safety margin against heavy flavour very close to threshold,
30277 C...e.g. caused by mismatch in c and b masses.
30278 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
30282 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
30287 XSFX(I,KFL)=XPQ(KFL)
30292 C...Calculate alpha_em, alpha_strong and K-factor
30295 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
30296 &1D0-(PMAS(24,1)/PMAS(23,1))**2
30298 XWC=1D0/(16D0*XW*XW1)
30300 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
30301 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
30304 IF(MSTP(33).EQ.1) THEN
30306 ELSEIF(MSTP(33).EQ.2) THEN
30308 FACA=PARP(32)/PARP(31)
30309 ELSEIF(MSTP(33).EQ.3) THEN
30311 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
30312 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
30314 C...PS (12 Feb 2010)
30315 C...New options MSTP(33) = 10 and 11
30316 C... 10: use K-factor = PARP(32) only for process 96 (MPI)
30317 C... 11: as for 10, but also use K-factor = PARP(31) for other procs
30318 ELSEIF(MSTP(33).GE.10) THEN
30319 IF (ISUB.EQ.96) THEN
30321 ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN
30329 C...Set flags for allowed reacting partons/leptons
30334 IF(MINT(44+I).EQ.1) THEN
30335 KFAC(I,MINT(10+I))=1
30336 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
30337 KFAC(I,MINT(10+I))=1
30343 KFAC(I,J)=KFIN(I,J)
30344 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
30345 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
30350 C...Lower and upper limit for fermion flavour loops
30356 IF(KFAC(1,-J).EQ.1) MMIN1=-J
30357 IF(KFAC(1,J).EQ.1) MMAX1=J
30358 IF(KFAC(2,-J).EQ.1) MMIN2=-J
30359 IF(KFAC(2,J).EQ.1) MMAX2=J
30361 MMINA=MIN(MMIN1,MMIN2)
30362 MMAXA=MAX(MMAX1,MMAX2)
30364 C...Common resonance mass and width combinations
30367 GMMZ=PMAS(23,1)*PMAS(23,2)
30368 GMMW=PMAS(24,1)*PMAS(24,2)
30370 C...Polarization factors...implemented so far for W+W-(25)
30371 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
30372 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
30373 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
30374 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
30376 C...Phase space integral in tau
30377 COMFAC=PARU(1)*PARU(5)/VINT(2)
30378 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
30379 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
30380 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
30381 ATAU1=LOG(TAUMAX/TAUMIN)
30382 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
30383 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
30384 IF(MINT(72).GE.1) THEN
30387 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
30389 IF(ATAUD.GT.1D-10) H1=H1+
30390 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
30391 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
30393 IF(ATAUD.GT.1D-10) H1=H1+
30394 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
30396 IF(MINT(72).GE.2) THEN
30399 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
30401 IF(ATAUD.GT.1D-10) H1=H1+
30402 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
30403 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
30405 IF(ATAUD.GT.1D-10) H1=H1+
30406 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
30408 IF(MINT(72).EQ.3) THEN
30411 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
30413 IF(ATAUD.GT.1D-10) H1=H1+
30414 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
30415 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
30417 IF(ATAUD.GT.1D-10) H1=H1+
30418 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
30420 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
30421 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
30422 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
30423 & MAX(2D-10,1D0-TAU)
30424 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
30425 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
30426 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
30427 & MAX(1D-10,1D0-TAU)
30429 COMFAC=COMFAC*ATAU1/(TAU*H1)
30432 C...Phase space integral in y*
30433 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
30435 AYST0=YSTMAX-YSTMIN
30436 IF(AYST0.LT.1D-10) THEN
30439 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
30441 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
30442 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
30443 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
30444 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
30445 IF(MINT(45).EQ.3) THEN
30446 YST0=-0.5D0*LOG(TAUE)
30447 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
30448 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
30449 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
30450 & MAX(1D-10,1D0-EXP(YST-YST0))
30452 IF(MINT(46).EQ.3) THEN
30453 YST0=-0.5D0*LOG(TAUE)
30454 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
30455 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
30456 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
30457 & MAX(1D-10,1D0-EXP(-YST-YST0))
30459 COMFAC=COMFAC*AYST0/H2
30463 C...2 -> 1 processes: reduction in angular part of phase space integral
30464 C...for case of decaying resonance
30465 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
30466 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
30467 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
30468 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
30469 & KFPR(ISUB,1).EQ.39) THEN
30470 COMFAC=COMFAC*0.5D0*ACTH0
30472 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
30473 & CTPMAX**3-CTPMIN**3)
30477 C...2 -> 2 processes: angular part of phase space integral
30478 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
30479 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
30480 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
30481 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
30482 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
30483 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
30484 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
30485 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
30486 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
30487 H3=COEF(ISUBSV,13)+
30488 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
30489 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
30490 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
30491 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
30492 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
30494 C...2 -> 2 processes: take into account final state Breit-Wigners
30495 COMFAC=COMFAC*VINT(80)
30498 C...2 -> 3, 4 processes: phace space integral in tau'
30499 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
30500 ATAUP1=LOG(TAUPMX/TAUPMN)
30501 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
30502 H4=COEF(ISUBSV,18)+
30503 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
30504 IF(MINT(47).EQ.5) THEN
30505 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
30506 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
30507 ELSEIF(MINT(47).GE.6) THEN
30508 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
30509 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
30511 COMFAC=COMFAC*ATAUP1/H4
30514 C...2 -> 3, 4 processes: effective W/Z parton distributions
30515 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
30516 IF(1D0-TAU/TAUP.GT.1D-4) THEN
30517 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
30519 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
30524 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
30525 IF(ISTSB.EQ.5) THEN
30526 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
30527 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
30530 C...Phase space integral for low-pT and multiple interactions
30531 IF(ISTSB.EQ.9) THEN
30532 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
30533 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
30534 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
30535 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
30536 COMFAC=COMFAC*ATAU1/H1
30537 AYST0=YSTMAX-YSTMIN
30538 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
30539 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
30540 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
30541 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
30542 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
30543 COMFAC=COMFAC*AYST0/H2
30544 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
30545 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
30546 C...introduced to make cross-section finite for xT2 -> 0
30547 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
30551 C...Real gamma + gamma: include factor 2 when different nature
30552 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
30553 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
30555 C...Extra factors to include the effects of
30556 C...longitudinal resolved photons (but not direct or DIS ones).
30558 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
30559 & MINT(106+ISDE).LE.3) THEN
30562 IF(MSTP(16).EQ.0) THEN
30563 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
30564 & XY=VINT(304+ISDE)
30566 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
30567 & XY=VINT(308+ISDE)
30569 Q2GA=VINT(306+ISDE)
30570 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
30571 & Q2GA.GT.0D0) THEN
30573 IF(MSTP(17).EQ.1) THEN
30574 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
30575 ELSEIF(MSTP(17).EQ.2) THEN
30576 REDUCE=4D0*Q2GA/(Q2+Q2GA)
30577 ELSEIF(MSTP(17).EQ.3) THEN
30578 PMVIRT=PMAS(PYCOMP(113),1)
30579 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30580 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
30581 PMVIRT=PMAS(PYCOMP(113),1)
30582 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
30583 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
30584 PMVIRT=PMAS(PYCOMP(113),1)
30585 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
30586 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
30587 PMVSMN=4D0*PARP(15)**2
30588 PMVSMX=4D0*VINT(154)**2
30589 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
30590 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
30591 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
30592 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
30593 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
30594 PMVIRT=PMAS(PYCOMP(113),1)
30595 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30596 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
30597 PMVIRT=PMAS(PYCOMP(113),1)
30598 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30599 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
30600 PMVSMN=4D0*PARP(15)**2
30601 PMVSMX=4D0*VINT(154)**2
30602 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
30603 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
30604 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
30607 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
30608 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
30609 & (1D0-2D0*BEAMAS**2/Q2GA))
30610 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
30615 COMFAC=COMFAC*VINT(314+ISDE)
30618 C...Evaluate cross sections - done in separate routines by kind
30619 C...of physics, to keep PYSIGH of sensible size.
30621 C...Standard QCD (including photons).
30622 CALL PYSGQC(NCHN,SIGS)
30623 ELSEIF(MAP.EQ.2) THEN
30624 C...Heavy flavours.
30625 CALL PYSGHF(NCHN,SIGS)
30626 ELSEIF(MAP.EQ.3) THEN
30628 CALL PYSGWZ(NCHN,SIGS)
30629 ELSEIF(MAP.EQ.4) THEN
30630 C...Higgs (2 doublets; including longitudinal W/Z scattering).
30631 CALL PYSGHG(NCHN,SIGS)
30632 ELSEIF(MAP.EQ.5) THEN
30634 CALL PYSGSU(NCHN,SIGS)
30635 ELSEIF(MAP.EQ.6) THEN
30637 CALL PYSGTC(NCHN,SIGS)
30638 ELSEIF(MAP.EQ.7) THEN
30639 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
30640 CALL PYSGEX(NCHN,SIGS)
30641 ELSEIF(MAP.EQ.8) THEN
30642 C... Universal Extra Dimensions
30643 CALL PYXUED(NCHN,SIGS)
30646 C...Multiply with parton distributions
30647 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
30649 IF(MINT(45).GE.2) THEN
30651 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
30653 IF(MINT(46).GE.2) THEN
30655 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
30657 SIGS=SIGS+SIGH(ICHN)
30664 C*********************************************************************
30667 C...Subprocess cross sections for QCD processes,
30668 C...including photons.
30669 C...Auxiliary to PYSIGH.
30671 SUBROUTINE PYSGQC(NCHN,SIGS)
30673 C...Double precision and integer declarations
30674 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30675 IMPLICIT INTEGER(I-N)
30676 INTEGER PYK,PYCHGE,PYCOMP
30677 C...Parameter statement to help give large particle numbers.
30678 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30679 &KEXCIT=4000000,KDIMEN=5000000)
30681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30682 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30683 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30684 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30685 COMMON/PYINT1/MINT(400),VINT(400)
30686 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30687 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30688 COMMON/PYINT4/MWID(500),WIDS(500,5)
30689 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30690 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30691 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30692 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30693 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30694 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30695 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30697 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30699 C...Differential cross section expressions.
30701 IF(ISUB.LE.20) THEN
30702 IF(ISUB.EQ.10) THEN
30703 C...f + f' -> f + f' (gamma/Z/W exchange)
30704 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30705 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30706 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30707 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30708 DO 110 I=MMIN1,MMAX1
30709 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30711 DO 100 J=MMIN2,MMAX2
30712 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30714 C...Electroweak couplings
30715 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30716 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30718 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30719 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30722 C...gamma/Z exchange, only gamma exchange, or only Z exchange
30723 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30724 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30725 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30726 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30727 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30728 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30729 ELSEIF(MSTP(21).EQ.2) THEN
30730 FACNCF=FACGGF*EI**2*EJ**2
30732 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30733 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30735 C...Extrafactor 2 for only one incoming neutrino spin state.
30736 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30737 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30745 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30746 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30747 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30748 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30749 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30759 ELSEIF(ISUB.EQ.11) THEN
30760 C...f + f' -> f + f' (g exchange)
30761 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30762 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30763 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30764 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30765 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30766 DO 130 I=MMIN1,MMAX1
30768 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30769 DO 120 J=MMIN2,MMAX2
30771 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30777 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30779 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30784 SIGH(NCHN)=0.5D0*FACQQ2
30789 ELSEIF(ISUB.EQ.12) THEN
30790 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30791 CALL PYWIDT(21,SH,WDTP,WDTE)
30792 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30793 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30794 DO 140 I=MMINA,MMAXA
30795 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30796 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30804 ELSEIF(ISUB.EQ.13) THEN
30805 C...f + fbar -> g + g (q + qbar -> g + g only)
30806 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30808 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30810 DO 150 I=MMINA,MMAXA
30811 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30812 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30817 SIGH(NCHN)=0.5D0*FACGG1
30822 SIGH(NCHN)=0.5D0*FACGG2
30825 ELSEIF(ISUB.EQ.14) THEN
30826 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30827 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30828 DO 160 I=MMINA,MMAXA
30829 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30830 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30831 EI=KCHG(IABS(I),1)/3D0
30836 SIGH(NCHN)=FACGG*EI**2
30839 ELSEIF(ISUB.EQ.18) THEN
30840 C...f + fbar -> gamma + gamma
30841 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30842 DO 170 I=MMINA,MMAXA
30843 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30844 EI=KCHG(IABS(I),1)/3D0
30846 IF(IABS(I).LE.10) FCOI=FACA/3D0
30851 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30855 ELSEIF(ISUB.LE.40) THEN
30856 IF(ISUB.EQ.28) THEN
30857 C...f + g -> f + g (q + g -> q + g only)
30858 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30860 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30862 DO 190 I=MMINA,MMAXA
30863 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30865 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30866 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30869 ISIG(NCHN,3-ISDE)=21
30874 ISIG(NCHN,3-ISDE)=21
30880 ELSEIF(ISUB.EQ.29) THEN
30881 C...f + g -> f + gamma (q + g -> q + gamma only)
30882 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30883 DO 210 I=MMINA,MMAXA
30884 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30885 EI=KCHG(IABS(I),1)/3D0
30888 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30889 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30892 ISIG(NCHN,3-ISDE)=21
30898 ELSEIF(ISUB.EQ.33) THEN
30899 C...f + gamma -> f + g (q + gamma -> q + g only)
30900 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30901 DO 230 I=MMINA,MMAXA
30902 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30903 EI=KCHG(IABS(I),1)/3D0
30906 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30907 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30910 ISIG(NCHN,3-ISDE)=22
30916 ELSEIF(ISUB.EQ.34) THEN
30917 C...f + gamma -> f + gamma
30918 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30919 DO 250 I=MMINA,MMAXA
30920 IF(I.EQ.0) GOTO 250
30921 EI=KCHG(IABS(I),1)/3D0
30924 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30925 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30928 ISIG(NCHN,3-ISDE)=22
30935 ELSEIF(ISUB.LE.80) THEN
30936 IF(ISUB.EQ.53) THEN
30937 C...g + g -> f + fbar (g + g -> q + qbar only)
30938 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30940 C...Begin by d, u, s flavours.
30942 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30943 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30944 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30945 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30946 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30947 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30948 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30949 & UH2/SH2)*FLAVWT*FACA
30950 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30951 & TH2/SH2)*FLAVWT*FACA
30962 C...Next c and b flavours: modified that and uhat for fixed
30963 C...cos(theta-hat).
30965 SQMAVG=PMAS(IFL,1)**2
30966 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30967 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30968 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30969 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30970 THUHQ=THQ*UHQ-SQMAVG*SH
30971 IF(MSTP(34).EQ.0) THEN
30972 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30973 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30975 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30976 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30977 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30978 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30980 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30981 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30985 ISIG(NCHN,3)=1+2*(IFL-3)
30990 ISIG(NCHN,3)=2+2*(IFL-3)
30996 ELSEIF(ISUB.EQ.54) THEN
30997 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30998 CALL PYWIDT(21,SH,WDTP,WDTE)
31000 DO 280 I=1,MIN(8,MDCY(21,3))
31002 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31005 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
31006 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31013 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31021 ELSEIF(ISUB.EQ.58) THEN
31022 C...gamma + gamma -> f + fbar
31023 CALL PYWIDT(22,SH,WDTP,WDTE)
31025 DO 290 I=1,MIN(12,MDCY(22,3))
31026 IF(I.LE.8) EF= KCHG(I,1)/3D0
31027 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
31028 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31031 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
31032 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31040 ELSEIF(ISUB.EQ.68) THEN
31042 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
31043 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
31045 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
31047 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
31053 SIGH(NCHN)=0.5D0*FACGG1
31058 SIGH(NCHN)=0.5D0*FACGG2
31063 SIGH(NCHN)=0.5D0*FACGG3
31066 ELSEIF(ISUB.EQ.80) THEN
31067 C...q + gamma -> q' + pi+/-
31068 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
31069 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
31070 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
31071 DELSH=UH*SQRT(ASSH*Q2FPSH)
31072 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
31073 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
31074 DELUH=SH*SQRT(ASUH*Q2FPUH)
31075 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
31076 IF(I.EQ.0) GOTO 320
31077 EI=KCHG(IABS(I),1)/3D0
31078 EJ=SIGN(1D0-ABS(EI),EI)
31080 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
31081 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
31084 ISIG(NCHN,3-ISDE)=22
31086 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
31091 ELSEIF(ISUB.LE.100) THEN
31092 IF(ISUB.EQ.91) THEN
31093 C...Elastic scattering
31094 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
31096 ELSEIF(ISUB.EQ.92) THEN
31097 C...Single diffractive scattering (first side, i.e. XB)
31098 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
31100 ELSEIF(ISUB.EQ.93) THEN
31101 C...Single diffractive scattering (second side, i.e. AX)
31102 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
31104 ELSEIF(ISUB.EQ.94) THEN
31105 C...Double diffractive scattering
31106 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
31108 ELSEIF(ISUB.EQ.95) THEN
31109 C...Low-pT scattering
31110 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
31112 ELSEIF(ISUB.EQ.96) THEN
31113 C...Multiple interactions: sum of QCD processes
31114 CALL PYWIDT(21,SH,WDTP,WDTE)
31116 C...q + q' -> q + q'
31117 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
31118 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
31119 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
31120 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
31121 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
31122 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
31124 IF(I.EQ.0) GOTO 340
31126 IF(J.EQ.0) GOTO 330
31132 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
31134 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
31139 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
31144 C...q + qbar -> q' + qbar' or g + g
31145 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
31146 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
31147 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
31149 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
31152 IF(I.EQ.0) GOTO 350
31162 SIGH(NCHN)=0.5D0*FACGG1
31167 SIGH(NCHN)=0.5D0*FACGG2
31171 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
31173 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
31176 IF(I.EQ.0) GOTO 370
31180 ISIG(NCHN,3-ISDE)=21
31185 ISIG(NCHN,3-ISDE)=21
31191 C...g + g -> q + qbar (only d, u, s)
31194 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
31195 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
31196 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
31197 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
31198 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
31199 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
31200 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
31201 & UH2/SH2)*FLAVWT*FACA
31202 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
31203 & TH2/SH2)*FLAVWT*FACA
31215 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
31218 SQMAVG=PMAS(IFL,1)**2
31219 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
31220 BE34=SQRT(1D0-4D0*SQMAVG/SH)
31221 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31222 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31223 THUHQ=THQ*UHQ-SQMAVG*SH
31224 IF(MSTP(34).EQ.0) THEN
31225 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
31226 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
31228 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31229 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
31230 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31231 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
31233 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
31234 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
31238 ISIG(NCHN,3)=531+2*(IFL-3)
31243 ISIG(NCHN,3)=532+2*(IFL-3)
31249 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
31250 & 2D0*TH/SH+TH2/SH2)*FACA
31251 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
31252 & 2D0*SH/UH+SH2/UH2)*FACA
31253 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
31254 & 2D0*UH/TH+UH2/TH2)
31259 SIGH(NCHN)=0.5D0*FACGG1
31264 SIGH(NCHN)=0.5D0*FACGG2
31269 SIGH(NCHN)=0.5D0*FACGG3
31271 ELSEIF(ISUB.EQ.99) THEN
31272 C...f + gamma* -> f.
31273 IF(MINT(107).EQ.4) THEN
31282 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
31283 PM2RHO=PMAS(PYCOMP(113),1)**2
31284 IF(MSTP(19).EQ.0) THEN
31286 ELSEIF(MSTP(19).EQ.1) THEN
31287 COMFAC=COMFAC/(Q2GA+PM2RHO)
31288 ELSEIF(MSTP(19).EQ.2) THEN
31289 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
31291 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
31293 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
31294 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
31295 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
31296 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
31298 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
31300 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
31302 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
31303 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
31305 DO 390 I=MMINA,MMAXA
31306 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
31307 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
31308 EI=KCHG(IABS(I),1)/3D0
31311 ISIG(NCHN,3-ISDE)=22
31313 SIGH(NCHN)=COMFAC*EI**2
31318 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
31319 C...g + g -> gamma + gamma or g + g -> g + gamma
31334 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
31336 EI=KCHG(IABS(I),1)/3D0
31338 IF(ISUB.EQ.115) EIWT=EI
31343 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
31344 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
31347 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
31348 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
31349 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
31350 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
31356 CALL PYWAUX(1,EPSS,W1SR,W1SI)
31357 CALL PYWAUX(1,EPST,W1TR,W1TI)
31358 CALL PYWAUX(1,EPSU,W1UR,W1UI)
31359 CALL PYWAUX(2,EPSS,W2SR,W2SI)
31360 CALL PYWAUX(2,EPST,W2TR,W2TI)
31361 CALL PYWAUX(2,EPSU,W2UR,W2UI)
31362 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
31363 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
31364 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
31365 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
31366 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
31367 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
31368 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
31369 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
31370 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
31371 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
31372 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
31373 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
31374 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
31375 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
31376 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
31377 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
31378 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
31379 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
31380 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
31381 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
31382 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
31383 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
31384 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
31385 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
31386 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
31387 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
31388 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
31389 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
31390 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
31391 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
31392 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
31393 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
31394 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
31395 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
31396 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
31397 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
31398 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
31399 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
31400 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
31401 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
31402 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
31403 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
31404 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
31405 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
31406 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
31407 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
31408 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
31409 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
31410 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
31411 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
31412 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
31413 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
31414 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
31415 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
31416 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
31417 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
31419 A0STUR=A0STUR+EIWT*B0STUR
31420 A0STUI=A0STUI+EIWT*B0STUI
31421 A0TSUR=A0TSUR+EIWT*B0TSUR
31422 A0TSUI=A0TSUI+EIWT*B0TSUI
31423 A0UTSR=A0UTSR+EIWT*B0UTSR
31424 A0UTSI=A0UTSI+EIWT*B0UTSI
31425 A1STUR=A1STUR+EIWT*B1STUR
31426 A1STUI=A1STUI+EIWT*B1STUI
31427 A2STUR=A2STUR+EIWT*B2STUR
31428 A2STUI=A2STUI+EIWT*B2STUI
31430 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
31431 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
31432 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
31433 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
31434 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
31439 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
31440 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
31443 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
31444 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
31446 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31448 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31450 IF(ISUB.EQ.131) THEN
31451 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
31452 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
31454 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
31456 DO 430 I=MMINA,MMAXA
31457 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
31458 EI=KCHG(IABS(I),1)/3D0
31461 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
31462 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
31465 ISIG(NCHN,3-ISDE)=22
31471 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
31472 C...f + gamma*_(T,L) -> f + gamma
31474 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31476 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31478 IF(ISUB.EQ.133) THEN
31479 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
31480 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
31482 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
31484 DO 450 I=MMINA,MMAXA
31485 IF(I.EQ.0) GOTO 450
31486 EI=KCHG(IABS(I),1)/3D0
31489 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
31490 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
31493 ISIG(NCHN,3-ISDE)=22
31499 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
31500 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
31502 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31504 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31506 CALL PYWIDT(21,SH,WDTP,WDTE)
31508 DO 460 I=1,MIN(8,MDCY(21,3))
31510 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31513 IF(ISUB.EQ.135) THEN
31514 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
31515 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
31517 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
31519 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31526 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31534 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
31535 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
31537 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
31539 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
31540 CALL PYWIDT(22,SH,WDTP,WDTE)
31542 DO 470 I=1,MIN(12,MDCY(22,3))
31543 IF(I.LE.8) EF= KCHG(I,1)/3D0
31544 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
31545 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31548 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
31549 IF(ISUB.EQ.137) THEN
31550 FPARAM=-SH*(TH+UH)/DLAMB2
31551 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
31552 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
31553 & 2D0*PH1*PH2*FPARAM**2)
31554 ELSEIF(ISUB.EQ.138) THEN
31555 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
31556 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
31557 & 2D0*PH1**2*(TH-UH)**2)
31558 ELSEIF(ISUB.EQ.139) THEN
31559 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
31560 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
31561 & 2D0*PH2**2*(TH-UH)**2)
31563 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
31564 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
31566 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31580 C*********************************************************************
31583 C...Subprocess cross sections for heavy flavour production,
31584 C...open and closed.
31585 C...Auxiliary to PYSIGH.
31587 SUBROUTINE PYSGHF(NCHN,SIGS)
31589 C...Double precision and integer declarations
31590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31591 IMPLICIT INTEGER(I-N)
31592 INTEGER PYK,PYCHGE,PYCOMP
31593 C...Parameter statement to help give large particle numbers.
31594 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31595 &KEXCIT=4000000,KDIMEN=5000000)
31597 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31598 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31599 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31600 COMMON/PYINT1/MINT(400),VINT(400)
31601 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31602 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31603 COMMON/PYINT4/MWID(500),WIDS(500,5)
31604 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31605 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31606 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31607 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31608 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
31611 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
31613 C...Determine where are charmonium/bottomonium wave function parameters.
31615 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
31617 C...Convert bottomonium process into equivalent charmonium ones.
31618 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
31620 C...Differential cross section expressions.
31622 IF(ISUB.LE.100) THEN
31623 IF(ISUB.EQ.81) THEN
31624 C...q + qbar -> Q + Qbar
31625 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31626 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31627 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31628 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
31630 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
31632 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31633 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31635 DO 100 I=MMINA,MMAXA
31636 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31637 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31645 ELSEIF(ISUB.EQ.82) THEN
31646 C...g + g -> Q + Qbar
31647 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31648 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31649 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31650 THUHQ=THQ*UHQ-SQMAVG*SH
31651 IF(MSTP(34).EQ.0) THEN
31652 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
31653 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
31655 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31656 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
31657 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31658 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
31660 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
31661 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
31662 IF(MSTP(35).GE.1) THEN
31663 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
31664 FACQQ1=FACQQ1*FATRE
31665 FACQQ2=FACQQ2*FATRE
31668 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31669 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31672 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31685 ELSEIF(ISUB.EQ.83) THEN
31686 C...f + q -> f' + Q
31687 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31688 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31689 DO 130 I=MMIN1,MMAX1
31690 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31691 DO 120 J=MMIN2,MMAX2
31692 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31693 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31694 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31695 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31701 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31702 & (IABS(I)+1)/2)*VINT(180+J)
31703 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31704 & (MINT(55)+1)/2)*VINT(180+J)
31707 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31708 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31711 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31712 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31715 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31716 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31718 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31724 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31725 & (IABS(J)+1)/2)*VINT(180+I)
31726 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31727 & (MINT(55)+1)/2)*VINT(180+I)
31730 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31731 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31734 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31735 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31738 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31739 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31744 ELSEIF(ISUB.EQ.84) THEN
31745 C...g + gamma -> Q + Qbar
31746 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31747 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31748 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31749 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31750 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31752 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31754 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31755 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31757 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31764 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31772 ELSEIF(ISUB.EQ.85) THEN
31773 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31774 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31775 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31776 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31777 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31778 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31779 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31780 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31781 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31782 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31783 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31785 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31786 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31787 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31789 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31797 ELSEIF(ISUB.EQ.86) THEN
31798 C...g + g -> J/Psi + g
31799 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31800 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31801 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31802 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31810 ELSEIF(ISUB.EQ.87) THEN
31811 C...g + g -> chi_0c + g
31812 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31813 QGTW=(SH*TH*UH)/SH**3
31815 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31816 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31817 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31818 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31819 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31820 & (QGTW*(QGTW-RGTW*PGTW)**4)
31821 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31829 ELSEIF(ISUB.EQ.88) THEN
31830 C...g + g -> chi_1c + g
31831 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31832 QGTW=(SH*TH*UH)/SH**3
31834 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31835 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31836 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31837 & (QGTW-RGTW*PGTW)**4
31838 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31846 ELSEIF(ISUB.EQ.89) THEN
31847 C...g + g -> chi_2c + g
31848 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31849 QGTW=(SH*TH*UH)/SH**3
31851 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31852 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31853 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31854 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31855 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31856 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31857 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31866 ELSEIF(ISUB.LE.200) THEN
31867 IF(ISUB.EQ.104) THEN
31868 C...g + g -> chi_c0.
31870 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31871 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31872 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31873 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31881 ELSEIF(ISUB.EQ.105) THEN
31882 C...g + g -> chi_c2.
31884 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31885 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31886 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31887 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31895 ELSEIF(ISUB.EQ.106) THEN
31896 C...g + g -> J/Psi + gamma.
31897 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31898 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31899 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31900 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31901 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31909 ELSEIF(ISUB.EQ.107) THEN
31910 C...g + gamma -> J/Psi + g.
31911 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31912 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31913 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31914 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31915 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31922 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31930 ELSEIF(ISUB.EQ.108) THEN
31931 C...gamma + gamma -> J/Psi + gamma.
31932 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31933 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31934 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31935 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31936 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31946 C...Additional code by Stefan Wolf
31949 C...Common code for quarkonium production.
31956 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31957 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31959 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31960 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31964 IF(MSTP(145).EQ.1) THEN
31965 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31966 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31967 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31968 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31969 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31970 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31971 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31972 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31973 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31974 & ISUB.GE.437) THEN
31975 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31976 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31977 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31978 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31979 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31980 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31984 SMQQ2=SQMQQ*VINT(2)
31985 C...Polarisation frames
31986 IF(MSTP(146).EQ.1) THEN
31988 POLH1=SQRT(AQ2-SMQQ2)
31989 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31992 AX=AQ*BQ/(POLH1*POLH2)
31994 ELSEIF(MSTP(146).EQ.2) THEN
31995 C...Gottfried Jackson frame
31997 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
32000 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
32001 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
32002 ELSEIF(MSTP(146).EQ.3) THEN
32005 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
32008 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
32009 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
32010 ELSEIF(MSTP(146).EQ.4) THEN
32011 C...Collins Soper frame
32013 POLH2=SQRT(VINT(2)*POLH1)
32016 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
32017 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
32019 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
32020 EL1K10=AZ*ATILK1+BZ*BTILK1
32021 EL1K20=AZ*ATILK2+BZ*BTILK2
32024 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
32025 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
32030 IF(ISUB.EQ.421) THEN
32031 C...g + g -> QQ~[3S11] + g
32032 IF(MSTP(145).EQ.0) THEN
32033 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32034 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
32035 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32036 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
32037 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32038 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
32040 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
32041 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
32045 IF(MSTP(147).EQ.0) THEN
32046 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32047 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32048 ELSEIF(MSTP(147).EQ.1) THEN
32049 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32050 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32051 ELSEIF(MSTP(147).EQ.3) THEN
32052 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32053 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32054 ELSEIF(MSTP(147).EQ.4) THEN
32055 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32056 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32057 ELSEIF(MSTP(147).EQ.5) THEN
32058 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32059 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32060 ELSEIF(MSTP(147).EQ.6) THEN
32061 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32062 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32064 FACQQG=COMFAC*FF*FACQQG
32066 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32071 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
32074 ELSEIF(ISUB.EQ.422) THEN
32075 C...g + g -> QQ~[3S18] + g
32076 IF(MSTP(145).EQ.0) THEN
32077 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
32078 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
32080 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
32082 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
32083 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
32084 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
32088 IF(MSTP(147).EQ.0) THEN
32089 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32090 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32091 ELSEIF(MSTP(147).EQ.1) THEN
32092 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32093 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32094 ELSEIF(MSTP(147).EQ.3) THEN
32095 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32096 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32097 ELSEIF(MSTP(147).EQ.4) THEN
32098 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32099 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32100 ELSEIF(MSTP(147).EQ.5) THEN
32101 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32102 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32103 ELSEIF(MSTP(147).EQ.6) THEN
32104 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32105 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32107 FACQQG=COMFAC*FF*FACQQG
32109 C...Split total contribution into different colour flows just like
32110 C...in g g -> g g (recalculate kinematics for massless partons).
32111 THP=-0.5D0*SH*(1D0-CTH)
32112 UHP=-0.5D0*SH*(1D0+CTH)
32113 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32114 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32115 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32116 FACGGS=FACGG1+FACGG2+FACGG3
32117 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32122 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
32127 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
32132 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
32135 ELSEIF(ISUB.EQ.423) THEN
32136 C...g + g -> QQ~[1S08] + g
32137 IF(MSTP(145).EQ.0) THEN
32138 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
32139 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
32140 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
32141 * & (SHTH2*THUH2*UHSH2)
32142 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
32143 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
32144 & TH2/(SHTH2*THUH2))*
32145 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
32147 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
32148 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
32149 & TH2/(SHTH2*THUH2))*
32150 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
32151 IF(MSTP(147).EQ.0) THEN
32153 ELSEIF(MSTP(147).EQ.1) THEN
32154 FACQQG=COMFAC*2D0*FA
32155 ELSEIF(MSTP(147).EQ.3) THEN
32157 ELSEIF(MSTP(147).EQ.4) THEN
32159 ELSEIF(MSTP(147).EQ.5) THEN
32161 ELSEIF(MSTP(147).EQ.6) THEN
32165 C...Split total contribution into different colour flows just like
32166 C...in g g -> g g (recalculate kinematics for massless partons).
32167 THP=-0.5D0*SH*(1D0-CTH)
32168 UHP=-0.5D0*SH*(1D0+CTH)
32169 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32170 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32171 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32172 FACGGS=FACGG1+FACGG2+FACGG3
32173 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32178 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
32183 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
32188 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
32191 ELSEIF(ISUB.EQ.424) THEN
32192 C...g + g -> QQ~[3PJ8] + g
32194 IF(MSTP(145).EQ.0) THEN
32195 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
32196 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
32197 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
32199 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
32200 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
32201 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
32203 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
32204 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
32205 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
32207 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
32208 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
32209 & +451D0*SH*TH**5+126D0*TH**6)
32210 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
32211 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
32212 & +171D0*SH*TH**5+42D0*TH**6)
32213 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
32214 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
32215 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
32216 & +99D0*SH*TH**3+35D0*TH**4)
32217 & +7D0*SQMQQ**8*SHTH*POLY)/
32218 & (SH*TH*UH*SQMQQR*SQMQQ*
32219 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
32221 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
32222 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
32223 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
32224 & -SQMQQ*SHTH2*POLY**2*
32225 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
32226 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
32227 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
32228 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
32229 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
32230 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
32231 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
32232 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
32233 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
32234 & +145D0*SH*TH**5+34D0*TH**6)
32235 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
32236 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
32238 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
32239 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
32240 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
32241 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
32242 & +3D0*SQMQQ**8*SHTH*POLY)
32243 BB=4D0*SHTH2*POLY**3
32244 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
32245 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
32246 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
32247 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
32248 & +84D0*SH*TH**9+20D0*TH**10)
32249 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
32250 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
32251 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
32253 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
32254 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
32255 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
32257 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
32258 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
32259 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
32260 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
32261 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
32263 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
32264 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
32265 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
32267 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
32268 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
32269 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
32270 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
32272 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
32273 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
32274 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
32275 & +394D0*SH*TH**9+84D0*TH**10)
32276 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
32277 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
32278 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
32279 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
32280 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
32281 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
32282 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
32283 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
32284 & +266D0*SH*TH**6+84D0*TH**7)
32285 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
32286 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
32288 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
32289 & +7D0*SH*TH**3+4*TH**4)
32290 & +SQMQQ**8*SH*(SH-TH)**2*TH
32291 DD=2D0*TH2*SHTH2*POLY**3
32292 & *(-SH2+2*SH*TH+2*TH2)
32293 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
32294 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
32295 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
32296 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
32297 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
32298 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
32299 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
32300 & -210D0*SH*TH**8-60D0*TH**9)
32301 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
32302 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
32303 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
32305 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
32306 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
32307 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
32308 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
32309 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
32310 & -30D0*SH*TH**6-24D0*TH**7)
32311 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
32312 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
32314 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
32315 IF(MSTP(147).EQ.0) THEN
32316 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32317 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32318 ELSEIF(MSTP(147).EQ.1) THEN
32319 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32320 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32321 ELSEIF(MSTP(147).EQ.3) THEN
32322 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32323 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32324 ELSEIF(MSTP(147).EQ.4) THEN
32325 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32326 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32327 ELSEIF(MSTP(147).EQ.5) THEN
32328 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32329 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32330 ELSEIF(MSTP(147).EQ.6) THEN
32331 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32332 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32334 FACQQG=COMFAC*FF*FACQQG
32336 C...Split total contribution into different colour flows just like
32337 C...in g g -> g g (recalculate kinematics for massless partons).
32338 THP=-0.5D0*SH*(1D0-CTH)
32339 UHP=-0.5D0*SH*(1D0+CTH)
32340 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32341 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32342 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32343 FACGGS=FACGG1+FACGG2+FACGG3
32344 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32349 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32354 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32359 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
32362 ELSEIF(ISUB.EQ.425) THEN
32363 C...q + g -> q + QQ~[3S18]
32364 IF(MSTP(145).EQ.0) THEN
32365 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
32366 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
32367 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
32369 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
32370 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
32375 IF(MSTP(147).EQ.0) THEN
32376 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32377 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32378 ELSEIF(MSTP(147).EQ.1) THEN
32379 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32380 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32381 ELSEIF(MSTP(147).EQ.3) THEN
32382 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32383 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32384 ELSEIF(MSTP(147).EQ.4) THEN
32385 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32386 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32387 ELSEIF(MSTP(147).EQ.5) THEN
32388 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32389 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32390 ELSEIF(MSTP(147).EQ.6) THEN
32391 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32392 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32394 FACQQG=COMFAC*FF*FACQQG
32396 C...Split total contribution into different colour flows just like
32397 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32398 C...(recalculate kinematics for massless partons).
32399 THP=-0.5D0*SH*(1D0-CTH)
32400 UHP=-0.5D0*SH*(1D0+CTH)
32401 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32402 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32403 FACQGS=FACQG1+FACQG2
32404 DO 2442 I=MMINA,MMAXA
32405 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
32407 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
32408 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
32411 ISIG(NCHN,3-ISDE)=21
32413 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
32416 ISIG(NCHN,3-ISDE)=21
32418 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
32422 ELSEIF(ISUB.EQ.426) THEN
32423 C...q + g -> q + QQ~[1S08]
32424 IF(MSTP(145).EQ.0) THEN
32425 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
32426 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
32428 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
32429 IF(MSTP(147).EQ.0) THEN
32431 ELSEIF(MSTP(147).EQ.1) THEN
32432 FACQQG=COMFAC*2D0*FA
32433 ELSEIF(MSTP(147).EQ.3) THEN
32435 ELSEIF(MSTP(147).EQ.4) THEN
32437 ELSEIF(MSTP(147).EQ.5) THEN
32439 ELSEIF(MSTP(147).EQ.6) THEN
32443 C...Split total contribution into different colour flows just like
32444 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32445 C...(recalculate kinematics for massless partons).
32446 THP=-0.5D0*SH*(1D0-CTH)
32447 UHP=-0.5D0*SH*(1D0+CTH)
32448 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32449 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32450 FACQGS=FACQG1+FACQG2
32451 DO 2444 I=MMINA,MMAXA
32452 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
32454 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
32455 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
32458 ISIG(NCHN,3-ISDE)=21
32460 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
32463 ISIG(NCHN,3-ISDE)=21
32465 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
32469 ELSEIF(ISUB.EQ.427) THEN
32470 C...q + g -> q + QQ~[3PJ8]
32471 IF(MSTP(145).EQ.0) THEN
32472 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
32473 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
32474 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
32475 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
32477 FF=10D0*PARU(1)*AS**3/
32478 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
32479 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
32480 BB=8D0*(SHTH2+TH*UH)
32481 CC=8D0*UHSH*(SHTH+THUH)
32482 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
32483 IF(MSTP(147).EQ.0) THEN
32484 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32485 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32486 ELSEIF(MSTP(147).EQ.1) THEN
32487 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32488 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32489 ELSEIF(MSTP(147).EQ.3) THEN
32490 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32491 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32492 ELSEIF(MSTP(147).EQ.4) THEN
32493 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32494 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32495 ELSEIF(MSTP(147).EQ.5) THEN
32496 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32497 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32498 ELSEIF(MSTP(147).EQ.6) THEN
32499 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32500 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32502 FACQQG=COMFAC*FF*FACQQG
32504 C...Split total contribution into different colour flows just like
32505 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32506 C...(recalculate kinematics for massless partons).
32507 THP=-0.5D0*SH*(1D0-CTH)
32508 UHP=-0.5D0*SH*(1D0+CTH)
32509 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32510 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32511 FACQGS=FACQG1+FACQG2
32512 DO 2446 I=MMINA,MMAXA
32513 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
32515 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
32516 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
32519 ISIG(NCHN,3-ISDE)=21
32521 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
32524 ISIG(NCHN,3-ISDE)=21
32526 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
32530 ELSEIF(ISUB.EQ.428) THEN
32531 C...q + q~ -> g + QQ~[3S18]
32532 IF(MSTP(145).EQ.0) THEN
32533 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
32534 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
32535 & (SQMQQ*SQMQQR*TH*UH*THUH2)
32537 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
32538 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
32543 IF(MSTP(147).EQ.0) THEN
32544 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32545 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32546 ELSEIF(MSTP(147).EQ.1) THEN
32547 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32548 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32549 ELSEIF(MSTP(147).EQ.3) THEN
32550 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32551 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32552 ELSEIF(MSTP(147).EQ.4) THEN
32553 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32554 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32555 ELSEIF(MSTP(147).EQ.5) THEN
32556 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32557 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32558 ELSEIF(MSTP(147).EQ.6) THEN
32559 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32560 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32562 FACQQG=COMFAC*FF*FACQQG
32564 C...Split total contribution into different colour flows just like
32565 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32566 C...(recalculate kinematics for massless partons).
32567 THP=-0.5D0*SH*(1D0-CTH)
32568 UHP=-0.5D0*SH*(1D0+CTH)
32569 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32570 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32571 FACGGS=FACGG1+FACGG2
32572 DO 2447 I=MMINA,MMAXA
32573 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32574 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
32579 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
32584 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
32587 ELSEIF(ISUB.EQ.429) THEN
32588 C...q + q~ -> g + QQ~[1S08]
32589 IF(MSTP(145).EQ.0) THEN
32590 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
32591 & (TH2+UH2)/(SQMQQR*SH*THUH2)
32593 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
32594 IF(MSTP(147).EQ.0) THEN
32596 ELSEIF(MSTP(147).EQ.1) THEN
32597 FACQQG=COMFAC*2D0*FA
32598 ELSEIF(MSTP(147).EQ.3) THEN
32600 ELSEIF(MSTP(147).EQ.4) THEN
32602 ELSEIF(MSTP(147).EQ.5) THEN
32604 ELSEIF(MSTP(147).EQ.6) THEN
32608 C...Split total contribution into different colour flows just like
32609 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32610 C...(recalculate kinematics for massless partons).
32611 THP=-0.5D0*SH*(1D0-CTH)
32612 UHP=-0.5D0*SH*(1D0+CTH)
32613 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32614 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32615 FACGGS=FACGG1+FACGG2
32616 DO 2448 I=MMINA,MMAXA
32617 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32618 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
32623 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
32628 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
32631 ELSEIF(ISUB.EQ.430) THEN
32632 C...q + q~ -> g + QQ~[3PJ8]
32633 IF(MSTP(145).EQ.0) THEN
32634 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
32635 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
32636 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
32637 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
32639 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
32640 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
32641 BB=8D0*(UHSH2+SH*TH)
32642 CC=8D0*(SHTH2+SH*UH)
32643 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
32644 IF(MSTP(147).EQ.0) THEN
32645 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32646 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32647 ELSEIF(MSTP(147).EQ.1) THEN
32648 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32649 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32650 ELSEIF(MSTP(147).EQ.3) THEN
32651 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32652 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32653 ELSEIF(MSTP(147).EQ.4) THEN
32654 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32655 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32656 ELSEIF(MSTP(147).EQ.5) THEN
32657 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32658 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32659 ELSEIF(MSTP(147).EQ.6) THEN
32660 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32661 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32663 FACQQG=COMFAC*FF*FACQQG
32665 C...Split total contribution into different colour flows just like
32666 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32667 C...(recalculate kinematics for massless partons).
32668 THP=-0.5D0*SH*(1D0-CTH)
32669 UHP=-0.5D0*SH*(1D0+CTH)
32670 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32671 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32672 FACGGS=FACGG1+FACGG2
32673 DO 2449 I=MMINA,MMAXA
32674 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32675 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32680 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32685 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32688 ELSEIF(ISUB.EQ.431) THEN
32689 C...g + g -> QQ~[3P01] + g
32690 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32691 QGTW=(SH*TH*UH)/SH**3
32693 IF(MSTP(145).EQ.0) THEN
32694 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32695 & (9D0*RGTW**2*PGTW**4*
32696 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32697 & -6D0*RGTW*PGTW**3*QGTW*
32698 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32699 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32700 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32701 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32703 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32704 & (9D0*RGTW**2*PGTW**4*
32705 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32706 & -6D0*RGTW*PGTW**3*QGTW*
32707 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32708 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32709 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32710 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32711 IF(MSTP(147).EQ.0) THEN
32713 ELSEIF(MSTP(147).EQ.1) THEN
32714 FACQQG=COMFAC*2D0*FC1
32715 ELSEIF(MSTP(147).EQ.3) THEN
32717 ELSEIF(MSTP(147).EQ.4) THEN
32719 ELSEIF(MSTP(147).EQ.5) THEN
32721 ELSEIF(MSTP(147).EQ.6) THEN
32725 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32730 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32733 ELSEIF(ISUB.EQ.432) THEN
32734 C...g + g -> QQ~[3P11] + g
32735 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32736 QGTW=(SH*TH*UH)/SH**3
32738 IF(MSTP(145).EQ.0) THEN
32739 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32740 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32741 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32742 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32744 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32745 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32746 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32747 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32748 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32749 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32750 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32751 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32752 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32753 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32754 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32755 C4=-4D0*THUH*(TH-UH)**2*
32756 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32757 & -SH2*TH*UH*(TH2+UH2))
32758 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32759 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32760 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32761 IF(MSTP(147).EQ.0) THEN
32762 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32763 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32764 ELSEIF(MSTP(147).EQ.1) THEN
32765 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32766 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32767 ELSEIF(MSTP(147).EQ.3) THEN
32768 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32769 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32770 ELSEIF(MSTP(147).EQ.4) THEN
32771 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32772 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32773 ELSEIF(MSTP(147).EQ.5) THEN
32774 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32775 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32776 ELSEIF(MSTP(147).EQ.6) THEN
32777 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32778 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32780 FACQQG=COMFAC*FF*FACQQG
32782 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32787 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32790 ELSEIF(ISUB.EQ.433) THEN
32791 C...g + g -> QQ~[3P21] + g
32792 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32793 QGTW=(SH*TH*UH)/SH**3
32795 IF(MSTP(145).EQ.0) THEN
32796 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32797 & (12D0*RGTW**2*PGTW**4*
32798 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32799 & -3D0*RGTW*PGTW**3*QGTW*
32800 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32801 & +2D0*PGTW**2*QGTW**2*
32802 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32803 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32804 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32806 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32807 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32808 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32810 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32811 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32812 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32813 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32814 & +10D0*(SH2**2+TH2**2))
32815 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32816 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32817 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32818 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32819 & +4D0*SH*TH*UH2**4*SHTH2)
32820 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32821 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32822 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32823 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32824 & +10D0*(SH2**2+UH2**2))
32825 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32826 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32827 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32828 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32829 & +4D0*SH*UH*TH2**4*UHSH2)
32830 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32831 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32832 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32833 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32834 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32835 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32836 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32837 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32838 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32839 & +3D0*(TH2**3+UH2**3)))
32840 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32841 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32842 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32843 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32844 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32845 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32846 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32848 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32850 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32852 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32853 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32854 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32855 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32856 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32857 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32859 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32861 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32863 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32864 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32865 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32866 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32867 & +4D0*SH*TH2**2*UH2**2*THUH2
32868 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32869 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32870 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32871 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32872 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32873 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32874 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32875 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32876 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32877 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32878 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32879 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32880 & +2D0*(TH2**3+UH2**3))
32881 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32882 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32883 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32884 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32885 IF(MSTP(147).EQ.0) THEN
32886 FACQQG=1D0/3D0*(C1*3D0
32887 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32888 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32889 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32890 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32891 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32892 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32893 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32894 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32895 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32896 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32897 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32898 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32899 ELSEIF(MSTP(147).EQ.1) THEN
32901 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32902 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32903 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32904 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32905 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32906 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32907 & +EL1K10*EL2K20*EL1K11*EL2K11)
32908 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32909 & +EL1K10*EL2K20*EL1K21*EL2K21)
32910 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32911 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32912 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32913 & +EL1K20*EL2K20*EL1K11*EL2K11)
32914 ELSEIF(MSTP(147).EQ.2) THEN
32916 & -C2*EL1K11*EL2K11
32917 & -C3*EL1K21*EL2K21
32918 & -C4*EL1K11*EL2K21
32919 & +C5*(EL1K11*EL2K11)**2
32920 & +C6*(EL1K21*EL2K21)**2
32921 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32922 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32923 & +(C9+C0)*(EL1K11*EL2K21)**2)
32925 FACQQG=COMFAC*FF*FACQQG
32927 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32932 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32935 ELSEIF(ISUB.EQ.434) THEN
32936 C...q + g -> q + QQ~[3P01]
32937 IF(MSTP(145).EQ.0) THEN
32938 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32939 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32941 FA=-PARU(1)*AS**3*(16D0/243D0)*
32942 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32943 IF(MSTP(147).EQ.0) THEN
32945 ELSEIF(MSTP(147).EQ.1) THEN
32946 FACQQG=COMFAC*2D0*FA
32947 ELSEIF(MSTP(147).EQ.3) THEN
32949 ELSEIF(MSTP(147).EQ.4) THEN
32951 ELSEIF(MSTP(147).EQ.5) THEN
32953 ELSEIF(MSTP(147).EQ.6) THEN
32957 DO 2452 I=MMINA,MMAXA
32958 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32960 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32961 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32964 ISIG(NCHN,3-ISDE)=21
32966 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32970 ELSEIF(ISUB.EQ.435) THEN
32971 C...q + g -> q + QQ~[3P11]
32972 IF(MSTP(145).EQ.0) THEN
32973 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32974 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32976 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32981 IF(MSTP(147).EQ.0) THEN
32982 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32983 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32984 ELSEIF(MSTP(147).EQ.1) THEN
32985 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32986 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32987 ELSEIF(MSTP(147).EQ.3) THEN
32988 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32989 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32990 ELSEIF(MSTP(147).EQ.4) THEN
32991 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32992 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32993 ELSEIF(MSTP(147).EQ.5) THEN
32994 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32995 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32996 ELSEIF(MSTP(147).EQ.6) THEN
32997 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32998 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33000 FACQQG=COMFAC*FF*FACQQG
33002 DO 2454 I=MMINA,MMAXA
33003 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
33005 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
33006 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
33009 ISIG(NCHN,3-ISDE)=21
33011 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33015 ELSEIF(ISUB.EQ.436) THEN
33016 C...q + g -> q + QQ~[3P21]
33017 IF(MSTP(145).EQ.0) THEN
33018 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
33019 & ((6D0*SQMQQ**2+TH2)*UHSH2
33020 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
33021 & (SQMQQR*TH*UHSH2**2)
33023 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
33025 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
33034 IF(MSTP(147).EQ.0) THEN
33035 FACQQG=1D0/3D0*(C1*3D0
33036 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
33037 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
33038 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
33039 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
33040 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
33041 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33042 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33043 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
33044 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33045 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33046 & *(EL1K20*EL2K20-EL1K21*EL2K21)
33047 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
33048 ELSEIF(MSTP(147).EQ.1) THEN
33050 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
33051 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
33052 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
33053 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
33054 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
33055 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
33056 & +EL1K10*EL2K20*EL1K11*EL2K11)
33057 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
33058 & +EL1K10*EL2K20*EL1K21*EL2K21)
33059 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
33060 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
33061 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
33062 & +EL1K20*EL2K20*EL1K11*EL2K11)
33063 ELSEIF(MSTP(147).EQ.2) THEN
33065 & -C2*EL1K11*EL2K11
33066 & -C3*EL1K21*EL2K21
33067 & -C4*EL1K11*EL2K21
33068 & +C5*(EL1K11*EL2K11)**2
33069 & +C6*(EL1K21*EL2K21)**2
33070 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
33071 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
33072 & +(C9+C0)*(EL1K11*EL2K21)**2)
33074 FACQQG=COMFAC*FF*FACQQG
33076 DO 2456 I=MMINA,MMAXA
33077 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
33079 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
33080 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
33083 ISIG(NCHN,3-ISDE)=21
33085 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33089 ELSEIF(ISUB.EQ.437) THEN
33090 C...q + q~ -> g + QQ~[3P01]
33091 IF(MSTP(145).EQ.0) THEN
33092 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
33093 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
33095 FA=PARU(1)*AS**3*(128D0/729D0)*
33096 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
33097 IF(MSTP(147).EQ.0) THEN
33099 ELSEIF(MSTP(147).EQ.1) THEN
33100 FACQQG=COMFAC*2D0*FA
33101 ELSEIF(MSTP(147).EQ.3) THEN
33103 ELSEIF(MSTP(147).EQ.4) THEN
33105 ELSEIF(MSTP(147).EQ.5) THEN
33107 ELSEIF(MSTP(147).EQ.6) THEN
33111 DO 2457 I=MMINA,MMAXA
33112 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33113 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
33118 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33121 ELSEIF(ISUB.EQ.438) THEN
33122 C...q + q~ -> g + QQ~[3P11]
33123 IF(MSTP(145).EQ.0) THEN
33124 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
33125 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
33127 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
33132 IF(MSTP(147).EQ.0) THEN
33133 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
33134 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
33135 ELSEIF(MSTP(147).EQ.1) THEN
33136 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33137 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
33138 ELSEIF(MSTP(147).EQ.3) THEN
33139 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
33140 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
33141 ELSEIF(MSTP(147).EQ.4) THEN
33142 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33143 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33144 ELSEIF(MSTP(147).EQ.5) THEN
33145 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
33146 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
33147 ELSEIF(MSTP(147).EQ.6) THEN
33148 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33149 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33151 FACQQG=COMFAC*FF*FACQQG
33153 DO 2458 I=MMINA,MMAXA
33154 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33155 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
33160 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33163 ELSEIF(ISUB.EQ.439) THEN
33164 C...q + q~ -> g + QQ~[3P21]
33165 IF(MSTP(145).EQ.0) THEN
33166 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
33167 & ((6D0*SQMQQ**2+SH2)*THUH2
33168 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
33169 & (SQMQQR*SH*THUH2**2)
33171 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
33173 C2=4D0*(SH2+UH2+2D0*SH*THUH)
33174 C3=4D0*(SH2+TH2+2D0*SH*THUH)
33175 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
33182 IF(MSTP(147).EQ.0) THEN
33183 FACQQG=1D0/3D0*(C1*3D0
33184 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
33185 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
33186 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
33187 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
33188 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
33189 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33190 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33191 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
33192 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33193 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33194 & *(EL1K20*EL2K20-EL1K21*EL2K21)
33195 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
33196 ELSEIF(MSTP(147).EQ.1) THEN
33198 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
33199 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
33200 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
33201 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
33202 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
33203 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
33204 & +EL1K10*EL2K20*EL1K11*EL2K11)
33205 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
33206 & +EL1K10*EL2K20*EL1K21*EL2K21)
33207 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
33208 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
33209 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
33210 & +EL1K20*EL2K20*EL1K11*EL2K11)
33211 ELSEIF(MSTP(147).EQ.2) THEN
33213 & -C2*EL1K11*EL2K11
33214 & -C3*EL1K21*EL2K21
33215 & -C4*EL1K11*EL2K21
33216 & +C5*(EL1K11*EL2K11)**2
33217 & +C6*(EL1K21*EL2K21)**2
33218 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
33219 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
33220 & +(C9+C0)*(EL1K11*EL2K21)**2)
33222 FACQQG=COMFAC*FF*FACQQG
33224 DO 2459 I=MMINA,MMAXA
33225 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33226 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
33231 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33241 C*********************************************************************
33244 C...Subprocess cross sections for W/Z processes,
33245 C...except that longitudinal WW scattering is in Higgs sector.
33246 C...Auxiliary to PYSIGH.
33248 SUBROUTINE PYSGWZ(NCHN,SIGS)
33250 C...Double precision and integer declarations
33251 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33252 IMPLICIT INTEGER(I-N)
33253 INTEGER PYK,PYCHGE,PYCOMP
33254 C...Parameter statement to help give large particle numbers.
33255 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33256 &KEXCIT=4000000,KDIMEN=5000000)
33258 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33259 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33260 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33261 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33262 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33263 COMMON/PYINT1/MINT(400),VINT(400)
33264 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33265 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33266 COMMON/PYINT4/MWID(500),WIDS(500,5)
33267 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
33268 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33269 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33270 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33271 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33272 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
33273 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
33274 C...Local arrays and complex numbers
33275 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
33277 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
33279 C...Differential cross section expressions.
33281 IF(ISUB.LE.20) THEN
33283 C...f + fbar -> gamma*/Z0
33285 CALL PYWIDT(23,SH,WDTP,WDTE)
33287 FACZ=4D0*COMFAC*3D0
33290 DO 100 I=MMINA,MMAXA
33291 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33292 EI=KCHG(IABS(I),1)/3D0
33296 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
33298 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
33303 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
33304 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
33305 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
33306 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
33309 ELSEIF(ISUB.EQ.2) THEN
33310 C...f + fbar' -> W+/-
33311 CALL PYWIDT(24,SH,WDTP,WDTE)
33313 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
33314 HP=AEM/(24D0*XW)*SH
33315 DO 120 I=MMIN1,MMAX1
33316 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33318 DO 110 J=MMIN2,MMAX2
33319 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33321 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
33322 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33324 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33326 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
33331 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
33332 SIGH(NCHN)=HI*FACBW*HF
33336 ELSEIF(ISUB.EQ.15) THEN
33337 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
33338 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33339 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33343 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33344 DO 130 I=1,MIN(16,MDCY(23,3))
33346 IF(MDME(IDC,1).LT.0) GOTO 130
33348 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33352 AF=SIGN(1D0,EF+0.1D0)
33354 ELSEIF(I.LE.16) THEN
33356 AF=SIGN(1D0,EF+0.1D0)
33359 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33360 IF(4D0*RM1.LT.1D0) THEN
33362 IF(I.LE.8) FCOF=3D0*RADC4
33363 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33365 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33366 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33367 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33368 & AF**2*(1D0-4D0*RM1))*BE34
33372 C...Propagators: as simulated in PYOFSH and as desired
33373 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33377 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33379 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33380 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33381 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33382 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33383 C...Loop over flavours; consider full gamma/Z structure
33384 DO 140 I=MMINA,MMAXA
33385 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33386 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
33387 EI=KCHG(IABS(I),1)/3D0
33394 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
33395 & (VI**2+AI**2)*HFZZ)/HBW4
33398 ELSEIF(ISUB.EQ.16) THEN
33399 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
33400 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33401 C...Propagators: as simulated in PYOFSH and as desired
33402 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33403 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33404 GMMWC=SQRT(SQM4)*WDTP(0)
33405 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33406 FACWG=FACWG*HBW4C/HBW4
33407 DO 160 I=MMIN1,MMAX1
33409 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
33410 DO 150 J=MMIN2,MMAX2
33412 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
33413 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
33414 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33415 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33416 FCKM=VCKM((IA+1)/2,(JA+1)/2)
33421 SIGH(NCHN)=FACWG*FCKM*WIDSC
33425 ELSEIF(ISUB.EQ.19) THEN
33426 C...f + fbar -> gamma + (gamma*/Z0)
33427 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33428 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33432 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33433 DO 170 I=1,MIN(16,MDCY(23,3))
33435 IF(MDME(IDC,1).LT.0) GOTO 170
33437 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33441 AF=SIGN(1D0,EF+0.1D0)
33443 ELSEIF(I.LE.16) THEN
33445 AF=SIGN(1D0,EF+0.1D0)
33448 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33449 IF(4D0*RM1.LT.1D0) THEN
33451 IF(I.LE.8) FCOF=3D0*RADC4
33452 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33454 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33455 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33456 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33457 & AF**2*(1D0-4D0*RM1))*BE34
33461 C...Propagators: as simulated in PYOFSH and as desired
33462 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33466 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33468 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33469 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33470 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33471 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33472 C...Loop over flavours; consider full gamma/Z structure
33473 DO 180 I=MMINA,MMAXA
33474 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
33475 EI=KCHG(IABS(I),1)/3D0
33479 IF(IABS(I).LE.10) FCOI=FACA/3D0
33484 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33485 & (VI**2+AI**2)*HFZZ)/HBW4
33488 ELSEIF(ISUB.EQ.20) THEN
33489 C...f + fbar' -> gamma + W+/-
33490 FACGW=COMFAC*0.5D0*AEM**2/XW
33491 C...Propagators: as simulated in PYOFSH and as desired
33492 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33493 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33494 GMMWC=SQRT(SQM4)*WDTP(0)
33495 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33496 FACGW=FACGW*HBW4C/HBW4
33497 C...Anomalous couplings
33498 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33501 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
33502 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
33503 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
33504 & (4D0*SQMW))/(TH+UH)**2
33506 DO 200 I=MMIN1,MMAX1
33508 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
33509 DO 190 J=MMIN2,MMAX2
33511 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
33512 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
33513 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33515 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33516 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33518 FACWR=UH/(TH+UH)-1D0/3D0
33519 FCKM=VCKM((IA+1)/2,(JA+1)/2)
33526 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
33531 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
33536 ELSEIF(ISUB.LE.40) THEN
33537 IF(ISUB.EQ.22) THEN
33538 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
33539 C...Kinematics dependence
33540 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
33541 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
33542 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33548 RADC3=1D0+PYALPS(SQM3)/PARU(1)
33549 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33550 DO 230 I=1,MIN(16,MDCY(23,3))
33552 IF(MDME(IDC,1).LT.0) GOTO 230
33554 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
33555 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
33558 AF=SIGN(1D0,EF+0.1D0)
33560 ELSEIF(I.LE.16) THEN
33562 AF=SIGN(1D0,EF+0.1D0)
33565 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
33566 IF(4D0*RM1.LT.1D0) THEN
33568 IF(I.LE.8) FCOF=3D0*RADC3
33569 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33571 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33572 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33573 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
33574 & AF**2*(1D0-4D0*RM1))*BE34
33577 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33578 IF(4D0*RM1.LT.1D0) THEN
33580 IF(I.LE.8) FCOF=3D0*RADC4
33581 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33583 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33584 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33585 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
33586 & AF**2*(1D0-4D0*RM1))*BE34
33590 C...Propagators: as simulated in PYOFSH and as desired
33591 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33592 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33596 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33598 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33600 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
33601 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
33602 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
33607 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33609 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33611 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
33612 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
33613 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
33615 C...Loop over flavours; separate left- and right-handed couplings
33616 DO 270 I=MMINA,MMAXA
33617 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
33618 EI=KCHG(IABS(I),1)/3D0
33624 IF(IABS(I).LE.10) FCOI=FACA/3D0
33626 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
33627 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
33628 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
33629 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
33631 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
33632 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
33633 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
33634 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
33639 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
33642 ELSEIF(ISUB.EQ.23) THEN
33643 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
33644 FACZW=COMFAC*0.5D0*(AEM/XW)**2
33645 FACZW=FACZW*WIDS(23,2)
33646 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33647 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
33648 DO 290 I=MMIN1,MMAX1
33650 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
33651 DO 280 J=MMIN2,MMAX2
33653 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
33654 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
33655 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33657 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33659 AI=SIGN(1D0,EI+0.1D0)
33662 AJ=SIGN(1D0,EJ+0.1D0)
33664 IF(VI+AI.GT.0) THEN
33673 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33675 IF(IA.LE.10) FCOI=FACA/3D0
33680 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33681 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33682 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33683 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33684 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33685 & WIDS(24,(5-KCHW)/2)
33686 C***Protect against slightly negative cross sections. (Reason yet to be
33687 C***sorted out. One possibility: addition of width to the W propagator.)
33688 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33692 ELSEIF(ISUB.EQ.25) THEN
33693 C...f + fbar -> W+ + W-
33694 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33696 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33697 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33698 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33699 GMMW3=SQRT(SQM3)*WDTP(0)
33700 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33701 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33702 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33703 GMMW4=SQRT(SQM4)*WDTP(0)
33704 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33705 C...Kinematical functions
33706 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33707 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33708 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33709 GT=THUH34+4D0*THUH/TH2
33710 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33711 GU=THUH34+4D0*THUH/UH2
33712 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33713 C...Common factors and couplings
33714 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33715 FACWW=FACWW*WIDS(24,1)
33717 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33718 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33719 CNG=AEM**2/(4D0*XW)
33720 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33721 CNN=AEM**2/(16D0*XW**2)
33722 C...Coulomb factor for W+W- pair
33723 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33724 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33725 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33726 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33727 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33728 & PMAS(24,2)**2)-COULE))
33730 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33732 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33733 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33734 & PMAS(24,2)**2)+COULE))
33736 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33739 IF(MSTP(40).EQ.1) THEN
33740 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33741 & MAX(1D-10,2D0*COULP*COULP1))
33742 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33743 ELSEIF(MSTP(40).EQ.2) THEN
33744 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33745 COULCP=DCMPLX(0D0,DBLE(COULP))
33746 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33747 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33748 & (4D0*COULCP)*LOG(COULCD)
33749 COULCS=DCMPLX(0D0,0D0)
33752 COULXX=(ISTP-0.5)/NSTP
33753 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33754 & (1D0+COULXX/COULCD))
33756 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33758 FACCOU=ABS(COULCR)**2
33759 ELSEIF(MSTP(40).EQ.3) THEN
33760 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33761 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33762 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33764 ELSEIF(MSTP(40).EQ.4) THEN
33765 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33771 C...Loop over allowed flavours
33772 DO 310 I=MMINA,MMAXA
33773 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33774 EI=KCHG(IABS(I),1)/3D0
33775 AI=SIGN(1D0,EI+0.1D0)
33778 IF(IABS(I).LE.10) FCOI=FACA/3D0
33779 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33781 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33782 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33784 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33785 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33788 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33789 BET=SQRT(1D0-4D0*XMW02/SH)
33790 GAT=1D0/SQRT(1D0-BET**2)
33792 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33793 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33794 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33795 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33796 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33797 & (1D0-2D0*BET*CTH+BET**2))
33798 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33799 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33800 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33801 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33802 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33803 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33804 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33811 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33814 ELSEIF(ISUB.EQ.30) THEN
33815 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33816 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33818 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33822 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33823 DO 320 I=1,MIN(16,MDCY(23,3))
33825 IF(MDME(IDC,1).LT.0) GOTO 320
33827 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33831 AF=SIGN(1D0,EF+0.1D0)
33833 ELSEIF(I.LE.16) THEN
33835 AF=SIGN(1D0,EF+0.1D0)
33838 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33839 IF(4D0*RM1.LT.1D0) THEN
33841 IF(I.LE.8) FCOF=3D0*RADC4
33842 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33844 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33845 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33846 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33847 & AF**2*(1D0-4D0*RM1))*BE34
33851 C...Propagators: as simulated in PYOFSH and as desired
33852 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33856 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33858 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33859 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33860 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33861 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33862 C...Loop over flavours; consider full gamma/Z structure
33863 DO 340 I=MMINA,MMAXA
33864 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33865 EI=KCHG(IABS(I),1)/3D0
33868 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33869 & (VI**2+AI**2)*HFZZ)/HBW4
33871 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33872 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33875 ISIG(NCHN,3-ISDE)=21
33881 ELSEIF(ISUB.EQ.31) THEN
33882 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33883 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33884 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33885 C...Propagators: as simulated in PYOFSH and as desired
33886 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33887 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33888 GMMWC=SQRT(SQM4)*WDTP(0)
33889 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33890 FACWQ=FACWQ*HBW4C/HBW4
33891 DO 360 I=MMINA,MMAXA
33892 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33894 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33895 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33897 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33898 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33901 ISIG(NCHN,3-ISDE)=21
33903 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33907 ELSEIF(ISUB.EQ.35) THEN
33908 C...f + gamma -> f + (gamma*/Z0)
33909 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33910 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33911 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33912 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33913 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33914 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33916 FZQN=SH2+UH2+2D0*SQM4*TH
33919 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33920 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33924 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33925 DO 370 I=1,MIN(16,MDCY(23,3))
33927 IF(MDME(IDC,1).LT.0) GOTO 370
33929 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33933 AF=SIGN(1D0,EF+0.1D0)
33935 ELSEIF(I.LE.16) THEN
33937 AF=SIGN(1D0,EF+0.1D0)
33940 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33941 IF(4D0*RM1.LT.1D0) THEN
33943 IF(I.LE.8) FCOF=3D0*RADC4
33944 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33946 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33947 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33948 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33949 & AF**2*(1D0-4D0*RM1))*BE34
33953 C...Propagators: as simulated in PYOFSH and as desired
33954 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33958 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33960 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33961 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33962 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33963 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33964 C...Loop over flavours; consider full gamma/Z structure
33965 DO 390 I=MMINA,MMAXA
33966 IF(I.EQ.0) GOTO 390
33967 EI=KCHG(IABS(I),1)/3D0
33970 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33971 & (VI**2+AI**2)*HFZZ)/HBW4
33972 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33974 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33975 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33978 ISIG(NCHN,3-ISDE)=22
33980 SIGH(NCHN)=FACZQ*FZQN/FZQD
33984 ELSEIF(ISUB.EQ.36) THEN
33985 C...f + gamma -> f' + W+/-
33986 FWQ=COMFAC*AEM**2/(2D0*XW)*
33987 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33988 C...Propagators: as simulated in PYOFSH and as desired
33989 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33990 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33991 GMMWC=SQRT(SQM4)*WDTP(0)
33992 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33994 DO 410 I=MMINA,MMAXA
33995 IF(I.EQ.0) GOTO 410
33997 EIA=ABS(KCHG(IABS(I),1)/3D0)
33998 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33999 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34000 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
34002 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
34003 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
34006 ISIG(NCHN,3-ISDE)=22
34008 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
34013 ELSEIF(ISUB.LE.100) THEN
34014 IF(ISUB.EQ.69) THEN
34015 C...gamma + gamma -> W+ + W-
34016 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
34017 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
34018 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
34019 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
34020 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
34028 ELSEIF(ISUB.EQ.70) THEN
34029 C...gamma + W+/- -> Z0 + W+/-
34030 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
34031 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
34032 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
34033 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
34034 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
34035 DO 440 KCHW=1,-1,-2
34037 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
34040 ISIG(NCHN,3-ISDE)=24*KCHW
34042 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
34051 C*********************************************************************
34054 C...Subprocess cross sections for Higgs processes,
34055 C...except Higgs pairs in PYSGSU, but including WW scattering.
34056 C...Auxiliary to PYSIGH.
34058 SUBROUTINE PYSGHG(NCHN,SIGS)
34060 C...Double precision and integer declarations
34061 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34062 IMPLICIT INTEGER(I-N)
34063 INTEGER PYK,PYCHGE,PYCOMP
34064 C...Parameter statement to help give large particle numbers.
34065 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34066 &KEXCIT=4000000,KDIMEN=5000000)
34068 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34069 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34070 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
34071 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34072 COMMON/PYINT1/MINT(400),VINT(400)
34073 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34074 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34075 COMMON/PYINT4/MWID(500),WIDS(500,5)
34076 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
34077 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34078 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34079 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34080 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34081 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34082 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
34083 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
34084 C...Local arrays and complex variables
34085 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34086 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
34087 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
34089 C...Convert H or A process into equivalent h one
34092 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
34093 KFHIGG=KFPR(ISUB,1)
34095 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
34096 &ISUB.LE.190)) THEN
34098 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
34100 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
34101 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
34102 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
34103 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
34104 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
34105 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
34106 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
34107 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
34108 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
34109 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
34110 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
34111 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
34113 SQMH=PMAS(KFHIGG,1)**2
34114 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
34116 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34117 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
34118 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
34119 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
34120 IF(MSTP(46).LE.4) THEN
34121 HDTLH=LOG(PMAS(25,1)/PARP(44))
34122 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
34123 HDTNR=-1D0/18D0+HDTLH/6D0
34125 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
34126 HDTLQ=LOG(PARP(45)/PARP(44))
34127 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
34128 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
34131 C...Calculate lowest and next-to-lowest order partial wave amplitudes
34132 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
34136 HDTLS=LOG(SH/PARP(44)**2)
34137 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
34138 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
34139 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
34140 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
34141 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
34142 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
34143 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
34144 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
34146 C...Unitarize partial wave amplitudes with Pade or K-matrix method
34147 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
34148 A00U=A00L/(1D0-A004/A00L)
34149 A20U=A20L/(1D0-A204/A20L)
34150 A11U=A11L/(1D0-A114/A11L)
34152 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
34153 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
34154 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
34158 C...Differential cross section expressions.
34160 IF(ISUB.LE.60) THEN
34162 C...f + fbar -> h0 (or H0, or A0)
34163 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34165 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34166 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34168 HP=AEM/(8D0*XW)*SH/SQMW*SH
34169 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34170 DO 100 I=MMINA,MMAXA
34171 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
34173 RMQ=PYMRUN(IA,SH)**2/SH
34175 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
34176 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34178 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34179 IF(IA.GT.10) IKFI=3
34180 HI=HI*PARU(150+10*IHIGG+IKFI)**2
34181 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34182 HI=HI/(1D0+RMSS(41))**2
34183 IF(IHIGG.NE.3) THEN
34184 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34185 & PARU(151+10*IHIGG))**2
34193 SIGH(NCHN)=HI*FACBW*HF
34196 ELSEIF(ISUB.EQ.5) THEN
34198 CALL PYWIDT(25,SH,WDTP,WDTE)
34200 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34201 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
34202 HP=AEM/(8D0*XW)*SH/SQMW*SH
34203 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34205 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
34206 DO 120 I=MMIN1,MMAX1
34207 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
34208 DO 110 J=MMIN2,MMAX2
34209 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
34210 EI=KCHG(IABS(I),1)/3D0
34213 EJ=KCHG(IABS(J),1)/3D0
34220 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
34224 ELSEIF(ISUB.EQ.8) THEN
34226 CALL PYWIDT(25,SH,WDTP,WDTE)
34228 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34229 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
34230 HP=AEM/(8D0*XW)*SH/SQMW*SH
34231 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34233 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
34234 DO 140 I=MMIN1,MMAX1
34235 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
34236 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34237 DO 130 J=MMIN2,MMAX2
34238 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
34239 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34240 IF(EI*EJ.GT.0D0) GOTO 130
34245 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
34249 ELSEIF(ISUB.EQ.24) THEN
34250 C...f + fbar -> Z0 + h0 (or H0, or A0)
34251 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
34252 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
34253 CALL PYWIDT(23,SQM3,WDTP,WDTE)
34254 GMMZ3=SQRT(SQM3)*WDTP(0)
34255 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
34256 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34257 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34258 GMMH4=SQRT(SQM4)*WDTP(0)
34259 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
34260 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
34261 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
34262 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
34263 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
34264 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
34265 & PARU(154+10*IHIGG)**2
34266 DO 150 I=MMINA,MMAXA
34267 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
34268 EI=KCHG(IABS(I),1)/3D0
34272 IF(IABS(I).LE.10) FCOI=FACA/3D0
34277 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
34280 ELSEIF(ISUB.EQ.26) THEN
34281 C...f + fbar' -> W+/- + h0 (or H0, or A0)
34282 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
34283 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
34284 CALL PYWIDT(24,SQM3,WDTP,WDTE)
34285 GMMW3=SQRT(SQM3)*WDTP(0)
34286 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
34287 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34288 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34289 GMMH4=SQRT(SQM4)*WDTP(0)
34290 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
34291 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
34292 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
34293 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
34294 FACHW=FACHW*WIDS(KFHIGG,2)
34295 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
34296 & PARU(155+10*IHIGG)**2
34297 DO 170 I=MMIN1,MMAX1
34299 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
34300 DO 160 J=MMIN2,MMAX2
34302 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
34303 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
34304 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34306 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34308 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34310 IF(IA.LE.10) FCOI=FACA/3D0
34315 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
34319 ELSEIF(ISUB.EQ.32) THEN
34320 C...f + g -> f + h0 (q + g -> q + h0 only)
34321 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
34322 C...H propagator: as simulated in PYOFSH and as desired
34323 SQMHC=PMAS(25,1)**2
34324 GMMHC=PMAS(25,1)*PMAS(25,2)
34325 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34326 CALL PYWIDT(25,SQM4,WDTP,WDTE)
34327 GMMHCC=SQRT(SQM4)*WDTP(0)
34328 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34329 FHCQ=FHCQ*HBW4C/HBW4
34330 DO 190 I=MMINA,MMAXA
34332 IF(IA.NE.5) GOTO 190
34333 SQML=PYMRUN(IA,SH)**2
34335 FACHCQ=FHCQ*SQML/SQMW*
34336 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34337 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
34338 & (SQM4-SQMQ-SH)/SH)
34340 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
34341 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
34344 ISIG(NCHN,3-ISDE)=21
34346 SIGH(NCHN)=FACHCQ*WIDS(25,2)
34351 ELSEIF(ISUB.LE.80) THEN
34352 IF(ISUB.EQ.71) THEN
34353 C...Z0 + Z0 -> Z0 + Z0
34354 IF(SH.LE.4.01D0*SQMZ) GOTO 220
34356 IF(MSTP(46).LE.2) THEN
34357 C...Exact scattering ME:s for on-mass-shell gauge bosons
34358 BE2=1D0-4D0*SQMZ/SH
34359 TH=-0.5D0*SH*BE2*(1D0-CTH)
34360 UH=-0.5D0*SH*BE2*(1D0+CTH)
34361 IF(MAX(TH,UH).GT.-1D0) GOTO 220
34362 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
34363 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34364 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34365 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
34366 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34367 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34368 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
34369 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
34370 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
34371 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
34372 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
34373 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
34374 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
34375 & (ASHIM+ATHIM+AUHIM)**2)
34376 IF(MSTP(46).EQ.2) FACZZ=0D0
34379 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34380 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
34381 & ABS(A00U+2D0*A20U)**2
34383 FACZZ=FACZZ*WIDS(23,1)
34385 DO 210 I=MMIN1,MMAX1
34386 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
34387 EI=KCHG(IABS(I),1)/3D0
34391 DO 200 J=MMIN2,MMAX2
34392 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
34393 EJ=KCHG(IABS(J),1)/3D0
34401 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
34406 ELSEIF(ISUB.EQ.72) THEN
34407 C...Z0 + Z0 -> W+ + W-
34408 IF(SH.LE.4.01D0*SQMZ) GOTO 250
34410 IF(MSTP(46).LE.2) THEN
34411 C...Exact scattering ME:s for on-mass-shell gauge bosons
34412 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
34414 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
34415 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
34416 IF(MAX(TH,UH).GT.-1D0) GOTO 250
34417 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
34418 & (1D0-2D0*SQMZ/SH)
34419 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34420 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34421 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
34422 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34423 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34424 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
34425 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34427 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
34428 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34429 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34430 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
34431 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34433 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
34435 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
34436 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
34437 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
34438 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
34439 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
34440 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
34441 & (ATWIM+AUWIM+A4IM)**2)
34444 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34445 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
34446 & ABS(A00U-A20U)**2
34448 FACWW=FACWW*WIDS(24,1)
34450 DO 240 I=MMIN1,MMAX1
34451 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
34452 EI=KCHG(IABS(I),1)/3D0
34456 DO 230 J=MMIN2,MMAX2
34457 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
34458 EJ=KCHG(IABS(J),1)/3D0
34466 SIGH(NCHN)=FACWW*AVI*AVJ
34471 ELSEIF(ISUB.EQ.73) THEN
34472 C...Z0 + W+/- -> Z0 + W+/-
34473 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
34475 IF(MSTP(46).LE.2) THEN
34476 C...Exact scattering ME:s for on-mass-shell gauge bosons
34477 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
34478 EP1=1D0-(SQMZ-SQMW)/SH
34479 EP2=1D0+(SQMZ-SQMW)/SH
34480 TH=-0.5D0*SH*BE2*(1D0-CTH)
34481 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
34482 IF(MAX(TH,UH).GT.-1D0) GOTO 280
34483 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
34484 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34485 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34486 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
34487 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
34488 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
34489 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
34491 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
34492 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
34493 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
34494 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
34495 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
34496 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
34497 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
34498 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
34499 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
34500 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
34501 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
34502 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
34504 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
34505 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
34507 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
34508 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
34509 IF(MSTP(46).LE.0) FACZW=0D0
34510 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
34511 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
34512 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
34513 & (ASWIM+AUWIM+A4IM)**2)
34516 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34517 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
34518 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
34520 FACZW=FACZW*WIDS(23,2)
34522 DO 270 I=MMIN1,MMAX1
34523 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
34524 EI=KCHG(IABS(I),1)/3D0
34528 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
34529 DO 260 J=MMIN2,MMAX2
34530 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
34531 EJ=KCHG(IABS(J),1)/3D0
34535 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
34540 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
34545 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
34550 ELSEIF(ISUB.EQ.75) THEN
34551 C...W+ + W- -> gamma + gamma
34553 ELSEIF(ISUB.EQ.76) THEN
34554 C...W+ + W- -> Z0 + Z0
34555 IF(SH.LE.4.01D0*SQMZ) GOTO 310
34557 IF(MSTP(46).LE.2) THEN
34558 C...Exact scattering ME:s for on-mass-shell gauge bosons
34559 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
34561 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
34562 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
34563 IF(MAX(TH,UH).GT.-1D0) GOTO 310
34564 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
34565 & (1D0-2D0*SQMZ/SH)
34566 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34567 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34568 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
34569 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34570 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34571 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
34572 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34574 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
34575 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34576 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34577 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
34578 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34580 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
34582 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
34584 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
34585 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
34586 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
34587 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
34588 & (ATWIM+AUWIM+A4IM)**2)
34591 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34592 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34593 & ABS(A00U-A20U)**2
34595 FACZZ=FACZZ*WIDS(23,1)
34597 DO 300 I=MMIN1,MMAX1
34598 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
34599 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34600 DO 290 J=MMIN2,MMAX2
34601 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
34602 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34603 IF(EI*EJ.GT.0D0) GOTO 290
34608 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
34613 ELSEIF(ISUB.EQ.77) THEN
34614 C...W+/- + W+/- -> W+/- + W+/-
34615 IF(SH.LE.4.01D0*SQMW) GOTO 340
34617 IF(MSTP(46).LE.2) THEN
34618 C...Exact scattering ME:s for on-mass-shell gauge bosons
34619 BE2=1D0-4D0*SQMW/SH
34623 TH=-0.5D0*SH*BE2*(1D0-CTH)
34624 UH=-0.5D0*SH*BE2*(1D0+CTH)
34625 IF(MAX(TH,UH).GT.-1D0) GOTO 340
34627 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34628 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34630 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34631 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34633 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
34634 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
34635 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
34638 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
34640 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
34641 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
34642 ATGRE=0.5D0*XW*SH/TH*TGZANG
34644 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
34646 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
34647 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
34648 AUGRE=0.5D0*XW*SH/UH*UGZANG
34650 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
34652 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
34654 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
34656 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
34658 IF(MSTP(46).LE.0) THEN
34663 ELSEIF(MSTP(46).EQ.1) THEN
34664 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34665 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34666 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34667 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34669 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34670 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34671 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34672 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34674 AWWA2=AWWARE**2+AWWAIM**2
34675 AWWS2=AWWSRE**2+AWWSIM**2
34678 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34679 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34680 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34681 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34684 DO 330 I=MMIN1,MMAX1
34685 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34686 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34687 DO 320 J=MMIN2,MMAX2
34688 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34689 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34690 IF(EI*EJ.LT.0D0) THEN
34692 IF(MSTP(45).EQ.1) GOTO 320
34693 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34694 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34697 IF(MSTP(45).EQ.2) GOTO 320
34698 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34699 IF(MSTP(46).GE.3) FACWW=FWWS
34700 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34701 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34707 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34708 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34714 ELSEIF(ISUB.LE.120) THEN
34715 IF(ISUB.EQ.102) THEN
34716 C...g + g -> h0 (or H0, or A0)
34717 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34719 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34720 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34721 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34723 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34724 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34726 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34727 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34728 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34730 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34731 & '(PYSGHG:) did not find Higgs -> g g channel')
34734 HI=SHR*WDTP(13)/32D0
34736 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34741 SIGH(NCHN)=HI*FACBW*HF
34744 ELSEIF(ISUB.EQ.103) THEN
34745 C...gamma + gamma -> h0 (or H0, or A0)
34746 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34748 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34749 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34750 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34752 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34753 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34755 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34756 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34757 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34759 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34760 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34763 HI=SHR*WDTP(14)*2D0
34765 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34770 SIGH(NCHN)=HI*FACBW*HF
34773 ELSEIF(ISUB.EQ.110) THEN
34774 C...f + fbar -> gamma + h0
34775 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34776 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34777 FACHG=FACHG*WIDS(KFHIGG,2)
34778 C...Calculate loop contributions for intermediate gamma* and Z0
34779 CIGTOT=DCMPLX(0D0,0D0)
34780 CIZTOT=DCMPLX(0D0,0D0)
34783 IF(J.LE.2*MSTP(1)) THEN
34786 AJ=SIGN(1D0,EJ+0.1D0)
34788 BALP=SQM4/(2D0*PMAS(J,1))**2
34789 BBET=SH/(2D0*PMAS(J,1))**2
34790 ELSEIF(J.LE.3*MSTP(1)) THEN
34792 JL=2*(J-2*MSTP(1))-1
34793 EJ=KCHG(10+JL,1)/3D0
34794 AJ=SIGN(1D0,EJ+0.1D0)
34796 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34797 BBET=SH/(2D0*PMAS(10+JL,1))**2
34799 BALP=SQM4/(2D0*PMAS(24,1))**2
34800 BBET=SH/(2D0*PMAS(24,1))**2
34802 BABI=1D0/(BALP-BBET)
34803 IF(BALP.LT.1D0) THEN
34804 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34807 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34808 & -DBLE(0.5D0*PARU(1)))
34811 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34812 IF(BBET.LT.1D0) THEN
34813 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34816 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34817 & -DBLE(0.5D0*PARU(1)))
34820 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34821 IF(J.LE.3*MSTP(1)) THEN
34822 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34823 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34824 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34825 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34828 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34829 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34830 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34831 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34832 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34833 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34837 CIGTOT=CIGTOT/DBLE(SH)
34838 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34839 C...Loop over initial flavours
34840 DO 380 I=MMINA,MMAXA
34841 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34842 EI=KCHG(IABS(I),1)/3D0
34846 IF(IABS(I).LE.10) FCOI=FACA/3D0
34851 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34852 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34855 ELSEIF(ISUB.EQ.111) THEN
34856 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34857 IF(MSTP(38).NE.0) THEN
34858 C...Simple case: only do gg <-> h exactly.
34859 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34860 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34861 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34863 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34864 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34865 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34867 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34868 & '(PYSGHG:) did not find Higgs -> g g channel')
34869 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34870 & (TH**2+UH**2)/(SH*SQM4)
34872 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34873 & (TH**2+UH**2)/(SH*SQM4)
34875 C...Propagators: as simulated in PYOFSH and as desired
34876 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34877 GMMHC=SQRT(SQM4)*WDTP(0)
34878 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34879 & ((SQM4-SQMH)**2+GMMHC**2)
34880 FACGH=FACGH*HBW4C/HBW4
34882 C...Messy case: do full loop integrals
34885 DO 390 I=1,2*MSTP(1)
34889 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34890 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34891 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34892 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34893 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34894 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34895 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34896 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34898 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34899 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34900 FACGH=FACGH*WIDS(25,2)
34902 DO 400 I=MMINA,MMAXA
34903 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34904 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34912 ELSEIF(ISUB.EQ.112) THEN
34913 C...f + g -> f + h0 (q + g -> q + h0 only)
34914 IF(MSTP(38).NE.0) THEN
34915 C...Simple case: only do gg <-> h exactly.
34916 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34917 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34918 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34920 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34921 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34922 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34924 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34925 & '(PYSGHG:) did not find Higgs -> g g channel')
34926 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34927 & (SH**2+UH**2)/(-TH*SQM4)
34929 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34930 & (SH**2+UH**2)/(-TH*SQM4)
34932 C...Propagators: as simulated in PYOFSH and as desired
34933 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34934 GMMHC=SQRT(SQM4)*WDTP(0)
34935 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34936 & ((SQM4-SQMH)**2+GMMHC**2)
34937 FACQH=FACQH*HBW4C/HBW4
34939 C...Messy case: do full loop integrals
34942 DO 410 I=1,2*MSTP(1)
34946 CALL PYWAUX(1,EPST,W1TR,W1TI)
34947 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34948 CALL PYWAUX(2,EPST,W2TR,W2TI)
34949 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34950 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34951 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34952 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34953 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34955 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34956 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34957 FACQH=FACQH*WIDS(25,2)
34959 DO 430 I=MMINA,MMAXA
34960 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34962 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34963 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34966 ISIG(NCHN,3-ISDE)=21
34972 ELSEIF(ISUB.EQ.113) THEN
34973 C...g + g -> g + h0
34974 IF(MSTP(38).NE.0) THEN
34975 C...Simple case: only do gg <-> h exactly.
34976 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34977 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34978 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34980 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34981 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34982 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34984 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34985 & '(PYSGHG:) did not find Higgs -> g g channel')
34986 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34987 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34989 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34990 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34992 C...Propagators: as simulated in PYOFSH and as desired
34993 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34994 GMMHC=SQRT(SQM4)*WDTP(0)
34995 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34996 & ((SQM4-SQMH)**2+GMMHC**2)
34997 FACGH=FACGH*HBW4C/HBW4
34999 C...Messy case: do full loop integrals
35008 DO 440 I=1,2*MSTP(1)
35014 IF(EPSH.LT.1D-6) GOTO 440
35015 CALL PYWAUX(1,EPSS,W1SR,W1SI)
35016 CALL PYWAUX(1,EPST,W1TR,W1TI)
35017 CALL PYWAUX(1,EPSU,W1UR,W1UI)
35018 CALL PYWAUX(1,EPSH,W1HR,W1HI)
35019 CALL PYWAUX(2,EPSS,W2SR,W2SI)
35020 CALL PYWAUX(2,EPST,W2TR,W2TI)
35021 CALL PYWAUX(2,EPSU,W2UR,W2UI)
35022 CALL PYWAUX(2,EPSH,W2HR,W2HI)
35023 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
35024 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
35025 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
35026 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
35027 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
35028 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
35029 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
35030 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
35031 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
35032 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
35033 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
35034 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
35035 W3STUR=YHSTUR-Y3STUR-Y3UTSR
35036 W3STUI=YHSTUI-Y3STUI-Y3UTSI
35037 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
35038 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
35039 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
35040 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
35041 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
35042 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
35043 W3USTR=YHUSTR-Y3USTR-Y3TSUR
35044 W3USTI=YHUSTI-Y3USTI-Y3TSUI
35045 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
35046 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
35047 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
35048 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
35049 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
35050 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
35051 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
35052 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
35053 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
35054 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
35055 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
35056 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
35057 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
35058 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
35059 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
35060 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
35061 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
35062 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
35063 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
35064 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
35065 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
35066 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
35067 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
35068 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
35069 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
35070 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
35071 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
35072 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
35073 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
35074 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
35075 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
35076 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
35077 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
35078 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
35079 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
35080 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
35081 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
35082 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
35083 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
35084 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
35085 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
35086 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
35087 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
35088 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
35089 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
35090 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
35091 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
35092 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
35093 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
35094 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
35095 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
35096 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
35097 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
35098 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
35099 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
35100 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
35101 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
35102 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
35103 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
35104 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
35105 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
35106 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
35107 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35108 & (W2SR-W2HR+W3STUR))
35109 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
35110 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35111 & (W2TR-W2HR+W3TUSR))
35112 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
35113 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35114 & (W2UR-W2HR+W3USTR))
35115 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
35116 A2STUR=A2STUR+B2STUR+B2SUTR
35117 A2STUI=A2STUI+B2STUI+B2SUTI
35118 A2USTR=A2USTR+B2USTR+B2UTSR
35119 A2USTI=A2USTI+B2USTI+B2UTSI
35120 A2TUSR=A2TUSR+B2TUSR+B2TSUR
35121 A2TUSI=A2TUSI+B2TUSI+B2TSUI
35122 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
35123 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
35125 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
35126 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
35127 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
35128 FACGH=FACGH*WIDS(25,2)
35130 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
35139 ELSEIF(ISUB.LE.170) THEN
35140 IF(ISUB.EQ.121) THEN
35141 C...g + g -> Q + Qbar + h0
35142 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
35145 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
35146 & (0.5D0*PMF/PMAS(24,1))**2
35148 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
35150 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
35152 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
35153 IF(IA.GT.10) IKFI=3
35154 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
35155 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
35156 FACQQH=FACQQH/(1D0+RMSS(41))**2
35157 IF(IHIGG.NE.3) THEN
35158 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
35159 & PARU(151+10*IHIGG))**2
35163 CALL PYQQBH(WTQQBH)
35164 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35166 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35167 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35168 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35174 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
35177 ELSEIF(ISUB.EQ.122) THEN
35178 C...q + qbar -> Q + Qbar + h0
35181 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
35182 & (0.5D0*PMF/PMAS(24,1))**2
35184 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
35186 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
35188 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
35189 IF(IA.GT.10) IKFI=3
35190 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
35191 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
35192 FACQQH=FACQQH/(1D0+RMSS(41))**2
35193 IF(IHIGG.NE.3) THEN
35194 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
35195 & PARU(151+10*IHIGG))**2
35199 CALL PYQQBH(WTQQBH)
35200 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35202 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35203 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35204 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35206 DO 470 I=MMINA,MMAXA
35207 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35208 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
35213 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
35216 ELSEIF(ISUB.EQ.123) THEN
35217 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
35219 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
35220 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
35221 & PARU(154+10*IHIGG)**2
35222 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
35223 & (VINT(216)-VINT(209)**2))**2
35224 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
35225 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
35226 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35228 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35229 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35230 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35232 DO 490 I=MMIN1,MMAX1
35233 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
35235 DO 480 J=MMIN2,MMAX2
35236 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
35238 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
35239 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
35241 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
35242 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
35244 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
35245 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
35250 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
35254 ELSEIF(ISUB.EQ.124) THEN
35255 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
35257 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
35258 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
35259 & PARU(155+10*IHIGG)**2
35260 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
35261 & (VINT(216)-VINT(209)**2))**2
35262 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
35263 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35265 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35266 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35267 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35269 DO 510 I=MMIN1,MMAX1
35270 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
35271 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
35272 DO 500 J=MMIN2,MMAX2
35273 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
35274 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
35275 IF(EI*EJ.GT.0D0) GOTO 500
35276 FACLR=VINT(180+I)*VINT(180+J)
35281 SIGH(NCHN)=FACLR*FACWW*FACBW
35285 ELSEIF(ISUB.EQ.143) THEN
35286 C...f + fbar' -> H+/-
35287 SQMHC=PMAS(37,1)**2
35288 CALL PYWIDT(37,SH,WDTP,WDTE)
35290 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
35291 HP=AEM/(8D0*XW)*SH/SQMW*SH
35292 DO 530 I=MMIN1,MMAX1
35293 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
35295 IM=(MOD(IA,10)+1)/2
35296 DO 520 J=MMIN2,MMAX2
35297 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
35299 JM=(MOD(JA,10)+1)/2
35300 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
35301 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35303 IF(MOD(IA,2).EQ.0) THEN
35310 RML=PYMRUN(IL,SH)**2/SH
35311 RMU=PYMRUN(IU,SH)**2/SH
35312 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
35313 IF(IA.LE.10) HI=HI*FACA/3D0
35314 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35315 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
35320 SIGH(NCHN)=HI*FACBW*HF
35324 ELSEIF(ISUB.EQ.161) THEN
35325 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
35326 C...(choice of only b and t to avoid kinematics problems)
35327 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
35328 C...H propagator: as simulated in PYOFSH and as desired
35329 SQMHC=PMAS(37,1)**2
35330 GMMHC=PMAS(37,1)*PMAS(37,2)
35331 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
35332 CALL PYWIDT(37,SQM4,WDTP,WDTE)
35333 GMMHCC=SQRT(SQM4)*WDTP(0)
35334 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
35335 FHCQ=FHCQ*HBW4C/HBW4
35337 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
35338 DO 550 I=MMINA,MMAXA
35340 IF(IA.NE.5) GOTO 550
35341 SQML=PYMRUN(IA,Q2RM)**2
35343 SQMQ=PYMRUN(IUA,Q2RM)**2
35344 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
35345 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
35346 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
35347 & (SQMHC-SQMQ-SH)/SH)
35348 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
35350 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
35351 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
35354 ISIG(NCHN,3-ISDE)=21
35356 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
35357 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
35362 ELSEIF(ISUB.LE.402) THEN
35363 IF(ISUB.EQ.401) THEN
35364 C... g + g -> t + bbar + H-
35365 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
35368 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35370 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
35371 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35377 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
35378 c Since we don't know yet if H+ or H-, assume H+
35379 c when calculating suppression due to closed channels.
35380 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
35381 IF(ABS(WIDS(37,2)-WIDS(37,3))
35382 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
35383 & ABS(WIDS(6,2)-WIDS(6,3))
35384 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
35385 WRITE(*,*)'Error: Process 401 cannot handle different'
35386 WRITE(*,*)'decays for H+ and H- or t and tbar.'
35387 WRITE(*,*)'Execution stopped.'
35392 ELSEIF(ISUB.EQ.402) THEN
35393 C... q + qbar -> t + bbar + H-
35396 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35398 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
35399 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35401 DO 570 I=MMINA,MMAXA
35402 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35403 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
35408 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
35409 c Since we don't know yet if H+ or H-, assume H+
35410 c when calculating suppression due to closed channels.
35411 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
35412 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
35414 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
35416 WRITE(*,*)'Error: Process 402 cannot handle different'
35417 WRITE(*,*)'decays for H+ and H- or t and tbar.'
35418 WRITE(*,*)'Execution stopped.'
35428 C*********************************************************************
35431 C...Subprocess cross sections for SUSY processes,
35432 C...including Higgs pair production.
35433 C...Auxiliary to PYSIGH.
35435 SUBROUTINE PYSGSU(NCHN,SIGS)
35437 C...Double precision and integer declarations
35438 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35439 IMPLICIT INTEGER(I-N)
35440 INTEGER PYK,PYCHGE,PYCOMP
35441 C...Parameter statement to help give large particle numbers.
35442 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35443 &KEXCIT=4000000,KDIMEN=5000000)
35445 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35446 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35447 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35448 COMMON/PYINT1/MINT(400),VINT(400)
35449 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35450 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35451 COMMON/PYINT4/MWID(500),WIDS(500,5)
35452 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35453 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35454 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35455 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35456 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35457 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35458 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35459 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
35460 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
35461 C...Local arrays and complex variables
35462 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35463 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
35464 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
35465 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
35468 C...Z and W width, combinations of weak mixing angle
35472 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35474 C...Convert almost equivalent SUSY processes into each other
35475 C...Extract differences in flavours and couplings
35477 C...Sleptons and sneutrinos
35478 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
35479 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35482 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
35483 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35486 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
35487 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35489 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
35490 IF(ISUB.EQ.210) THEN
35492 ELSEIF(ISUB.EQ.211) THEN
35494 ELSEIF(ISUB.EQ.212) THEN
35498 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
35499 IF(ISUB.EQ.213) THEN
35500 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35502 ELSEIF(ISUB.EQ.214) THEN
35509 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
35510 IF(ISUB.EQ.216) THEN
35513 ELSEIF(ISUB.EQ.217) THEN
35516 ELSEIF(ISUB.EQ.218) THEN
35519 ELSEIF(ISUB.EQ.219) THEN
35522 ELSEIF(ISUB.EQ.220) THEN
35525 ELSEIF(ISUB.EQ.221) THEN
35528 ELSEIF(ISUB.EQ.222) THEN
35531 ELSEIF(ISUB.EQ.223) THEN
35534 ELSEIF(ISUB.EQ.224) THEN
35537 ELSEIF(ISUB.EQ.225) THEN
35544 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
35545 IF(ISUB.EQ.226) THEN
35548 ELSEIF(ISUB.EQ.227) THEN
35551 ELSEIF(ISUB.EQ.228) THEN
35557 C...Neutralino + chargino
35558 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
35559 IF(ISUB.EQ.229) THEN
35562 ELSEIF(ISUB.EQ.230) THEN
35565 ELSEIF(ISUB.EQ.231) THEN
35568 ELSEIF(ISUB.EQ.232) THEN
35571 ELSEIF(ISUB.EQ.233) THEN
35574 ELSEIF(ISUB.EQ.234) THEN
35577 ELSEIF(ISUB.EQ.235) THEN
35580 ELSEIF(ISUB.EQ.236) THEN
35586 C...Gluino + neutralino
35587 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
35588 IF(ISUB.EQ.237) THEN
35590 ELSEIF(ISUB.EQ.238) THEN
35592 ELSEIF(ISUB.EQ.239) THEN
35594 ELSEIF(ISUB.EQ.240) THEN
35599 C...Gluino + chargino
35600 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
35601 IF(ISUB.EQ.241) THEN
35603 ELSEIF(ISUB.EQ.242) THEN
35608 C...Squark + neutralino
35609 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
35611 IF(MOD(ISUB,2).NE.0) ILR=1
35612 IF(ISUB.LE.247) THEN
35614 ELSEIF(ISUB.LE.249) THEN
35616 ELSEIF(ISUB.LE.251) THEN
35618 ELSEIF(ISUB.LE.253) THEN
35624 C...Squark + chargino
35625 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
35626 IF(ISUB.LE.255) THEN
35628 ELSEIF(ISUB.LE.257) THEN
35631 IF(MOD(ISUB,2).EQ.0) THEN
35639 C...Squark + gluino
35640 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
35645 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
35647 IF(ISUB.EQ.262) ILR=1
35649 ELSEIF(ISUB.EQ.265) THEN
35653 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
35655 IF(ISUB.LE.273) THEN
35656 IF(ISUB.EQ.273) ILR=1
35659 ELSEIF(ISUB.LE.276) THEN
35660 IF(ISUB.EQ.276) ILR=1
35663 ELSEIF(ISUB.LE.278) THEN
35664 IF(ISUB.EQ.278) ILR=1
35668 IF(ISUB.EQ.280) ILR=1
35673 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35675 IF(ISUB.LE.283) THEN
35676 IF(ISUB.EQ.283) ILR=1
35679 ELSEIF(ISUB.LE.286) THEN
35680 IF(ISUB.EQ.286) ILR=1
35683 ELSEIF(ISUB.LE.288) THEN
35684 IF(ISUB.EQ.288) ILR=1
35687 ELSEIF(ISUB.LE.290) THEN
35688 IF(ISUB.EQ.290) ILR=1
35691 ELSEIF(ISUB.LE.293) THEN
35692 IF(ISUB.EQ.293) ILR=1
35695 ELSEIF(ISUB.EQ.296) THEN
35699 C...Squark + gluino
35700 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35705 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35706 IF(ISUB.EQ.297) THEN
35707 RKF=.5D0*PARU(195)**2
35708 ELSEIF(ISUB.EQ.298) THEN
35709 RKF=.5D0*(1D0-PARU(195)**2)
35713 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35714 IF(ISUB.EQ.299) THEN
35717 ELSEIF(ISUB.EQ.300) THEN
35723 ELSEIF(ISUB.EQ.301) THEN
35729 C...Supersymmetric processes - all of type 2 -> 2 :
35730 C...correct final-state Breit-Wigners from fixed to running width.
35731 IF(MSTP(42).GT.0) THEN
35733 KFLW=KFPR(ISUBSV,I)
35735 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35736 IF(I.EQ.1) SQMI=SQM3
35737 IF(I.EQ.2) SQMI=SQM4
35738 SQMS=PMAS(KCW,1)**2
35739 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35740 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35741 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35742 GMMI=SQRT(SQMI)*WDTP(0)
35743 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35744 COMFAC=COMFAC*(HBWI/HBWS)
35748 C...Differential cross section expressions.
35750 IF(ISUB.LE.210) THEN
35751 IF(ISUB.EQ.201) THEN
35752 C...f + fbar -> e_L + e_Lbar
35753 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35754 DO 130 I=MMIN1,MMAX1
35756 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35758 TT3I=SIGN(1D0,EI+1D-6)/2D0
35762 C...Color factor for e+ e-
35763 IF(IA.GE.11) FCOL=3D0
35764 IF(ISUBSV.EQ.301) THEN
35767 ELSEIF(ILR.EQ.1) THEN
35768 A1=SFMIX(KFID,3)**2
35769 A2=SFMIX(KFID,4)**2
35770 ELSEIF(ILR.EQ.0) THEN
35771 A1=SFMIX(KFID,1)**2
35772 A2=SFMIX(KFID,2)**2
35774 XLQ=(TT3J-EJ*XW)*A1
35778 TAA=(EI*EJ)**2*(POLL+POLR)
35779 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35780 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35781 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35782 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35786 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35792 DK=1D0/(TH-SMZ(II)**2)
35793 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35795 FREK=FAC2*TANW*EI*ZMIX(II,1)
35796 TNN1=TNN1+FLEK**2*DK
35797 TNN2=TNN2+FREK**2*DK
35799 DL=1D0/(TH-SMZ(JJ)**2)
35800 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35802 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35803 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35806 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35807 & A2**2*TNN2**2*POLR)
35808 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35809 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35810 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35811 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35812 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35815 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35818 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35819 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35820 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35825 SIGH(NCHN)=FACQQ1+FACQQ2
35828 ELSEIF(ISUB.EQ.203) THEN
35829 C...f + fbar -> e_L + e_Rbar
35830 DO 160 I=MMIN1,MMAX1
35832 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35833 EI=KCHG(IABS(I),1)/3D0
35834 TT3I=SIGN(1D0,EI)/2D0
35838 C...Color factor for e+ e-
35839 IF(IA.GE.11) FCOL=3D0
35840 A1=SFMIX(KFID,1)**2
35841 A2=SFMIX(KFID,2)**2
35846 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35847 & /XW**2/XW1**2*A1*A2
35848 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35853 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35859 DK=1D0/(TH-SMZ(II)**2)
35860 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35862 FREK=FAC2*TANW*EI*ZMIX(II,1)
35863 TNN1=TNN1+FLEK**2*DK
35864 TNN2=TNN2+FREK**2*DK
35866 DL=1D0/(TH-SMZ(JJ)**2)
35867 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35869 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35870 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35873 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35874 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35875 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35876 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35877 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35878 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35881 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35882 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35883 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35889 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35890 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35895 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35896 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35899 ELSEIF(ISUB.EQ.210) THEN
35900 C...q + qbar' -> W*- > ~l_L + ~nu_L
35901 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35902 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35903 DO 180 I=MMIN1,MMAX1
35905 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35906 DO 170 J=MMIN2,MMAX2
35908 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35909 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35911 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35912 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35914 IF(KCHSUM.LT.0) KCHW=3
35919 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35920 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35921 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35923 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35924 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35926 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35931 ELSEIF(ISUB.LE.220) THEN
35932 IF(ISUB.EQ.213) THEN
35933 C...f + fbar -> ~nu_L + ~nu_Lbar
35934 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35935 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35936 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35938 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35941 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35944 DO 190 I=MMIN1,MMAX1
35946 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35949 C...Color factor for e+ e-
35950 IF(IA.GE.11) FCOL=3D0
35951 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35955 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35956 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35959 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35961 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35967 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35968 & *AEM**2*FCOL/3D0/XW**2
35971 ELSEIF(ISUB.EQ.216) THEN
35972 C...q + qbar -> ~chi0_1 + ~chi0_1
35973 IF(IZID1.EQ.IZID2) THEN
35974 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35976 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35977 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35979 FACXX=COMFAC*AEM**2/3D0/XW**2
35980 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35983 WU2 = (UH-ZM12)*(UH-ZM22)
35984 WT2 = (TH-ZM12)*(TH-ZM22)
35985 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35986 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35987 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35989 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35990 IF(IZID2.NE.IZID1) THEN
35991 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35994 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35995 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35997 DO 210 I=MMINA,MMAXA
35998 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35999 EI=KCHG(IABS(I),1)/3D0
36000 T3I=SIGN(1D0,EI+1D-6)/2D0
36001 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
36002 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
36003 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
36004 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
36005 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
36006 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
36007 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
36009 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
36010 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
36011 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
36013 IF(IABS(I).GE.11) FCOL=3D0
36014 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
36015 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
36016 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
36017 & QRL*DCONJG(QRR)*POLR)*WS2
36022 SIGH(NCHN)=FACXX*FACGG1*FCOL
36026 ELSEIF(ISUB.LE.230) THEN
36027 IF(ISUB.EQ.226) THEN
36028 C...f + fbar -> ~chi+_1 + ~chi-_1
36029 FACXX=COMFAC*AEM**2/3D0
36032 WU2 = (UH-ZM12)*(UH-ZM22)
36033 WT2 = (TH-ZM12)*(TH-ZM22)
36034 WS2 = SMW(IZID1)*SMW(IZID2)*SH
36035 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
36036 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
36038 IF(IZID1.EQ.IZID2) DIFF=1D0
36040 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
36041 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
36042 IF(IZID2.NE.IZID1) THEN
36043 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
36044 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
36047 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
36048 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
36049 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
36050 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
36051 DO 230 I=MMINA,MMAXA
36052 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
36053 EI=KCHG(IABS(I),1)/3D0
36054 T3I=SIGN(1D0,EI+1D-6)/2D0
36055 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
36056 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
36057 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
36058 IF(MOD(I,2).EQ.0) THEN
36059 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
36060 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
36061 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
36062 & DCMPLX(T3I/XW/(TH-XML2))
36064 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
36065 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
36066 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
36067 & DCMPLX(T3I/XW/(TH-XML2))
36070 IF(IABS(I).GE.11) FCOL=3D0
36071 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
36072 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
36073 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
36074 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
36079 IF(IZID1.EQ.IZID2) THEN
36080 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36082 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
36083 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36088 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36089 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
36093 ELSEIF(ISUB.EQ.229) THEN
36094 C...q + qbar' -> ~chi0_1 + ~chi+-_1
36095 FACXX=COMFAC*AEM**2/6D0/XW**2
36098 WU2 = (UH-ZM12)*(UH-ZM22)
36099 WT2 = (TH-ZM12)*(TH-ZM22)
36100 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
36101 RT2I = 1D0/SQRT(2D0)
36102 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
36103 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
36105 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
36106 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
36109 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
36111 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
36112 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
36113 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
36114 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
36116 DO 270 I=MMIN1,MMAX1
36118 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
36120 T3I=SIGN(1D0,EI+1D-6)/2D0
36121 DO 260 J=MMIN2,MMAX2
36123 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
36124 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
36126 T3J=SIGN(1D0,EJ+1D-6)/2D0
36128 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
36129 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
36131 IF(KCHSUM.LT.0) KCHW=3
36132 IF(MOD(IA,2).EQ.0) THEN
36133 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
36134 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
36135 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
36136 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
36137 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
36138 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
36141 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
36142 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
36143 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
36144 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
36145 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
36146 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
36149 ZINTR=DBLE(QLR*DCONJG(QLL))
36150 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
36156 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36157 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
36162 ELSEIF(ISUB.LE.240) THEN
36163 IF(ISUB.EQ.237) THEN
36164 C...q + qbar -> gluino + ~chi0_1
36165 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36166 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36168 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
36171 DO 280 I=MMINA,MMAXA
36172 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36173 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
36174 EI=KCHG(IABS(I),1)/3D0
36176 XLQC = -TANW*EI*ZMIX(IZID,1)
36177 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
36178 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
36181 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
36182 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
36183 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
36184 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
36185 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
36186 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
36187 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
36188 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
36189 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
36190 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
36195 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
36199 ELSEIF(ISUB.LE.250) THEN
36200 IF(ISUB.EQ.241) THEN
36201 C...q + qbar' -> ~chi+-_1 + gluino
36202 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
36205 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
36206 FAC0=UMIX(IZID,1)**2
36207 FAC1=VMIX(IZID,1)**2
36208 DO 300 I=MMIN1,MMAX1
36210 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
36211 DO 290 J=MMIN2,MMAX2
36213 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
36214 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
36216 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
36217 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
36219 IF(KCHSUM.LT.0) KCHW=3
36220 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
36221 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
36222 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
36223 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
36224 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
36225 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
36226 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
36227 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
36228 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
36229 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
36230 & SH/(TH-XMU2)/(UH-XMD2))/2D0
36235 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
36236 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36237 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
36241 ELSEIF(ISUB.EQ.243) THEN
36242 C...q + qbar -> gluino + gluino
36243 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36246 DO 310 I=MMINA,MMAXA
36247 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36248 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
36250 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
36251 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
36252 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
36253 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
36254 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
36255 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
36256 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
36257 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
36258 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
36259 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
36260 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
36261 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
36265 C...1/2 for identical particles
36266 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
36269 ELSEIF(ISUB.EQ.244) THEN
36270 C...g + g -> gluino + gluino
36271 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36274 FACQQ1=COMFAC*AS**2*9D0/4D0*(
36275 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
36276 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
36277 FACQQ2=COMFAC*AS**2*9D0/4D0*(
36278 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
36279 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
36280 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
36281 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
36282 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
36287 SIGH(NCHN)=FACQQ1/2D0
36292 SIGH(NCHN)=FACQQ2/2D0
36297 SIGH(NCHN)=FACQQ3/2D0
36300 ELSEIF(ISUB.EQ.246) THEN
36301 C...g + q_j -> ~chi0_1 + ~q_j
36302 FAC0=COMFAC*AS*AEM/6D0/XW
36305 FACZQ0=FAC0*( (ZM2-TH)/SH +
36306 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
36307 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
36308 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36309 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
36310 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
36311 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
36312 EI=KCHG(IABS(I),1)/3D0
36314 XRQZ = -TANW*EI*ZMIX(IZID,1)
36315 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
36316 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
36318 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
36320 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
36326 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
36327 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
36330 ISIG(NCHN,3-ISDE)=21
36332 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36333 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36338 ELSEIF(ISUB.LE.260) THEN
36339 IF(ISUB.EQ.254) THEN
36340 C...g + q_j -> ~chi1_1 + ~q_i
36341 FAC0=COMFAC*AS*AEM/12D0/XW
36346 FACZQ0=FAC0*( (ZM2-TH)/SH +
36347 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
36348 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
36349 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
36350 IF(MOD(KFNSQ1,2).EQ.0) THEN
36357 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
36358 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
36359 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
36361 IF(MOD(IA,2).EQ.0) THEN
36366 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
36370 IF(I.LT.0) KCHWQ=5-KCHW
36372 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
36373 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
36376 ISIG(NCHN,3-ISDE)=21
36378 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36379 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
36383 ELSEIF(ISUB.EQ.258) THEN
36384 C...g + q_j -> gluino + ~q_i
36391 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
36392 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
36393 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
36394 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
36395 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
36397 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
36398 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
36399 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
36401 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
36402 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
36403 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36404 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
36405 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
36406 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
36409 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36410 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36412 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
36413 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
36416 ISIG(NCHN,3-ISDE)=21
36418 SIGH(NCHN)=FACQG1*FACSEL
36421 ISIG(NCHN,3-ISDE)=21
36423 SIGH(NCHN)=FACQG2*FACSEL
36428 ELSEIF(ISUB.LE.270) THEN
36429 IF(ISUB.EQ.261) THEN
36430 C...q_i + q_ibar -> ~t_1 + ~t_1bar
36431 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
36432 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36433 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36435 DO 390 I=MMIN1,MMAX1
36437 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
36438 IF(IA.GE.11.AND.IA.LE.18) THEN
36440 EJ=KCHG(KFNSQ,1)/3D0
36441 T3I=SIGN(1D0,EI)/2D0
36442 T3J=SIGN(1D0,EJ)/2D0
36443 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
36444 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
36445 XLF=2D0*(T3I-EI*XW)
36447 TAA=0.5D0*(EI*EJ)**2
36448 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
36449 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36450 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
36451 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
36452 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
36458 SIGH(NCHN)=FACQQ1*FAC0
36461 ELSEIF(ISUB.EQ.263) THEN
36462 C...f + fbar -> ~t1 + ~t2bar
36463 DO 400 I=MMIN1,MMAX1
36465 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
36466 EI=KCHG(IABS(I),1)/3D0
36467 TT3I=SIGN(1D0,EI)/2D0
36471 C...Color factor for e+ e-
36472 IF(IA.GE.11) FCOL=3D0
36473 XLQ=2D0*(TT3J-EJ*XW)
36475 XLF=2D0*(TT3I-EI*XW)
36477 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
36478 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
36479 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36480 C...Factor of 2 for t1 t2bar + t2 t1bar
36481 C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels.
36482 FACQQ1=COMFAC*AEM**2*TZZ*FCOL*4D0
36483 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
36488 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36489 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
36494 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
36495 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36498 ELSEIF(ISUB.EQ.264) THEN
36499 C...g + g -> ~t_1 + ~t_1bar
36502 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
36503 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36504 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36505 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36506 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
36520 ELSEIF(ISUB.LE.280) THEN
36521 IF(ISUB.EQ.271) THEN
36522 C...q + q' -> ~q + ~q' (~g exchange)
36523 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
36532 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
36533 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
36536 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
36537 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
36538 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
36541 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
36542 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
36543 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
36544 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
36546 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36549 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
36550 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
36552 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36553 IF(I*J.LT.0) GOTO 420
36558 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36559 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36562 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
36563 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
36565 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
36566 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36567 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36574 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
36575 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
36577 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
36578 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36579 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36585 ELSEIF(ISUB.EQ.274) THEN
36586 C...q + qbar' -> ~q + ~qbar'
36587 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
36591 C...Mrenna...Normalization.and.1/XMT
36592 FACQQ1=COMFAC*AS**2*2D0/9D0*(
36593 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
36594 FACQQB=COMFAC*AS**2*4D0/9D0*(
36595 & (UH*TH-SQM3*SQM4)/SH2 )
36596 FACQQI=-COMFAC*AS**2*4D0/27D0*(
36597 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
36598 FACQQB=FACQQB+FACQQ1+FACQQI
36600 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
36603 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
36604 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
36605 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
36606 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
36608 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
36611 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
36612 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
36614 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
36615 IF(I*J.GT.0) GOTO 440
36620 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36621 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
36622 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
36623 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36627 ELSEIF(ISUB.EQ.277) THEN
36628 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
36629 C...if i .eq. j covered in 274
36630 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
36631 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36633 DO 460 I=MMIN1,MMAX1
36635 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
36636 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36637 IF(IA.EQ.KFNSQ) GOTO 460
36638 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
36640 EJ=KCHG(KFNSQ,1)/3D0
36642 T3I=SIGN(1D0,EI)/2D0
36644 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
36645 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
36647 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
36648 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
36650 XLF=2D0*(T3I-EI*XW)
36657 TAA=0.5D0*(EI*EJ)**2
36658 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
36659 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36660 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
36661 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
36662 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
36663 ELSEIF(IA.LE.6) THEN
36664 FAC0=AS**2*8D0/9D0/2D0
36670 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36673 ELSEIF(ISUB.EQ.279) THEN
36674 C...g + g -> ~q_j + ~q_jbar
36677 C...4=RKF because ~t ~tbar and ~b ~bbar treated separately
36678 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36679 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36680 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36681 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36686 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36691 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36701 C*********************************************************************
36704 C...Subprocess cross sections for Technicolor processes.
36705 C...Auxiliary to PYSIGH.
36707 SUBROUTINE PYSGTC(NCHN,SIGS)
36709 C...Double precision and integer declarations
36710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36711 IMPLICIT INTEGER(I-N)
36712 INTEGER PYK,PYCHGE,PYCOMP
36713 C...Parameter statement to help give large particle numbers.
36714 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36715 &KEXCIT=4000000,KDIMEN=5000000)
36717 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36718 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36719 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36720 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36721 COMMON/PYINT1/MINT(400),VINT(400)
36722 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36723 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36724 COMMON/PYINT4/MWID(500),WIDS(500,5)
36725 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36726 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36727 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36728 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36729 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36730 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36731 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36732 C...Local arrays and complex variables
36733 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36734 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36735 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36736 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36737 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36738 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36739 COMPLEX*16 DVVS,DVVT,DVVU
36742 C...Combinations of weak mixing angle.
36744 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36746 C...Convert almost equivalent technicolor processes into
36747 C...a few basic processes, and set distinguishing parameters.
36748 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36751 SN2W=2D0*SQRT(XW*XW1)
36754 CSXI=COS(ASIN(RTCM(3)))
36755 CSXIP=COS(ASIN(RTCM(4)))
36756 QUPD=2D0*RTCM(2)-1D0
36757 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36768 C... rho_tc0, etc. -> W_L W_L, W_L W_T
36769 IF(ISUB.EQ.361) THEN
36773 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36774 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36775 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36776 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36777 AXGP = SQRT(2D0)*AXGP
36778 ARGP = SQRT(2D0)*ARGP
36779 VOGP = SQRT(2D0)*VOGP
36780 C... rho_tc0 -> W_L pi_tc-
36781 ELSEIF(ISUB.EQ.362) THEN
36785 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36787 ELSEIF(ISUB.EQ.363) THEN
36791 CAB2=(1D0-RTCM(3)**2)**2
36792 C... rho_tc0/omega_tc -> gamma pi_tc
36793 ELSEIF(ISUB.EQ.364) THEN
36800 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36802 ELSEIF(ISUB.EQ.365) THEN
36806 VRGP=CSXIP/RTCM(12)
36808 VAGP=2D0*Q2UD*CSXIP
36809 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36811 ELSEIF(ISUB.EQ.366) THEN
36815 VOGP=CSXI*CT2W/RTCM(12)
36816 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36817 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36818 VZGP=-QUPD*CSXI*CS2W/XW1
36820 ELSEIF(ISUB.EQ.367) THEN
36824 C...RTCM(48) is the M_V for the techni-a
36825 VXGP=-CSXIP/SN2W/RTCM(48)
36826 VRGP=CSXIP*CT2W/RTCM(12)
36827 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36828 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36829 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36831 ELSEIF(ISUB.EQ.368) THEN
36835 C...RTCM(49) is the M_A for the techni-a
36836 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36837 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36838 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36839 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36840 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36841 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36842 ELSEIF(ISUB.EQ.370) THEN
36846 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36847 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36849 ELSEIF(ISUB.EQ.371) THEN
36853 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36855 ELSEIF(ISUB.EQ.372) THEN
36859 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36861 ELSEIF(ISUB.EQ.373) THEN
36865 CAB2=(1D0-RTCM(3)**2)**2
36867 ELSEIF(ISUB.EQ.374) THEN
36871 VRGP=QUPD*CSXI/RTCM(12)
36872 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36873 AXGP=-CSXI/RTCM(49)
36875 ELSEIF(ISUB.EQ.375) THEN
36879 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36880 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36881 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36882 AXGP=-CSXI*CT2W/RTCM(49)
36884 ELSEIF(ISUB.EQ.376) THEN
36889 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36890 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36892 ELSEIF(ISUB.EQ.377) THEN
36896 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36897 VWGP=CSXIP/(2D0*XW)
36898 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36900 ELSEIF(ISUB.EQ.378) THEN
36904 VRGP=QUPD*RTCM(3)/RTCM(12)
36905 AXGP=-RTCM(3)/RTCM(49)
36907 ELSEIF(ISUB.EQ.379) THEN
36911 VOGP=RTCM(3)/RTCM(12)
36912 VRGP=QUPD*RTCM(3)/RTCM(12)
36913 ELSEIF(ISUB.EQ.380) THEN
36917 VOGP=RTCM(3)*CT2W/RTCM(12)
36918 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36922 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36923 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36924 IF(ITCM(5).LE.4) THEN
36942 ELSEIF(ITCM(5).EQ.5) THEN
36944 IF(ITCM(2).EQ.0) THEN
36949 ALPRHT=2.16D0*(3D0/ITCM(1))
36950 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36951 SINT3=TANT3/SQRT(TANT3**2+1D0)
36952 XIG=SQRT(PYALPS(SH)/ALPRHT)
36953 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36954 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36955 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36956 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36957 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36958 & SINT3**2)*2D0/SIN2T
36959 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36960 & SINT3**2)*2D0/SIN2T
36962 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36963 SM1112=X12*RTCM(28)**2*SIN2T
36964 SM1121=-X21*RTCM(28)**2*SIN2T
36967 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36968 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36971 ZTC(1,1)=DCMPLX(SH,0D0)
36972 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36973 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36974 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36975 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36976 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36977 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36978 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36979 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36980 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36981 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36982 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36984 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36988 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36989 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36990 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36991 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
37004 CALL PYLDCM(ZTC,6,6,INDX,D)
37008 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37013 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37019 XIG=SQRT(PYALPS(-TH)/ALPRHT)
37021 ZTC(1,1)=DCMPLX(TH)
37022 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
37023 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
37024 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
37025 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
37026 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
37028 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
37032 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
37033 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
37034 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
37035 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
37047 CALL PYLDCM(ZTC,6,6,INDX,D)
37051 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37055 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37061 XIG=SQRT(PYALPS(-UH)/ALPRHT)
37063 ZTC(1,1)=DCMPLX(UH,0D0)
37064 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
37065 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
37066 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
37067 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
37068 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
37070 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
37074 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
37075 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
37076 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
37077 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
37089 CALL PYLDCM(ZTC,6,6,INDX,D)
37093 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37097 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37104 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
37105 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
37106 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
37107 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
37108 DQGS=DGGS-DGVS*DCMPLX(TANT3)
37109 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37111 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
37112 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
37113 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
37114 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
37115 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37116 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37119 SQDQTS=ABS(DQTS)**2
37120 SQDQQS=ABS(DQQS)**2
37121 SQDQQT=ABS(DQQT)**2
37122 SQDQQU=ABS(DQQU)**2
37123 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
37125 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
37127 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
37129 SQDGGS=ABS(DGGS)**2
37130 SQDGGT=ABS(DGGT)**2
37131 SQDGGU=ABS(DGGU)**2
37135 REDGTU=DBLE(DGGU*DCONJG(DGGT))
37136 REDGSU=DBLE(DGGU*DCONJG(DGGS))
37137 REDGST=DBLE(DGGS*DCONJG(DGGT))
37138 REDQST=DBLE(DQQS*DCONJG(DQQT))
37139 REDQTU=DBLE(DQQT*DCONJG(DQQU))
37144 C...Differential cross section expressions.
37146 IF(ISUB.LE.190) THEN
37147 IF(ISUB.EQ.149) THEN
37148 C...g + g -> eta_tc
37149 KCTC=PYCOMP(KTECHN+331)
37150 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
37152 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
37153 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37155 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
37157 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37162 SIGH(NCHN)=HI*FACBW*HF
37165 ELSEIF(ISUB.EQ.165) THEN
37166 C...q + qbar -> l+ + l- (including contact term for compositeness)
37167 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37168 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37169 KFF=IABS(KFPR(ISUB,1))
37171 AF=SIGN(1D0,EF+0.1D0)
37176 IF(KFF.LE.10) FCOF=3D0
37178 IF(KFF.EQ.6) WID2=WIDS(6,1)
37179 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
37180 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
37181 DO 260 I=MMINA,MMAXA
37182 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
37183 EI=KCHG(IABS(I),1)/3D0
37184 AI=SIGN(1D0,EI+0.1D0)
37189 IF(IABS(I).LE.10) FCOI=FACA/3D0
37190 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
37191 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
37192 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
37193 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
37195 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
37196 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
37198 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
37199 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
37200 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
37201 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
37202 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
37207 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
37210 ELSEIF(ISUB.EQ.166) THEN
37211 C...q + q'bar -> l + nu_l (including contact term for compositeness)
37212 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
37213 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
37214 KFF=IABS(KFPR(ISUB,1))
37216 IF(KFF.LE.10) FCOF=3D0
37217 DO 280 I=MMIN1,MMAX1
37218 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
37220 DO 270 J=MMIN2,MMAX2
37221 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
37223 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
37224 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37227 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37229 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
37230 & MOD(J,2).EQ.0)) THEN
37231 IF(KFF.EQ.5) WID2=WIDS(6,2)
37232 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
37233 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
37235 IF(KFF.EQ.5) WID2=WIDS(6,3)
37236 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
37237 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
37243 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
37244 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
37245 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
37250 ELSEIF(ISUB.LE.200) THEN
37251 IF(ISUB.EQ.191) THEN
37252 C...q + qbar -> rho_tc0.
37253 KCTC=PYCOMP(KTECHN+113)
37254 SQMRHT=PMAS(KCTC,1)**2
37255 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37257 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
37258 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37259 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37260 ALPRHT=2.16D0*(3D0/ITCM(1))
37261 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
37262 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
37263 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37264 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37265 DO 290 I=MMINA,MMAXA
37266 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
37268 EI=KCHG(IABS(I),1)/3D0
37269 AI=SIGN(1D0,EI+0.1D0)
37273 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
37274 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
37275 IF(IA.LE.10) HI=HI*FACA/3D0
37280 SIGH(NCHN)=HI*FACBW*HF
37283 ELSEIF(ISUB.EQ.192) THEN
37284 C...q + qbar' -> rho_tc+/-.
37285 KCTC=PYCOMP(KTECHN+213)
37286 SQMRHT=PMAS(KCTC,1)**2
37287 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37289 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
37290 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37291 ALPRHT=2.16D0*(3D0/ITCM(1))
37292 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
37293 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
37294 DO 310 I=MMIN1,MMAX1
37295 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
37297 DO 300 J=MMIN2,MMAX2
37298 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
37300 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
37301 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37303 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37304 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
37306 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37311 SIGH(NCHN)=HI*FACBW*HF
37315 ELSEIF(ISUB.EQ.193) THEN
37316 C...q + qbar -> omega_tc0.
37317 KCTC=PYCOMP(KTECHN+223)
37318 SQMOMT=PMAS(KCTC,1)**2
37319 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37321 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
37322 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37323 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37324 ALPRHT=2.16D0*(3D0/ITCM(1))
37325 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
37326 & (2D0*RTCM(2)-1D0)**2
37327 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37328 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37329 DO 320 I=MMINA,MMAXA
37330 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37332 EI=KCHG(IABS(I),1)/3D0
37333 AI=SIGN(1D0,EI+0.1D0)
37337 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
37338 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
37339 IF(IA.LE.10) HI=HI*FACA/3D0
37344 SIGH(NCHN)=HI*FACBW*HF
37347 ELSEIF(ISUB.EQ.194) THEN
37348 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
37349 C...Default final state is e+e-
37351 ALPRHT=2.16D0*(3D0/ITCM(1))
37354 SN2W=2D0*SQRT(XW*XW1)
37355 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
37356 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
37358 QUPD=2D0*RTCM(2)-1D0
37359 FAR=SQRT(AEM/ALPRHT)
37363 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37364 FZX=-FAR/SN2W*RTCM(47)
37370 CALL PYWIDT(23,SH,WDTP,WDTE)
37371 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
37372 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37373 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
37374 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37375 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
37376 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
37377 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
37378 C...Propagator including a_T^0
37379 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
37380 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
37381 C...Add in techni-a contribution
37382 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
37383 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
37384 $ SFZX*SSMR*SSMO)/DETD/SH
37385 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
37386 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
37388 XWRHT=1D0/(4D0*XW*(1D0-XW))
37389 KFF=IABS(KFPR(ISUB,1))
37391 AF=SIGN(1D0,EF+0.1D0)
37396 IF(KFF.LE.10) FCOF=3D0
37399 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
37400 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
37401 DZZ=DZZ*DCMPLX(XWRHT,0D0)
37402 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
37404 DO 330 I=MMINA,MMAXA
37405 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
37406 EI=KCHG(IABS(I),1)/3D0
37407 AI=SIGN(1D0,EI+0.1D0)
37412 IF(IABS(I).LE.10) FCOI=FCOI/3D0
37413 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
37414 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
37415 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
37416 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
37417 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
37418 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
37423 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
37426 ELSEIF(ISUB.EQ.195) THEN
37427 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
37430 ALPRHT=2.16D0*(3D0/ITCM(1))
37431 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
37433 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
37434 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37436 C...Propagator including a_T^+
37438 CALL PYWIDT(24,SH,WDTP,WDTE)
37439 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
37440 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37441 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
37442 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
37443 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
37444 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
37445 & DCMPLX(FWX**2,0D0)*SSMR
37446 DWW=SSMR*SSMX/DETD/SH
37448 IF(KFA.LE.8) FCOF=3D0
37449 HP=FACTC*ABS(DWW)**2*FCOF
37451 DO 350 I=MMIN1,MMAX1
37452 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
37454 DO 340 J=MMIN2,MMAX2
37455 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
37457 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
37458 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37460 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37462 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
37467 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
37472 ELSEIF(ISUB.LE.380) THEN
37473 ALPRHT=2.16D0*(3D0/ITCM(1))
37474 IF(ISUB.EQ.361) THEN
37475 FAR=SQRT(AEM/ALPRHT)
37479 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37480 FZX=-FAR/SN2W*RTCM(47)
37486 CALL PYWIDT(23,SH,WDTP,WDTE)
37487 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
37488 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37489 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
37490 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37491 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
37492 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
37493 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
37494 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
37495 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
37496 C...Add in techni-a contribution
37497 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
37498 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
37499 $ SFZX*FAR*SSMO)/DETD/SH
37500 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
37501 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
37502 $ SFZX*FAO*SSMR)/DETD/SH
37503 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
37504 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
37505 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
37506 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
37507 $ SFZX*SSMR*SSMO)/DETD/SH
37508 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
37509 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
37511 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
37512 C...W+W-, W pi_tc, pi_T pi_T, etc.
37513 FACA=(SH**2*BE34**2-(TH-UH)**2)
37514 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
37515 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
37516 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
37517 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
37518 DO 370 I=MMINA,MMAXA
37519 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
37521 EI=KCHG(IABS(I),1)/3D0
37522 AI=SIGN(1D0,EI+0.1D0)
37524 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
37525 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
37526 C...........Eqs. (5) and (6) in LSTC-rates.pdf
37527 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
37528 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
37529 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
37530 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
37531 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
37532 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
37533 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
37534 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
37535 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
37536 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
37537 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
37538 C...........Eqs. (5) and (7) in LSTC-rates.pdf
37539 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
37540 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
37541 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
37542 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
37543 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
37544 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
37545 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
37547 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
37549 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37550 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37551 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37552 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37553 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
37554 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
37555 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
37557 IF(IA.LE.10) HI=HI/3D0
37562 IF(KFA.EQ.KFB) THEN
37563 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
37564 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
37565 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
37570 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
37572 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
37576 ELSEIF(ISUB.EQ.370) THEN
37577 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
37578 C...f + fbar' -> gamma pi_tc, etc.
37579 FACA=(SH**2*BE34**2-(TH-UH)**2)
37580 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
37581 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
37582 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
37583 ALPRHT=2.16D0*(3D0/ITCM(1))
37584 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
37585 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
37586 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37588 CALL PYWIDT(24,SH,WDTP,WDTE)
37589 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
37590 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37591 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
37592 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
37593 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
37594 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
37595 & DCMPLX(FWX**2,0D0)*SSMR
37596 DWW=SSMR*SSMX/DETD/SH
37597 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
37598 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
37599 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
37600 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
37602 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
37604 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
37605 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
37606 C...Add in W_L Z_T axial and vector contributions.
37607 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
37608 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
37609 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
37610 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
37611 DO 410 I=MMIN1,MMAX1
37612 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
37614 DO 400 J=MMIN2,MMAX2
37615 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
37617 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
37618 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37620 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37622 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
37627 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
37628 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
37630 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
37631 & WIDS(PYCOMP(KFB),2)
37637 ELSEIF(ISUB.LE.390) THEN
37638 IF(ISUB.EQ.381) THEN
37639 C...f + f' -> f + f' (g exchange)
37640 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
37641 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
37642 & MSTP(34)*2D0/3D0*UH2*REDQST)
37643 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
37644 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
37645 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
37646 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
37647 C...Modifications from contact interactions (compositeness)
37648 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
37649 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
37650 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
37651 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
37652 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
37653 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
37654 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
37655 ELSEIF(ITCM(5).EQ.5) THEN
37660 CSM.......Check this change from
37664 DO 430 I=MMIN1,MMAX1
37666 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
37667 DO 420 J=MMIN2,MMAX2
37669 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
37674 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37677 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37680 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37681 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37688 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37689 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37690 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37692 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37693 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37699 ELSEIF(ISUB.EQ.382) THEN
37700 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37701 CALL PYWIDT(21,SH,WDTP,WDTE)
37702 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37703 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37704 IF(ITCM(5).EQ.1) THEN
37705 C...Modifications from contact interactions (compositeness)
37708 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37709 & WDTE(I,2)+WDTE(I,4))
37711 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37712 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37713 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37714 ELSEIF(ITCM(5).EQ.5) THEN
37715 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37716 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37717 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37719 DO 450 I=MMINA,MMAXA
37720 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37721 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37726 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37728 ELSEIF(ITCM(5).EQ.5) THEN
37740 ELSEIF(ISUB.EQ.383) THEN
37741 C...f + fbar -> g + g (q + qbar -> g + g only)
37742 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37743 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37744 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37745 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37746 IF(ITCM(5).EQ.5) THEN
37747 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37748 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37749 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37750 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37752 DO 460 I=MMINA,MMAXA
37753 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37754 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37759 SIGH(NCHN)=0.5D0*FACGG1
37760 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37765 SIGH(NCHN)=0.5D0*FACGG2
37766 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37769 ELSEIF(ISUB.EQ.384) THEN
37770 C...f + g -> f + g (q + g -> q + g only)
37771 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37772 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37773 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37774 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37775 DO 480 I=MMINA,MMAXA
37776 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37778 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37779 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37782 ISIG(NCHN,3-ISDE)=21
37787 ISIG(NCHN,3-ISDE)=21
37793 ELSEIF(ISUB.EQ.385) THEN
37794 C...g + g -> f + fbar (g + g -> q + qbar only)
37795 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37797 C...Begin by d, u, s flavours.
37799 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37800 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37801 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37802 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37803 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37804 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37805 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37806 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37807 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37808 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37819 C...Next c and b flavours: modified that and uhat for fixed
37820 C...cos(theta-hat).
37822 SQMAVG=PMAS(IFL,1)**2
37823 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37824 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37825 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37826 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37827 THUHQ=THQ*UHQ-SQMAVG*SH
37828 IF(MSTP(34).EQ.0) THEN
37829 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37830 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37832 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37833 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37834 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37835 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37837 IF(ITCM(5).GE.5) THEN
37839 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37840 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37841 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37842 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37844 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37845 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37846 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37847 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37850 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37851 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37855 ISIG(NCHN,3)=1+2*(IFL-3)
37860 ISIG(NCHN,3)=2+2*(IFL-3)
37866 ELSEIF(ISUB.EQ.386) THEN
37868 IF(ITCM(5).LE.4) THEN
37869 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37870 & 2D0*TH/SH+TH2/SH2)*FACA
37871 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37872 & 2D0*SH/UH+SH2/UH2)*FACA
37873 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37874 & 2D0*UH/TH+UH2/TH2)
37876 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37877 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37878 & 4D0*REDGST*(SH + 2D0*TH)*
37879 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37880 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37881 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37882 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37883 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37884 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37885 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37886 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37887 & 4D0*REDGSU*(SH + 2D0*UH)*
37888 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37889 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37890 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37891 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37892 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37893 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37894 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37895 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37896 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37897 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37898 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37899 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37900 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37901 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37902 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37903 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37904 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37905 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37906 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37907 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37908 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37909 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37911 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37916 SIGH(NCHN)=0.5D0*FACGG1
37921 SIGH(NCHN)=0.5D0*FACGG2
37926 SIGH(NCHN)=0.5D0*FACGG3
37929 ELSEIF(ISUB.EQ.387) THEN
37930 C...q + qbar -> Q + Qbar
37931 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37932 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37933 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37934 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37936 IF(ITCM(5).GE.5) THEN
37937 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37938 FACQQB=FACQQB*SH2*SQDQTS
37940 FACQQB=FACQQB*SH2*SQDQQS
37943 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37945 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37946 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37948 DO 520 I=MMINA,MMAXA
37949 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37950 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37958 ELSEIF(ISUB.EQ.388) THEN
37959 C...g + g -> Q + Qbar
37960 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37961 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37962 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37963 THUHQ=THQ*UHQ-SQMAVG*SH
37964 IF(MSTP(34).EQ.0) THEN
37965 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37966 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37968 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37969 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37970 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37971 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37973 IF(ITCM(5).GE.5) THEN
37974 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37975 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37976 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37977 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37978 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37980 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37981 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37982 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37983 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37986 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37987 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37988 IF(MSTP(35).GE.1) THEN
37989 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37990 FACQQ1=FACQQ1*FATRE
37991 FACQQ2=FACQQ2*FATRE
37994 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37995 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37998 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
38018 C*********************************************************************
38021 C...Subprocess cross sections for assorted exotic processes,
38022 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
38023 C...Auxiliary to PYSIGH.
38025 SUBROUTINE PYSGEX(NCHN,SIGS)
38027 C...Double precision and integer declarations
38028 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38029 IMPLICIT INTEGER(I-N)
38030 INTEGER PYK,PYCHGE,PYCOMP
38031 C...Parameter statement to help give large particle numbers.
38032 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38033 &KEXCIT=4000000,KDIMEN=5000000)
38035 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38036 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38037 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
38038 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38039 COMMON/PYINT1/MINT(400),VINT(400)
38040 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
38041 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
38042 COMMON/PYINT4/MWID(500),WIDS(500,5)
38043 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
38044 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
38045 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
38046 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
38047 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
38048 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
38049 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
38051 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
38053 C...Differential cross section expressions.
38055 IF(ISUB.LE.160) THEN
38056 IF(ISUB.EQ.141) THEN
38057 C...f + fbar -> gamma*/Z0/Z'0
38058 SQMZP=PMAS(32,1)**2
38060 CALL PYWIDT(32,SH,WDTP,WDTE)
38066 FACZP=4D0*COMFAC*3D0
38067 DO 100 I=MMINA,MMAXA
38068 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
38069 EI=KCHG(IABS(I),1)/3D0
38075 VPI=PARU(123-2*MOD(IABS(I),2))
38076 API=PARU(124-2*MOD(IABS(I),2))
38077 ELSEIF(IA.LE.4) THEN
38078 VPI=PARJ(182-2*MOD(IABS(I),2))
38079 API=PARJ(183-2*MOD(IABS(I),2))
38081 VPI=PARJ(190-2*MOD(IABS(I),2))
38082 API=PARJ(191-2*MOD(IABS(I),2))
38086 VPI=PARU(127-2*MOD(IABS(I),2))
38087 API=PARU(128-2*MOD(IABS(I),2))
38088 ELSEIF(IA.LE.14) THEN
38089 VPI=PARJ(186-2*MOD(IABS(I),2))
38090 API=PARJ(187-2*MOD(IABS(I),2))
38092 VPI=PARJ(194-2*MOD(IABS(I),2))
38093 API=PARJ(195-2*MOD(IABS(I),2))
38097 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
38099 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
38101 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
38106 C...Special case: if only branching ratios known then use them.
38107 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
38110 HI=SHR*WDTP(IA)*FACA/9D0
38111 ELSEIF(IA.LT.20) THEN
38114 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38115 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
38117 C...Normal cross section.
38118 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
38119 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
38120 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
38121 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
38122 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
38123 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
38124 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
38125 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
38129 ELSEIF(ISUB.EQ.142) THEN
38130 C...f + fbar' -> W'+/-
38131 SQMWP=PMAS(34,1)**2
38132 CALL PYWIDT(34,SH,WDTP,WDTE)
38134 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
38135 HP=AEM/(24D0*XW)*SH
38136 DO 120 I=MMIN1,MMAX1
38137 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
38139 DO 110 J=MMIN2,MMAX2
38140 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
38142 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
38143 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38145 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38146 C...Special case: if only branching ratios known then use them.
38147 IF(MWID(34).EQ.2) THEN
38149 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
38150 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
38151 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
38152 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
38153 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
38155 IF(IA.LT.10) HI=HI*FACA/9D0
38157 C...Normal cross section.
38158 HI=HP*(PARU(133)**2+PARU(134)**2)
38159 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
38160 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38166 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38167 SIGH(NCHN)=HI*FACBW*HF
38171 ELSEIF(ISUB.EQ.144) THEN
38174 CALL PYWIDT(41,SH,WDTP,WDTE)
38176 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
38177 HP=AEM/(12D0*XW)*SH
38178 DO 140 I=MMIN1,MMAX1
38179 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
38181 DO 130 J=MMIN2,MMAX2
38182 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
38184 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
38186 IF(IA.LE.10) HI=HI*FACA/3D0
38187 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
38192 SIGH(NCHN)=HI*FACBW*HF
38196 ELSEIF(ISUB.EQ.145) THEN
38197 C...q + l -> LQ (leptoquark)
38198 SQMLQ=PMAS(42,1)**2
38199 CALL PYWIDT(42,SH,WDTP,WDTE)
38201 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
38202 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
38204 KFLQQ=KFDP(MDCY(42,2),1)
38205 KFLQL=KFDP(MDCY(42,2),2)
38206 DO 160 I=MMIN1,MMAX1
38207 IF(KFAC(1,I).EQ.0) GOTO 160
38209 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
38210 DO 150 J=MMIN2,MMAX2
38211 IF(KFAC(2,J).EQ.0) GOTO 150
38213 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
38214 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
38215 IF(JA.EQ.IA) GOTO 150
38216 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
38217 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
38219 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
38224 SIGH(NCHN)=HI*FACBW*HF
38228 ELSEIF(ISUB.EQ.146) THEN
38229 C...e + gamma* -> e* (excited lepton)
38230 KFQSTR=KFPR(ISUB,1)
38231 KCQSTR=PYCOMP(KFQSTR)
38232 KFQEXC=MOD(KFQSTR,KEXCIT)
38233 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
38235 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
38236 QF=-RTCM(43)/2D0-RTCM(44)/2D0
38237 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
38238 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
38241 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
38243 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
38244 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
38246 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38247 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
38250 ISIG(NCHN,3-ISDE)=22
38252 SIGH(NCHN)=HI*FACBW*HF
38256 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
38257 C...d + g -> d* and u + g -> u* (excited quarks)
38258 KFQSTR=KFPR(ISUB,1)
38259 KCQSTR=PYCOMP(KFQSTR)
38260 KFQEXC=MOD(KFQSTR,KEXCIT)
38261 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
38263 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
38264 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
38265 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
38268 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
38270 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
38271 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
38273 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38274 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
38277 ISIG(NCHN,3-ISDE)=21
38279 SIGH(NCHN)=HI*FACBW*HF
38284 ELSEIF(ISUB.LE.190) THEN
38285 IF(ISUB.EQ.162) THEN
38286 C...q + g -> LQ + lbar; LQ=leptoquark
38287 SQMLQ=PMAS(42,1)**2
38288 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
38289 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
38290 KFLQQ=KFDP(MDCY(42,2),1)
38291 DO 220 I=MMINA,MMAXA
38292 IF(IABS(I).NE.KFLQQ) GOTO 220
38295 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
38296 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
38299 ISIG(NCHN,3-ISDE)=21
38301 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
38305 ELSEIF(ISUB.EQ.163) THEN
38306 C...g + g -> LQ + LQbar; LQ=leptoquark
38307 SQMLQ=PMAS(42,1)**2
38308 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
38309 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
38310 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
38311 & ((TH-SQMLQ)*(UH-SQMLQ)))
38312 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
38316 C...Since don't know proper colour flow, randomize between alternatives
38317 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
38321 ELSEIF(ISUB.EQ.164) THEN
38322 C...q + qbar -> LQ + LQbar; LQ=leptoquark
38323 DELTA=0.25D0*(SQM3-SQM4)**2/SH
38324 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
38327 C SQMLQ=PMAS(42,1)**2
38328 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
38329 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
38330 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
38331 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
38332 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
38333 KFLQQ=KFDP(MDCY(42,2),1)
38334 DO 240 I=MMINA,MMAXA
38335 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38336 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
38342 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
38345 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
38346 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
38347 KFQSTR=KFPR(ISUB,2)
38348 KCQSTR=PYCOMP(KFQSTR)
38349 KFQEXC=MOD(KFQSTR,KEXCIT)
38350 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
38351 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
38352 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
38353 C...Propagators: as simulated in PYOFSH and as desired
38354 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
38355 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
38356 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
38357 GMMQC=SQRT(SQM4)*WDTP(0)
38358 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
38359 FACQSA=FACQSA*HBW4C/HBW4
38360 FACQSB=FACQSB*HBW4C/HBW4
38361 C...Branching ratios.
38362 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
38363 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
38364 DO 260 I=MMIN1,MMAX1
38366 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
38367 DO 250 J=MMIN2,MMAX2
38369 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
38370 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
38375 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
38376 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
38381 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
38382 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
38383 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
38388 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
38389 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
38390 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
38391 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
38396 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
38397 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
38402 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
38403 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
38404 ELSEIF(I.EQ.-J) THEN
38409 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38410 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38415 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38416 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38417 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
38422 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
38423 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
38424 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
38429 ELSEIF(ISUB.EQ.169) THEN
38430 C...q + qbar -> e + e* (excited lepton)
38431 KFQSTR=KFPR(ISUB,2)
38432 KCQSTR=PYCOMP(KFQSTR)
38433 KFQEXC=MOD(KFQSTR,KEXCIT)
38434 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
38435 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
38436 C...Propagators: as simulated in PYOFSH and as desired
38437 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
38438 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
38439 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
38440 GMMQC=SQRT(SQM4)*WDTP(0)
38441 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
38442 FACQSB=FACQSB*HBW4C/HBW4
38443 C...Branching ratios.
38444 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
38445 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
38446 DO 270 I=MMIN1,MMAX1
38448 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
38451 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
38456 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38457 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38462 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38463 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38467 ELSEIF(ISUB.LE.360) THEN
38468 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
38469 C...l + l -> H_L++/-- or H_R++/--.
38471 KFREC=PYCOMP(KFRES)
38472 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38474 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
38475 DO 290 I=MMIN1,MMAX1
38477 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
38479 DO 280 J=MMIN2,MMAX2
38481 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
38483 IF(I*J.LT.0) GOTO 280
38484 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38489 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
38490 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
38491 SIGH(NCHN)=HI*FACBW*HF
38495 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
38496 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
38498 KFREC=PYCOMP(KFRES)
38499 C...Propagators: as simulated in PYOFSH and as desired
38500 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
38501 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
38502 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
38503 GMMC=SQRT(SQM3)*WDTP(0)
38504 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
38505 FHCC=COMFAC*AEM*HBW3C/HBW3
38506 DO 310 I=MMINA,MMAXA
38508 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
38510 J=ISIGN(KFPR(ISUB,2),-I)
38511 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
38512 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
38513 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
38515 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
38516 & (TH-SQM4)*SH)/(TH-SQM4)**2
38517 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
38519 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
38520 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
38521 & ((UH-SQM3)*(TH-SQM4))
38522 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
38523 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
38524 & ((UH-SQM3)*(SH-SQML))
38525 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
38526 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
38527 & ((SH-SQML)*(TH-SQM4))
38528 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
38529 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
38531 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
38532 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
38535 ISIG(NCHN,3-ISDE)=22
38537 SIGH(NCHN)=FHCC*SMM*WIDSC
38541 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
38542 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
38544 KFREC=PYCOMP(KFRES)
38545 SQMH=PMAS(KFREC,1)**2
38546 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
38547 C...Propagators: H++/-- as simulated in PYOFSH and as desired
38548 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
38549 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
38550 GMMH3=SQRT(SQM3)*WDTP(0)
38551 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
38552 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
38553 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
38554 GMMH4=SQRT(SQM4)*WDTP(0)
38555 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
38556 C...Kinematical and coupling functions
38557 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
38558 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
38559 C...Loop over allowed flavours
38560 DO 320 I=MMINA,MMAXA
38561 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
38562 EI=KCHG(IABS(I),1)/3D0
38563 AI=SIGN(1D0,EI+0.1D0)
38566 IF(IABS(I).LE.10) FCOI=FACA/3D0
38567 IF(ISUB.EQ.349) THEN
38568 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
38569 IF(IABS(I).LT.10) THEN
38570 DSIGHH=8D0*AEM**2*(EI**2/SH2+
38571 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
38572 & (VI**2+AI**2)*XWHH**2*HBWZ)
38574 IAOFF=181+3*((IABS(I)-11)/2)
38575 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
38577 DSIGHH=8D0*AEM**2*(EI**2/SH2+
38578 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
38579 & (VI**2+AI**2)*XWHH**2*HBWZ)+
38580 & 8D0*AEM*(EI*HSUM/(SH*TH)+
38581 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
38585 IF(IABS(I).LT.10) THEN
38586 DSIGHH=8D0*AEM**2*EI**2/SH2
38588 IAOFF=181+3*((IABS(I)-11)/2)
38589 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
38591 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
38599 SIGH(NCHN)=FACHH*FCOI*DSIGHH
38602 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
38603 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
38605 KFREC=PYCOMP(KFRES)
38606 SQMH=PMAS(KFREC,1)**2
38607 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
38608 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
38609 & PMAS(PYCOMP(9900024),1)**2
38610 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
38611 FACPRT=1D0/((VINT(204)**2-VINT(215))*
38612 & (VINT(209)**2-VINT(216)))
38613 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
38614 & (VINT(209)**2+2D0*VINT(218)))
38615 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38617 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
38618 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
38620 DO 340 I=MMIN1,MMAX1
38621 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
38622 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
38623 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
38624 DO 330 J=MMIN2,MMAX2
38625 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
38626 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
38627 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
38629 IF(IABS(KCHH).NE.2) GOTO 330
38630 FACLR=VINT(180+I)*VINT(180+J)
38631 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
38632 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
38633 FACPRP=0.5D0*(FACPRT+FACPRU)**2
38641 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
38645 ELSEIF(ISUB.EQ.353) THEN
38646 C...f + fbar -> Z_R0
38647 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38648 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38650 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
38651 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38652 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
38653 DO 350 I=MMINA,MMAXA
38654 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
38655 IF(IABS(I).LE.8) THEN
38656 EI=KCHG(IABS(I),1)/3D0
38657 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
38658 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
38663 HI=HP*(VI**2+AI**2)
38664 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38669 SIGH(NCHN)=HI*FACBW*HF
38672 ELSEIF(ISUB.EQ.354) THEN
38673 C...f + fbar' -> W_R+/-
38674 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38675 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38677 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38678 HP=AEM/(24D0*XW)*SH
38679 DO 370 I=MMIN1,MMAX1
38680 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38682 DO 360 J=MMIN2,MMAX2
38683 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38685 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38686 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38688 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38690 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38695 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38696 SIGH(NCHN)=HI*FACBW*HF
38701 ELSEIF(ISUB.LE.400) THEN
38702 IF(ISUB.EQ.391) THEN
38703 C...f + fbar -> G*.
38704 KFGSTR=KFPR(ISUB,1)
38705 KCGSTR=PYCOMP(KFGSTR)
38706 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38708 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38709 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38710 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38711 C...Modify cross section in wings of peak.
38712 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38713 DO 380 I=MMINA,MMAXA
38714 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38716 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38724 ELSEIF(ISUB.EQ.392) THEN
38726 KFGSTR=KFPR(ISUB,1)
38727 KCGSTR=PYCOMP(KFGSTR)
38728 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38730 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38731 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38732 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38733 C...Modify cross section in wings of peak.
38734 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38735 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38743 ELSEIF(ISUB.EQ.393) THEN
38744 C...q + qbar -> g + G*.
38745 KFGSTR=KFPR(ISUB,2)
38746 KCGSTR=PYCOMP(KFGSTR)
38747 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38748 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38749 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38751 C...Propagators: as simulated in PYOFSH and as desired
38752 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38753 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38754 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38755 HS=SQRT(SQM4)*WDTP(0)
38756 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38757 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38758 FACG=FACG*HBW4C/HBW4
38759 DO 400 I=MMINA,MMAXA
38760 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38761 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38769 ELSEIF(ISUB.EQ.394) THEN
38770 C...q + g -> q + G*.
38771 KFGSTR=KFPR(ISUB,2)
38772 KCGSTR=PYCOMP(KFGSTR)
38773 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38774 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38775 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38776 & 2D0*TH2*TH/(UH*SH2))
38777 C...Propagators: as simulated in PYOFSH and as desired
38778 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38779 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38780 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38781 HS=SQRT(SQM4)*WDTP(0)
38782 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38783 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38784 FACG=FACG*HBW4C/HBW4
38785 DO 420 I=MMINA,MMAXA
38786 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38788 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38789 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38792 ISIG(NCHN,3-ISDE)=21
38798 ELSEIF(ISUB.EQ.395) THEN
38799 C...g + g -> g + G*.
38800 KFGSTR=KFPR(ISUB,2)
38801 KCGSTR=PYCOMP(KFGSTR)
38802 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38803 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38804 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38805 C...Propagators: as simulated in PYOFSH and as desired
38806 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38807 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38808 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38809 HS=SQRT(SQM4)*WDTP(0)
38810 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38811 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38812 FACG=FACG*HBW4C/HBW4
38813 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38821 ELSEIF(ISUB.LE.500) THEN
38822 IF(ISUBSV.EQ.481) ISUB=482
38823 c... GENERIC 2->(1)->2
38824 IF(ISUB.EQ.482) THEN
38826 KCRES=PYCOMP(KFRES)
38827 IF(KCRES.EQ.0) RETURN
38832 KCF1=PYCOMP(KFPR(ISUB,1))
38833 KCF2=PYCOMP(KFPR(ISUB,2))
38834 IF(ISUBSV.EQ.481) THEN
38835 SQMZR=PMAS(KCRES,1)**2
38836 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38838 FACBW=SH2/((SH-SQMZR)**2+HS**2)
38841 SQMH=PMAS(KCF1,1)**2
38842 GMMH=PMAS(KCF1,1)*PMAS(KCF1,2)
38843 C...Propagators: as simulated in PYOFSH and as desired
38844 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
38845 CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE)
38846 GMMH3=SQRT(SQM3)*WDTP(0)
38847 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
38848 SQMH=PMAS(KCF2,1)**2
38849 GMMH=PMAS(KCF2,1)*PMAS(KCF2,2)
38850 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
38851 CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE)
38852 GMMH4=SQRT(SQM4)*WDTP(0)
38853 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
38854 FACT=FACT*(HBW3C/HBW3)*(HBW4C/HBW4)
38857 KCI1=ABS(PYCOMP(KFDP(IDCY,1)))
38858 KCI2=ABS(PYCOMP(KFDP(IDCY,2)))
38859 JCOL1=SIGN(KCHG(KCF1,2),KFPR(ISUB,1))
38860 JCOL2=SIGN(KCHG(KCF2,2),KFPR(ISUB,2))
38863 ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.KCOL.EQ.2) THEN
38864 IF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
38869 ELSEIF(KCOL.EQ.-1.OR.KCOL.EQ.1) THEN
38871 ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.JCOL1.EQ.0.AND.
38874 ELSEIF(KCOL.EQ.2.AND.((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
38875 $ (JCOL1.EQ.2.AND.JCOL2.EQ.0))) THEN
38880 DO 440 I=MMIN1,MMAX1
38881 IF(KFAC(1,I).EQ.0) GOTO 440
38885 DO 430 J=MMIN2,MMAX2
38886 IF(KFAC(2,J).EQ.0) GOTO 430
38890 IF((IA.EQ.KCI1.AND.JA.EQ.KCI2).OR.
38891 $ (JA.EQ.KCI1.AND.IA.EQ.KCI2)) THEN
38892 KCHW=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
38893 IF(ABS(KCHW).EQ.ABS(KCEM)) THEN
38899 SIGH(NCHN)=FACT/NCOL
38911 C*********************************************************************
38914 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38915 C...parton distributions according to a few different parametrizations.
38916 C...Note that what is coded is x times the probability distribution,
38917 C...i.e. xq(x,Q2) etc.
38919 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38921 C...Double precision and integer declarations.
38922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38923 IMPLICIT INTEGER(I-N)
38924 INTEGER PYK,PYCHGE,PYCOMP
38926 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38928 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38929 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38930 COMMON/PYINT1/MINT(400),VINT(400)
38931 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38933 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38934 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38935 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38936 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38937 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38940 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38941 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38944 C...Interface to PDFLIB.
38945 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38947 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38948 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38949 CHARACTER*20 PARM(20)
38950 DATA VALUE/20*0D0/,PARM/20*' '/
38952 C...Data related to Schuler-Sjostrand photon distributions.
38953 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38955 C...Valence PDF momentum integral parametrizations PER PARTON!
38956 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38957 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38958 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38959 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38961 C...Reset parton distributions.
38970 C...Check x and particle species.
38971 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38972 WRITE(MSTU(11),5000) X
38976 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38977 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38978 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38979 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38980 &KFA.NE.310.AND.KFA.NE.130) THEN
38981 WRITE(MSTU(11),5100) KF
38985 C...Electron (or muon or tau) parton distribution call.
38986 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38987 CALL PYPDEL(KFA,X,Q2,XPEL)
38992 C...Photon parton distribution call (VDM+anomalous).
38993 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38994 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38995 CALL PYPDGA(X,Q2,XPGA)
38999 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
39002 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
39003 XPVAL(4)=MIN(XPQ(4),XPVU)
39004 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
39010 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39013 IF(MSTP(55).GE.7) P2MX=4.0D0
39014 IF(MSTP(57).EQ.0) Q2MX=P2MX
39016 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39017 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39020 XPVAL(KFL)=VXPDGM(KFL)
39023 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39026 IF(MSTP(55).GE.11) P2MX=4.0D0
39027 IF(MSTP(57).EQ.0) Q2MX=P2MX
39029 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39030 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39032 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39033 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39036 ELSEIF(MSTP(56).EQ.2) THEN
39037 C...Call PDFLIB parton distributions.
39041 VALUE(2)=MSTP(55)/1000
39043 VALUE(3)=MOD(MSTP(55),1000)
39044 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39045 CALL PDFSET_ALICE(PARM,VALUE)
39046 MINT(93)=3000000+MSTP(55)
39049 QQ2=MAX(0D0,Q2MIN,Q2)
39050 IF(MSTP(57).EQ.0) QQ2=Q2MIN
39052 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39054 IF(MSTP(55).EQ.5004) THEN
39055 IF(5D0*P2.LT.QQ2.AND.
39056 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
39057 & P2.GE.0D0.AND.P2.LT.10D0.AND.
39058 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
39059 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
39074 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
39102 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
39105 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
39106 XPVAL(4)=MIN(XPQ(4),XPVU)
39107 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
39114 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
39117 C...Pion/gammaVDM parton distribution call.
39118 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
39119 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
39120 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
39121 & MSTP(55).LE.12) THEN
39122 ISET=1+MOD(MSTP(55)-1,4)
39125 IF(ISET.GE.3) P2MX=4.0D0
39126 IF(MSTP(57).EQ.0) Q2MX=P2MX
39128 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39129 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39131 XPQ(KFL)=XPVMD(KFL)
39132 XPVAL(KFL)=VXPVMD(KFL)
39135 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
39136 CALL PYPDPI(X,Q2,XPPI)
39140 XPVAL(2)=XPQ(2)-XPQ(-2)
39141 XPVAL(-1)=XPQ(-1)-XPQ(1)
39142 ELSEIF(MSTP(54).EQ.2) THEN
39143 C...Call PDFLIB parton distributions.
39147 VALUE(2)=MSTP(53)/1000
39149 VALUE(3)=MOD(MSTP(53),1000)
39150 IF(MINT(93).NE.2000000+MSTP(53)) THEN
39151 CALL PDFSET_ALICE(PARM,VALUE)
39152 MINT(93)=2000000+MSTP(53)
39155 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39156 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39157 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
39158 + DSEA,STR,CHM,BOT,TOP,GLU)
39176 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
39179 C...Anomalous photon parton distribution call.
39180 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
39183 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
39184 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
39185 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
39186 IF(MSTP(57).EQ.0) Q2MX=P2MX
39188 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39189 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
39191 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
39192 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
39195 ELSEIF(MSTP(56).EQ.1) THEN
39196 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
39197 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
39198 IF(MSTP(57).EQ.0) Q2MX=P2MX
39200 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39201 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
39203 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
39204 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
39207 ELSEIF(MSTP(56).EQ.2) THEN
39208 IF(MSTP(57).EQ.0) Q2MX=P2MX
39209 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
39212 XPVAL(KFL)=VXPGA(KFL)
39215 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
39216 IF(MSTP(57).EQ.0) Q2MX=P2MX
39217 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
39220 XPVAL(KFL)=VXPGA(KFL)
39224 220 RKF=11D0*PYR(0)
39226 IF(RKF.GT.1D0) KFR=2
39227 IF(RKF.GT.5D0) KFR=3
39228 IF(RKF.GT.6D0) KFR=4
39229 IF(RKF.GT.10D0) KFR=5
39230 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
39231 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
39232 IF(MSTP(57).EQ.0) Q2MX=P2MX
39233 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
39236 XPVAL(KFL)=VXPGA(KFL)
39241 C...Proton parton distribution call.
39243 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
39244 CALL PYPDPR(X,Q2,XPPR)
39248 C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
39249 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
39250 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
39251 ELSEIF(MSTP(52).EQ.2) THEN
39252 C...Call PDFLIB parton distributions.
39256 VALUE(2)=MSTP(51)/1000
39258 VALUE(3)=MOD(MSTP(51),1000)
39259 IF(MINT(93).NE.1000000+MSTP(51)) THEN
39260 CALL PDFSET_ALICE(PARM,VALUE)
39261 MINT(93)=1000000+MSTP(51)
39264 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39265 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39266 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
39267 + DSEA,STR,CHM,BOT,TOP,GLU)
39285 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
39289 C...Isospin average for pi0/gammaVDM.
39290 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
39291 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
39296 XPS=0.5D0*(XPQ(1)+XPQ(-2))
39297 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
39301 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
39302 & XPVAL(3)+XPVAL(4)+XPVAL(5)
39306 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
39307 XPQ(1)=XPQ(1)+0.2D0*XPV
39308 XPQ(2)=XPQ(2)+0.8D0*XPV
39309 XPVAL(1)=0.2D0*XPVL
39310 XPVAL(2)=0.8D0*XPVL
39311 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
39314 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
39317 IF(MSTP(55).GE.9) THEN
39323 XPQ(1)=XPQ(1)+0.5D0*XPV
39324 XPQ(2)=XPQ(2)+0.5D0*XPV
39325 XPVAL(1)=0.5D0*XPVL
39326 XPVAL(2)=0.5D0*XPVL
39330 XPVAL(-KFL)=XPVAL(KFL)
39333 C...Rescale for gammaVDM by effective gamma -> rho coupling.
39334 C+++Do not rescale?
39335 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
39336 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
39338 XPQ(KFL)=VINT(281)*XPQ(KFL)
39339 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
39341 VINT(232)=VINT(281)*XPV
39344 C...Simple recipes for kaons.
39345 ELSEIF(KFA.EQ.321) THEN
39346 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
39348 XPVAL(-3)=XPVAL(-1)
39350 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
39351 XPS=0.5D0*(XPQ(1)+XPQ(-2))
39352 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
39355 XPQ(1)=XPQ(1)+0.5D0*XPV
39356 XPQ(-1)=XPQ(-1)+0.5D0*XPV
39357 XPQ(3)=XPQ(3)+0.5D0*XPV
39358 XPQ(-3)=XPQ(-3)+0.5D0*XPV
39359 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
39363 XPVAL(-1)=0.5D0*XPV
39365 XPVAL(-3)=0.5D0*XPV
39367 C...Isospin conjugation for neutron.
39368 ELSEIF(KFA.EQ.2112) THEN
39379 C...Simple recipes for hyperon (average valence parton distribution).
39380 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
39381 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
39382 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
39383 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
39388 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
39389 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
39390 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
39391 XPV=(XPVAL(1)+XPVAL(2))/3D0
39394 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
39395 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
39396 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
39399 C...Charge conjugation for antiparticle.
39402 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
39409 XPVAL(KFL)=XPVAL(-KFL)
39414 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
39417 C...Only reshape PDFs for the non-first interactions;
39418 C...But need valence/sea separation already from first interaction.
39419 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
39420 KFVSEL=KFIVAL(JS,1)
39421 C...If valence quark kicked out of pi0 or gamma then that decides
39422 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
39423 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
39426 XPVL=XPVL+XPVAL(KFL)
39427 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
39430 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
39431 XPVAL(IABS(KFVSEL))=XPVL
39434 XPVAL(-KFL)=XPVAL(KFL)
39437 C...If valence quark kicked out of K0S or K0S then that decides whether
39438 C...we should consider state as d sbar or s dbar.
39439 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
39441 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
39442 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
39443 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
39444 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
39447 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
39448 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
39449 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
39453 C...XPQ distributions are nominal for a (signed) beam particle
39454 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
39462 IF(IFL.EQ.0) GOTO 350
39464 C...Count up number of original IFL valence quarks.
39466 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
39467 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
39468 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
39469 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
39470 C...bookkeep as if d dbar (for total momentum sum in valence sector).
39471 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
39472 C...Count down number of remaining IFL valence quarks. Skip current
39473 C...interaction initiator.
39475 DO 330 I1=1,NMI(JS)
39476 IF (I1.EQ.MINT(36)) GOTO 330
39477 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
39481 C...Separate out original VALENCE and SEA content.
39483 SEA=MAX(0D0,XPQ(IFL)-VAL)
39487 C...Rescale valence content if changed.
39488 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
39489 & (VAL*IVREM)/IVORG
39491 C...Momentum integrals of original and removed valence quarks.
39492 IF(IVORG.NE.0) THEN
39493 C...For p/n/pbar/nbar beams can split into d_val and u_val.
39494 C...Isospin conjugation for neutrons
39495 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
39497 IF (KFA.EQ.2112) IAFLP=3-IAFLP
39498 VPAVG=PAVG(IAFLP,Q2)
39499 C...For other baryons average d_val and u_val, like for PDFs.
39500 ELSEIF(KFA.GT.1000) THEN
39501 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
39502 C...For mesons and photon average d_val and u_val and scale by 3/2.
39503 C...Very crude, especially for photon.
39505 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
39507 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
39508 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
39511 C...Now add companions (at X with partner having been at Z=XASSOC).
39512 C...NOTE: due to the assumed simple x scaling, the partner was at what
39513 C...corresponds to a higher Z than XASSOC, if there were intermediate
39514 C...scatterings. Nothing done about that for the moment.
39515 DO 340 IVC=1,NVC(JS,IFL)
39516 C...Skip companions that have been kicked out
39517 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
39521 C...Momentum fraction of the partner quark.
39522 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
39523 XS=XASSOC(JS,IFL,IVC)
39526 C...Momentum fraction of the companion quark.
39527 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
39529 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
39530 C...Add to momentum sum, with rescaling compensation factor.
39531 XCFAC=(XREM+XS)/XREM*CMPFAC
39532 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
39537 C...Wait until all flavours treated, then rescale seas and gluon.
39540 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
39541 IF (RSFAC.LE.0D0) THEN
39542 C...First calculate factor needed to exactly restore pz cons.
39543 IF (NRESC.EQ.1) CMPFAC =
39544 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
39545 C...Add a bit of headroom
39547 C...Try a few times if more headroom is needed, then print error message.
39548 IF (NRESC.LE.10) GOTO 345
39550 & '(PYPDFU:) Negative reshaping factor persists!')
39551 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
39555 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
39556 C...Also store resulting distributions in XPQ
39558 DO 360 ISVC=-1,NVC(JS,IFL)
39559 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
39562 C...Save companion reweighting factor for PYPTIS.
39567 C...Allow gluon also in position 21.
39570 C...Check positivity and reset above maximum allowed flavour.
39572 XPQ(KFL)=MAX(0D0,XPQ(KFL))
39573 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
39576 C...Formats for error printouts.
39577 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39578 5100 FORMAT(' Error: illegal particle code for parton distribution;',
39580 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
39582 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
39583 & ' Removed valence momentum fraction : ',F6.3/
39584 & ' Added companion momentum fraction : ',F6.3/
39585 & ' Resulting rescale factor : ',F6.3)
39587 C...Reset side pointer and return
39593 C*********************************************************************
39596 C...Gives proton parton distribution at small x and/or Q^2 according to
39597 C...correct limiting behaviour.
39599 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
39601 C...Double precision and integer declarations.
39602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39603 IMPLICIT INTEGER(I-N)
39604 INTEGER PYK,PYCHGE,PYCOMP
39606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39607 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39608 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39609 COMMON/PYINT1/MINT(400),VINT(400)
39610 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39612 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
39613 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
39615 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
39619 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
39620 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
39621 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
39623 CALL PYPDFU(KF,X,Q2,XPQ)
39627 C...Reset. Check x.
39631 IF(X.LE.0D0.OR.X.GE.1D0) THEN
39632 WRITE(MSTU(11),5000) X
39636 C...Define valence content.
39640 IF(KF.EQ.2212) THEN
39643 ELSEIF(KF.EQ.-2212) THEN
39646 ELSEIF(KF.EQ.2112) THEN
39649 ELSEIF(KF.EQ.-2112) THEN
39652 ELSEIF(KF.EQ.211) THEN
39656 ELSEIF(KF.EQ.-211) THEN
39660 ELSEIF(MINT(105).LE.223) THEN
39665 ELSEIF(MINT(105).EQ.333) THEN
39670 ELSEIF(MINT(105).EQ.443) THEN
39677 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
39679 CALL PYPDFU(KFC,X,Q2,XPA)
39680 Q2MN=MAX(3D0,VINT(231))
39681 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
39682 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
39684 C...Large Q2 and large x: naive call is enough.
39685 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
39691 C...Small Q2 and large x: dampen boundary value.
39692 ELSEIF(X.GT.XMN) THEN
39694 C...Evaluate at boundary and define dampening factors.
39696 CALL PYPDFU(KFC,X,Q2MN,XPA)
39697 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
39698 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
39700 C...Separate valence and sea parts of parton distribution.
39702 XFV1=XPA(KFV1)-XPA(-KFV1)
39703 XPA(KFV1)=XPA(-KFV1)
39704 XFV2=XPA(KFV2)-XPA(-KFV2)
39705 XPA(KFV2)=XPA(-KFV2)
39707 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39708 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39709 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39710 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39713 C...Dampen valence and sea separately. Put back together.
39715 XPQ(KFL)=FS*XPA(KFL)
39718 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
39719 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
39721 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
39722 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
39723 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
39724 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
39728 C...Large Q2 and small x: interpolate behaviour.
39729 ELSEIF(Q2.GT.Q2MN) THEN
39731 C...Evaluate at extremes and define coefficients for interpolation.
39733 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39736 CALL PYPDFU(KFC,X,Q2B,XPB)
39738 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
39739 FVA=(X/XMN)**0.45D0*FLA
39740 FSA=(X/XMN)**(-0.08D0)*FLA
39743 C...Separate valence and sea parts of parton distribution.
39745 XFVA1=XPA(KFV1)-XPA(-KFV1)
39746 XPA(KFV1)=XPA(-KFV1)
39747 XFVA2=XPA(KFV2)-XPA(-KFV2)
39748 XPA(KFV2)=XPA(-KFV2)
39749 XFVB1=XPB(KFV1)-XPB(-KFV1)
39750 XPB(KFV1)=XPB(-KFV1)
39751 XFVB2=XPB(KFV2)-XPB(-KFV2)
39752 XPB(KFV2)=XPB(-KFV2)
39754 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
39755 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
39756 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
39757 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
39758 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
39759 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39760 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39761 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39764 C...Interpolate for valence and sea. Put back together.
39766 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39769 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39770 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39772 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39773 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39774 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39775 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39779 C...Small Q2 and small x: dampen boundary value and add term.
39782 C...Evaluate at boundary and define dampening factors.
39784 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39785 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39787 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39788 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39789 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39790 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39791 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39792 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39794 C...Separate valence and sea parts of parton distribution.
39796 XFV1=XPA(KFV1)-XPA(-KFV1)
39797 XPA(KFV1)=XPA(-KFV1)
39798 XFV2=XPA(KFV2)-XPA(-KFV2)
39799 XPA(KFV2)=XPA(-KFV2)
39801 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39802 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39803 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39804 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39807 C...Dampen valence and sea separately. Add constant terms.
39808 C...Put back together.
39810 XPQ(KFL)=FSA*XPA(KFL)
39814 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39816 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39817 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39820 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39822 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39823 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39824 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39825 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39831 C...Format for error printout.
39832 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39837 C*********************************************************************
39840 C...Gives electron (or muon, or tau) parton distribution.
39842 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39844 C...Double precision and integer declarations.
39845 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39846 IMPLICIT INTEGER(I-N)
39847 INTEGER PYK,PYCHGE,PYCOMP
39849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39850 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39851 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39852 COMMON/PYINT1/MINT(400),VINT(400)
39853 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39855 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39857 C...Interface to PDFLIB.
39858 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39860 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39861 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39862 CHARACTER*20 PARM(20)
39863 DATA VALUE/20*0D0/,PARM/20*' '/
39865 C...Some common constants.
39871 IF(KFA.EQ.13) PME=PMAS(13,1)
39872 IF(KFA.EQ.15) PME=PMAS(15,1)
39873 XL=LOG(MAX(1D-10,X))
39874 X1L=LOG(MAX(1D-10,1D0-X))
39875 HLE=LOG(MAX(3D0,Q2/PME**2))
39876 HBE2=(AEM/PARU(1))*(HLE-1D0)
39878 C...Electron inside electron, see R. Kleiss et al., in Z physics at
39879 C...LEP 1, CERN 89-08, p. 34
39880 IF(MSTP(59).LE.1) THEN
39881 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39882 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39883 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39884 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39885 & 4D0*XL/(1D0-X)-5D0-X)
39887 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39888 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39889 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39891 C...Zero distribution for very large x and rescale it for intermediate.
39892 IF(X.GT.1D0-1D-10) THEN
39894 ELSEIF(X.GT.1D0-1D-7) THEN
39895 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39899 C...Photon and (transverse) W- inside electron.
39900 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39901 IF(MSTP(13).LE.1) THEN
39904 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39906 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39907 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39908 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39910 C...Electron or positron inside photon inside electron.
39911 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39912 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39913 & 2D0*X*(1D0+X)*XL)
39914 XPEL(11)=XPEL(11)+XFSEA
39917 C...Initialize PDFLIB photon parton distributions.
39918 IF(MSTP(56).EQ.2) THEN
39922 VALUE(2)=MSTP(55)/1000
39924 VALUE(3)=MOD(MSTP(55),1000)
39925 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39926 CALL PDFSET_ALICE(PARM,VALUE)
39927 MINT(93)=3000000+MSTP(55)
39931 C...Quarks and gluons inside photon inside electron:
39932 C...numerical convolution required.
39941 IF(ITER.EQ.0) NSTP=2
39943 SXP(KFL)=0.5D0*SXP(KFL)
39946 IF(ITER.EQ.0) WTSTP=0.5D0
39947 C...Pick grid of x_{gamma} values logarithmically even.
39952 XLE=XL*(ISTP-0.5D0)/NSTP
39954 XE=MIN(1D0-1D-10,EXP(XLE))
39955 XG=MIN(1D0-1D-10,X/XE)
39956 C...Evaluate photon inside electron parton distribution for convolution.
39957 XPGP=1D0+(1D0-XE)**2
39958 IF(MSTP(13).LE.1) THEN
39961 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39963 C...Evaluate photon parton distributions for convolution.
39964 IF(MSTP(56).EQ.1) THEN
39965 IF(MSTP(55).EQ.1) THEN
39966 CALL PYPDGA(XG,Q2,XPGA)
39967 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39970 IF(MSTP(55).GE.7) P2MX=4.0D0
39971 IF(MSTP(57).EQ.0) Q2MX=P2MX
39973 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39974 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39976 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39979 IF(MSTP(55).GE.11) P2MX=4.0D0
39980 IF(MSTP(57).EQ.0) Q2MX=P2MX
39982 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39983 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39987 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39989 ELSEIF(MSTP(56).EQ.2) THEN
39990 C...Call PDFLIB parton distributions.
39992 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39993 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39994 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
39995 + DSEA,STR,CHM,BOT,TOP,GLU)
39996 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39997 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39998 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39999 SXP(3)=SXP(3)+WTSTP*XPGP*STR
40000 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
40001 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
40002 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
40005 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
40006 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
40007 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
40009 C...Put convolution into output arrays.
40011 XPEL(0)=FCONV*SXP(0)
40013 XPEL(KFL)=FCONV*SXP(KFL)
40014 XPEL(-KFL)=XPEL(KFL)
40021 C*********************************************************************
40024 C...Gives photon parton distribution.
40026 SUBROUTINE PYPDGA(X,Q2,XPGA)
40028 C...Double precision and integer declarations.
40029 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40030 IMPLICIT INTEGER(I-N)
40031 INTEGER PYK,PYCHGE,PYCOMP
40033 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40034 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40035 COMMON/PYINT1/MINT(400),VINT(400)
40036 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40038 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
40039 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
40040 &DGCS(4,3),DGDS(4,3),DGES(4,3)
40042 C...The following data lines are coefficients needed in the
40043 C...Drees and Grassie photon parton distribution parametrization.
40044 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
40045 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
40046 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
40047 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
40048 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
40049 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
40050 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
40051 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
40052 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
40053 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
40054 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
40055 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
40056 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
40057 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
40058 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
40059 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
40060 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
40061 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
40062 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
40063 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
40064 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
40065 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
40066 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
40067 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
40068 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
40069 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
40071 C...Photon parton distribution from Drees and Grassie.
40072 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
40077 IF(MSTP(57).LE.0) THEN
40080 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
40084 IF(Q2.GT.25D0) NF=4
40085 IF(Q2.GT.300D0) NF=5
40089 C...Evaluate gluon content.
40090 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
40091 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
40092 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
40093 XPGL=DGA*X**DGB*X1**DGC
40095 C...Evaluate up- and down-type quark content.
40096 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
40097 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
40098 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
40099 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
40100 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
40101 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
40102 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
40103 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
40104 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
40105 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
40106 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
40108 IF(NF.EQ.4) DGF=10D0
40109 IF(NF.EQ.5) DGF=55D0/6D0
40110 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
40112 XPQU=(XPQS+9D0*XPQN)/6D0
40113 XPQD=(XPQS-4.5D0*XPQN)/6D0
40114 ELSEIF(NF.EQ.4) THEN
40115 XPQU=(XPQS+6D0*XPQN)/8D0
40116 XPQD=(XPQS-6D0*XPQN)/8D0
40118 XPQU=(XPQS+7.5D0*XPQN)/10D0
40119 XPQD=(XPQS-5D0*XPQN)/10D0
40122 C...Put into output arrays.
40127 IF(NF.GE.4) XPGA(4)=AEM*XPQU
40128 IF(NF.GE.5) XPGA(5)=AEM*XPQD
40130 XPGA(-KFL)=XPGA(KFL)
40136 C*********************************************************************
40139 C...Constructs the F2 and parton distributions of the photon
40140 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40141 C...For F2, c and b are included by the Bethe-Heitler formula;
40142 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40143 C...Contains the SaS sets 1D, 1M, 2D and 2M.
40144 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40146 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40148 C...Double precision and integer declarations.
40149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40150 IMPLICIT INTEGER(I-N)
40151 INTEGER PYK,PYCHGE,PYCOMP
40153 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40155 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40156 SAVE /PYINT8/,/PYINT9/
40158 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
40159 C...Charm and bottom masses (low to compensate for J/psi etc.).
40160 DATA PMC/1.3D0/, PMB/4.6D0/
40161 C...alpha_em and alpha_em/(2*pi).
40162 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
40163 C...Lambda value for 4 flavours.
40165 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40167 C...VMD couplings f_V**2/(4*pi).
40168 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
40169 C...Masses for rho (=omega) and phi.
40170 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
40171 C...Number of points in integration for IP2=1.
40189 C...Set Q0 cut-off parameter as function of set used.
40197 C...Scale choice for off-shell photon; common factors.
40202 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40203 FACNOR=LOG(Q2/Q02)/NSTEP
40204 ELSEIF(IP2.EQ.2) THEN
40206 ELSEIF(IP2.EQ.3) THEN
40208 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40209 ELSEIF(IP2.EQ.4) THEN
40210 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40211 & ((Q2+P2)*(Q02+P2)))
40212 ELSEIF(IP2.EQ.5) THEN
40213 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40214 & ((Q2+P2)*(Q02+P2)))
40215 P2MX=Q0*SQRT(P2MXA)
40216 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40217 ELSEIF(IP2.EQ.6) THEN
40218 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40219 & ((Q2+P2)*(Q02+P2)))
40220 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
40222 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40223 & ((Q2+P2)*(Q02+P2)))
40224 P2MX=Q0*SQRT(P2MXA)
40226 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
40227 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
40228 IF(ABS(Q2-Q02).GT.1D-6) THEN
40229 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40230 ELSEIF(P2.LT.Q02) THEN
40231 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
40237 C...Call VMD parametrization for d quark and use to give rho, omega,
40238 C...phi. Note dipole dampening for off-shell photon.
40239 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40243 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40244 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40246 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40248 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
40249 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40250 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40251 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
40252 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40253 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40254 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
40255 VXPVMD(2)=FRACU*FACUD*XFVAL
40256 VXPVMD(3)=FACS*XFVAL
40257 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
40258 VXPVMD(-2)=FRACU*FACUD*XFVAL
40259 VXPVMD(-3)=FACS*XFVAL
40262 C...Anomalous parametrizations for different strategies
40263 C...for off-shell photons; except full integration.
40265 C...Call anomalous parametrization for d + u + s.
40266 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40268 XPANL(KFL)=FACNOR*XPGA(KFL)
40269 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40272 C...Call anomalous parametrization for c and b.
40273 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40275 XPANH(KFL)=FACNOR*XPGA(KFL)
40276 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40278 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40280 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40281 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40285 C...Special option: loop over flavours and integrate over k2.
40287 DO 160 ISTEP=1,NSTEP
40288 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
40289 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40290 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40291 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40292 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40293 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
40294 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
40296 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40297 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40298 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40299 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40305 C...Call Bethe-Heitler term expression for charm and bottom.
40306 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
40309 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
40313 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40314 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40315 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
40317 XPDIR(KFL)=XPGA(KFL)
40321 C...Store result in output array.
40324 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
40325 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40326 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40327 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40328 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40334 C*********************************************************************
40337 C...Evaluates the VMD parton distributions of a photon,
40338 C...evolved homogeneously from an initial scale P2 to Q2.
40339 C...Does not include dipole suppression factor.
40340 C...ISET is parton distribution set, see above;
40341 C...additionally ISET=0 is used for the evolution of an anomalous photon
40342 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40343 C...ALAM is the 4-flavour Lambda, which is automatically converted
40344 C...to 3- and 5-flavour equivalents as needed.
40345 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40347 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40349 C...Double precision and integer declarations.
40350 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40351 IMPLICIT INTEGER(I-N)
40352 INTEGER PYK,PYCHGE,PYCOMP
40353 C...Local arrays and data.
40354 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40355 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
40364 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40365 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
40366 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
40367 P2EFF=MAX(P2,1.2D0*ALAM3**2)
40368 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40369 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40370 Q2EFF=MAX(Q2,P2EFF)
40372 C...Find number of flavours at lower and upper scale.
40374 IF(P2EFF.LT.PMC**2) NFP=3
40375 IF(P2EFF.GT.PMB**2) NFP=5
40377 IF(Q2EFF.LT.PMC**2) NFQ=3
40378 IF(Q2EFF.GT.PMB**2) NFQ=5
40380 C...Find s as sum of 3-, 4- and 5-flavour parts.
40384 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40385 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40387 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40389 IF(NFP.EQ.3) P2DIV=PMC**2
40391 IF(NFQ.EQ.5) Q2DIV=PMB**2
40392 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40396 IF(NFP.EQ.5) P2DIV=P2EFF
40397 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40400 C...Calculate frequent combinations of x and s.
40407 C...Evaluate homogeneous anomalous parton distributions below or
40408 C...above threshold.
40410 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40411 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40412 XVAL = X * 1.5D0 * (X**2+X1**2)
40416 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
40417 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
40418 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
40419 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
40420 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
40421 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
40422 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
40423 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
40424 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
40425 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
40426 & (2D0*X-1D0)*X*XL**2)
40429 C...Evaluate set 1D parton distributions below or above threshold.
40430 ELSEIF(ISET.EQ.1) THEN
40431 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40432 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40433 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
40434 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
40435 XSEA = 0.100D0 * X1**3.76D0
40437 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
40438 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
40439 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
40440 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
40441 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
40442 & X**0.40D0 * X1**(1.76D0+3D0*S)
40443 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
40444 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
40445 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
40446 XSEA0 = 0.100D0 * X1**3.76D0
40449 C...Evaluate set 1M parton distributions below or above threshold.
40450 ELSEIF(ISET.EQ.2) THEN
40451 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40452 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40453 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
40454 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
40457 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
40458 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
40459 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
40460 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
40461 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
40462 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
40463 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
40464 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
40469 C...Evaluate set 2D parton distributions below or above threshold.
40470 ELSEIF(ISET.EQ.3) THEN
40471 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40472 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40473 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
40474 XGLU = 1.925D0 * X1**2
40475 XSEA = 0.242D0 * X1**4
40477 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
40478 & X**(0.46D0+0.25D0*S) *
40479 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
40480 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
40481 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
40482 & EXP(-18.67D0*S) *
40483 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
40484 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
40485 & XL**(9.3D0*S/(1D0+1.7D0*S))
40486 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
40487 & (1D0-0.607D0*S+21.95D0*S2) *
40488 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
40489 XSEA0 = 0.242D0 * X1**4
40492 C...Evaluate set 2M parton distributions below or above threshold.
40493 ELSEIF(ISET.EQ.4) THEN
40494 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40495 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40496 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
40497 XGLU = 1.808D0 * X1**2
40498 XSEA = 0.209D0 * X1**4
40500 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
40501 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
40502 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
40503 & XL**(5.15D0*S/(1D0+2D0*S)) +
40504 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
40505 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
40506 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
40507 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
40508 & XL**(10.9D0*S/(1D0+2.5D0*S))
40509 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
40510 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
40511 & X1**(4D0+S) * XL**(0.45D0*S)
40512 XSEA0 = 0.209D0 * X1**4
40516 C...Threshold factors for c and b sea.
40517 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40519 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40520 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40522 XCHM=XSEA*(1D0-(SCH/SLL)**2)
40524 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
40528 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40529 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40531 XBOT=XSEA*(1D0-(SBT/SLL)**2)
40533 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
40537 C...Fill parton distributions.
40544 XPGA(KFA)=XPGA(KFA)+XVAL
40546 XPGA(-KFL)=XPGA(KFL)
40554 C*********************************************************************
40557 C...Evaluates the parton distributions of the anomalous photon,
40558 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
40559 C...KF=0 gives the sum over (up to) 5 flavours,
40560 C...KF<0 limits to flavours up to abs(KF),
40561 C...KF>0 is for flavour KF only.
40562 C...ALAM is the 4-flavour Lambda, which is automatically converted
40563 C...to 3- and 5-flavour equivalents as needed.
40564 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40566 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40568 C...Double precision and integer declarations.
40569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40570 IMPLICIT INTEGER(I-N)
40571 INTEGER PYK,PYCHGE,PYCOMP
40572 C...Local arrays and data.
40573 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40574 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
40581 IF(Q2.LE.P2) RETURN
40584 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40585 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
40587 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
40588 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
40589 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40590 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40591 Q2EFF=MAX(Q2,P2EFF)
40594 C...Find number of flavours at lower and upper scale.
40596 IF(P2EFF.LT.PMC**2) NFP=3
40597 IF(P2EFF.GT.PMB**2) NFP=5
40599 IF(Q2EFF.LT.PMC**2) NFQ=3
40600 IF(Q2EFF.GT.PMB**2) NFQ=5
40602 C...Define range of flavour loop.
40606 ELSEIF(KF.LT.0) THEN
40614 C...Loop over flavours the photon can branch into.
40615 DO 110 KFL=KFLMN,KFLMX
40617 C...Light flavours: calculate t range and (approximate) s range.
40618 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
40619 TDIFF=LOG(Q2EFF/P2EFF)
40620 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40621 & LOG(P2EFF/ALAMSQ(NFQ)))
40622 IF(NFQ.GT.NFP) THEN
40624 IF(NFQ.EQ.4) Q2DIV=PMC**2
40625 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40626 & LOG(P2EFF/ALAMSQ(NFQ)))
40627 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40628 & LOG(P2EFF/ALAMSQ(NFQ-1)))
40629 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40631 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
40633 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
40634 & LOG(P2EFF/ALAMSQ(4)))
40635 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
40636 & LOG(P2EFF/ALAMSQ(3)))
40637 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
40640 C...u and s quark do not need a separate treatment when d has been done.
40641 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
40643 C...Charm: as above, but only include range above c threshold.
40644 ELSEIF(KFL.EQ.4) THEN
40645 IF(Q2.LE.PMC**2) GOTO 110
40646 P2EFF=MAX(P2EFF,PMC**2)
40647 Q2EFF=MAX(Q2EFF,P2EFF)
40648 TDIFF=LOG(Q2EFF/P2EFF)
40649 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40650 & LOG(P2EFF/ALAMSQ(NFQ)))
40651 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
40653 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40654 & LOG(P2EFF/ALAMSQ(NFQ)))
40655 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40656 & LOG(P2EFF/ALAMSQ(NFQ-1)))
40657 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40660 C...Bottom: as above, but only include range above b threshold.
40661 ELSEIF(KFL.EQ.5) THEN
40662 IF(Q2.LE.PMB**2) GOTO 110
40663 P2EFF=MAX(P2EFF,PMB**2)
40664 Q2EFF=MAX(Q2,P2EFF)
40665 TDIFF=LOG(Q2EFF/P2EFF)
40666 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40667 & LOG(P2EFF/ALAMSQ(NFQ)))
40670 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
40672 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
40673 FAC=AEM2PI*2D0*CHSQ*TDIFF
40675 C...Evaluate parton distributions (normalized to unit momentum sum).
40676 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
40677 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
40678 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
40679 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
40680 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
40681 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
40682 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
40683 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
40684 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
40685 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
40686 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
40687 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
40689 C...Threshold factors for c and b sea.
40690 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40692 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40693 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40694 XCHM=XSEA*(1D0-(SCH/SLL)**3)
40697 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40698 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40699 XBOT=XSEA*(1D0-(SBT/SLL)**3)
40703 C...Add contribution of each valence flavour.
40704 XPGA(0)=XPGA(0)+FAC*XGLU
40705 XPGA(1)=XPGA(1)+FAC*XSEA
40706 XPGA(2)=XPGA(2)+FAC*XSEA
40707 XPGA(3)=XPGA(3)+FAC*XSEA
40708 XPGA(4)=XPGA(4)+FAC*XCHM
40709 XPGA(5)=XPGA(5)+FAC*XBOT
40710 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
40711 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
40714 XPGA(-KFL)=XPGA(KFL)
40715 VXPGA(-KFL)=VXPGA(KFL)
40722 C*********************************************************************
40725 C...Evaluates the Bethe-Heitler cross section for heavy flavour
40727 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40729 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
40731 C...Double precision and integer declarations.
40732 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40733 IMPLICIT INTEGER(I-N)
40734 INTEGER PYK,PYCHGE,PYCOMP
40737 DATA AEM2PI/0.0011614D0/
40743 C...Check kinematics limits.
40744 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
40746 BETA2=1D0-4D0*PM2/W2
40747 IF(BETA2.LT.1D-10) RETURN
40751 C...Simple case: P2 = 0.
40752 IF(P2.LT.1D-4) THEN
40753 IF(BETA.LT.0.99D0) THEN
40754 XBL=LOG((1D0+BETA)/(1D0-BETA))
40756 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
40758 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
40759 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40761 C...Complicated case: P2 > 0, based on approximation of
40762 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40764 RPQ=1D0-4D0*X**2*P2/Q2
40765 IF(RPQ.GT.1D-10) THEN
40766 RPBE=SQRT(RPQ*BETA2)
40767 IF(RPBE.LT.0.99D0) THEN
40768 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40769 XBI=2D0*RPBE/(1D0-RPBE**2)
40771 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40772 XBL=LOG((1D0+RPBE)**2/RPBESN)
40773 XBI=2D0*RPBE/RPBESN
40775 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40776 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40777 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40781 C...Multiply by charge-squared etc. to get parton distribution.
40783 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40784 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40789 C*********************************************************************
40792 C...Evaluates the direct contribution, i.e. the C^gamma term,
40793 C...as needed in MSbar parametrizations.
40794 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40796 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40798 C...Double precision and integer declarations.
40799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40800 IMPLICIT INTEGER(I-N)
40801 INTEGER PYK,PYCHGE,PYCOMP
40802 C...Local array and data.
40803 DIMENSION XPGA(-6:6)
40804 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40811 C...Evaluate common x-dependent expression.
40812 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40813 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40815 C...d, u, s part by simple charge factor.
40816 XPGA(1)=(1D0/9D0)*CGAM
40817 XPGA(2)=(4D0/9D0)*CGAM
40818 XPGA(3)=(1D0/9D0)*CGAM
40820 C...Also fill for antiquarks.
40828 C*********************************************************************
40831 C...Gives pi+ parton distribution according to two different
40832 C...parametrizations.
40834 SUBROUTINE PYPDPI(X,Q2,XPPI)
40836 C...Double precision and integer declarations.
40837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40838 IMPLICIT INTEGER(I-N)
40839 INTEGER PYK,PYCHGE,PYCOMP
40841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40842 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40843 COMMON/PYINT1/MINT(400),VINT(400)
40844 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40846 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40848 C...The following data lines are coefficients needed in the
40849 C...Owens pion parton distribution parametrizations, see below.
40850 C...Expansion coefficients for up and down valence quark distributions.
40851 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40852 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40853 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40854 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40855 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40856 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40857 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40858 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40859 C...Expansion coefficients for gluon distribution.
40860 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40861 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40862 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40863 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40864 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40865 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40866 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40867 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40868 C...Expansion coefficients for (up+down+strange) quark sea distribution.
40869 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40870 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40871 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40872 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40873 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40874 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40875 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40876 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40877 C...Expansion coefficients for charm quark sea distribution.
40878 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40879 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40880 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40881 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40882 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40883 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40884 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40885 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40887 C...Euler's beta function, requires ordinary Gamma function
40888 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40890 C...Reset output array.
40895 IF(MSTP(53).LE.2) THEN
40896 C...Pion parton distributions from Owens.
40897 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40899 C...Determine set, Lambda and s expansion variable.
40901 IF(NSET.EQ.1) ALAM=0.2D0
40902 IF(NSET.EQ.2) ALAM=0.4D0
40904 IF(MSTP(57).LE.0) THEN
40907 Q2IN=MIN(2D3,MAX(4D0,Q2))
40908 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40911 C...Calculate parton distributions.
40914 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40915 & COW(3,IS,KFL,NSET)*SD**2
40918 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40920 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40925 C...Put into output array.
40928 XPPI(2)=XQ(1)+XQ(3)/6D0
40931 XPPI(-1)=XQ(1)+XQ(3)/6D0
40936 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40937 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40941 C...Determine s expansion variable and some x expressions.
40943 IF(MSTP(57).LE.0) THEN
40946 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40947 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40953 C...Evaluate valence, gluon and sea distributions.
40954 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40955 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40956 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40958 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40959 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40961 & (1D0-X)**(0.390D0+1.053D0*SD)
40962 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40964 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40966 & XL**(2.538D0-0.763D0*SD)
40967 IF(SD.LE.0.888D0) THEN
40970 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40972 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40975 IF(SD.LE.1.351D0) THEN
40978 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40979 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40983 C...Put into output array.
40991 XPPI(-KFL)=XPPI(KFL)
40993 XPPI(2)=XPPI(2)+XFVAL
40994 XPPI(-1)=XPPI(-1)+XFVAL
41000 C*********************************************************************
41003 C...Gives proton parton distributions according to a few different
41004 C...parametrizations.
41006 SUBROUTINE PYPDPR(X,Q2,XPPR)
41008 C...Double precision and integer declarations.
41009 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41010 IMPLICIT INTEGER(I-N)
41011 INTEGER PYK,PYCHGE,PYCOMP
41013 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41014 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41015 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41016 COMMON/PYINT1/MINT(400),VINT(400)
41017 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41018 C...Arrays and data.
41019 DIMENSION XPPR(-6:6),Q2MIN(16)
41020 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
41021 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
41023 C...Reset output array.
41028 C...Common preliminaries.
41029 NSET=MAX(1,MIN(16,MSTP(51)))
41030 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
41031 VINT(231)=Q2MIN(NSET)
41032 IF(MSTP(57).EQ.0) THEN
41035 Q2L=MAX(Q2MIN(NSET),Q2)
41038 IF(NSET.GE.1.AND.NSET.LE.3) THEN
41039 C...Interface to the CTEQ 3 parton distributions.
41040 QRT=SQRT(MAX(1D0,Q2L))
41042 C...Loop over flavours.
41045 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
41046 ELSEIF(I.LE.2) THEN
41047 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
41053 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
41054 C...Interface to the GRV 94 distributions.
41056 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41057 ELSEIF(NSET.EQ.5) THEN
41058 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41060 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41063 C...Put into output array.
41065 XPPR(-1)=0.5D0*(UDB+DEL)
41066 XPPR(-2)=0.5D0*(UDB-DEL)
41070 XPPR(1)=DV+XPPR(-1)
41071 XPPR(2)=UV+XPPR(-2)
41076 ELSEIF(NSET.EQ.7) THEN
41077 C...Interface to the CTEQ 5L parton distributions.
41078 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
41079 C...freezing x*f(x,Q2) at borders.
41080 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
41081 XIN=MAX(1D-6,MIN(1D0,X))
41083 C...Loop over flavours (with u <-> d notation mismatch).
41084 SUMUDB=PYCT5L(-1,XIN,QRT)
41085 RATUDB=PYCT5L(-2,XIN,QRT)
41088 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
41089 ELSEIF(I.EQ.2) THEN
41090 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
41091 ELSEIF(I.EQ.-1) THEN
41092 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
41093 ELSEIF(I.EQ.-2) THEN
41094 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
41096 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
41097 IF(I.LT.0) XPPR(-I)=XPPR(I)
41101 ELSEIF(NSET.EQ.8) THEN
41102 C...Interface to the CTEQ 5M1 parton distributions.
41103 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
41104 XIN=MAX(1D-6,MIN(1D0,X))
41106 C...Loop over flavours (with u <-> d notation mismatch).
41107 SUMUDB=PYCT5M(-1,XIN,QRT)
41108 RATUDB=PYCT5M(-2,XIN,QRT)
41111 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
41112 ELSEIF(I.EQ.2) THEN
41113 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
41114 ELSEIF(I.EQ.-1) THEN
41115 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
41116 ELSEIF(I.EQ.-2) THEN
41117 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
41119 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
41120 IF(I.LT.0) XPPR(-I)=XPPR(I)
41124 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
41125 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
41126 C...obsolete but offers backwards compatibility.
41127 CALL PYPDPO(X,Q2L,XPPR)
41129 C...Symmetric choice for debugging only
41130 ELSEIF(NSET.EQ.16) THEN
41148 C*********************************************************************
41151 C...Gives the CTEQ 3 parton distribution function sets in
41152 C...parametrized form, of October 24, 1994.
41153 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
41154 C...J. Qiu, W.K. Tung and H. Weerts.
41156 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
41158 C...Double precision declaration.
41159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41160 IMPLICIT INTEGER(I-N)
41162 C...Data on Lambda values of fits, minimum Q and quark masses.
41163 DIMENSION ALM(3), QMS(4:6)
41164 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
41165 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
41167 C....Check flavour thresholds. Set up QI for SB.
41170 IF(Q .LE. QMS(IP)) THEN
41179 C...Use "standard lambda" of parametrization program for expansion.
41181 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
41186 C...Expansion for CTEQ3L.
41187 IF(ISET .EQ. 1) THEN
41188 IF(IPRT .EQ. 2) THEN
41189 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
41191 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
41192 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
41193 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
41194 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
41195 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
41196 ELSEIF(IPRT .EQ. 1) THEN
41197 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
41199 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
41200 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
41201 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
41202 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
41203 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
41204 ELSEIF(IPRT .EQ. 0) THEN
41205 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
41207 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
41208 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
41209 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
41210 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
41211 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
41212 ELSEIF(IPRT .EQ. -1) THEN
41213 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
41215 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
41216 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
41217 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
41218 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
41219 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
41220 ELSEIF(IPRT .EQ. -2) THEN
41221 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
41223 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
41224 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
41225 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
41226 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
41227 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
41228 ELSEIF(IPRT .EQ. -3) THEN
41229 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
41231 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
41232 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
41233 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
41234 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
41235 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
41236 ELSEIF(IPRT .EQ. -4) THEN
41237 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
41239 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
41240 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
41241 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
41242 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
41243 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
41244 ELSEIF(IPRT .EQ. -5) THEN
41245 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
41247 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
41248 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
41249 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
41250 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
41251 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
41252 ELSEIF(IPRT .EQ. -6) THEN
41253 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
41255 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
41256 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
41257 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
41258 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
41259 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
41262 C...Expansion for CTEQ3M.
41263 ELSEIF(ISET .EQ. 2) THEN
41264 IF(IPRT .EQ. 2) THEN
41265 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
41267 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
41268 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
41269 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
41270 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
41271 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
41272 ELSEIF(IPRT .EQ. 1) THEN
41273 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
41275 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
41276 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
41277 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
41278 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
41279 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
41280 ELSEIF(IPRT .EQ. 0) THEN
41281 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
41283 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
41284 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
41285 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
41286 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
41287 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
41288 ELSEIF(IPRT .EQ. -1) THEN
41289 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
41291 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
41292 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
41293 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
41294 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
41295 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
41296 ELSEIF(IPRT .EQ. -2) THEN
41297 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
41299 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
41300 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
41301 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
41302 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
41303 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
41304 ELSEIF(IPRT .EQ. -3) THEN
41305 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
41307 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
41308 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
41309 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
41310 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
41311 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
41312 ELSEIF(IPRT .EQ. -4) THEN
41313 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
41315 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
41316 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
41317 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
41318 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
41319 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
41320 ELSEIF(IPRT .EQ. -5) THEN
41321 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
41323 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
41324 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
41325 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
41326 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
41327 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
41328 ELSEIF(IPRT .EQ. -6) THEN
41329 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
41331 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
41332 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
41333 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
41334 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
41335 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
41338 C...Expansion for CTEQ3D.
41339 ELSEIF(ISET .EQ. 3) THEN
41340 IF(IPRT .EQ. 2) THEN
41341 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
41343 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
41344 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
41345 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
41346 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
41347 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
41348 ELSEIF(IPRT .EQ. 1) THEN
41349 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
41351 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
41352 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
41353 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
41354 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
41355 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
41356 ELSEIF(IPRT .EQ. 0) THEN
41357 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
41359 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
41360 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
41361 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
41362 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
41363 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
41364 ELSEIF(IPRT .EQ. -1) THEN
41365 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
41367 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
41368 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
41369 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
41370 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
41371 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
41372 ELSEIF(IPRT .EQ. -2) THEN
41373 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
41375 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
41376 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
41377 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
41378 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
41379 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
41380 ELSEIF(IPRT .EQ. -3) THEN
41381 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
41383 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
41384 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
41385 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
41386 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
41387 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
41388 ELSEIF(IPRT .EQ. -4) THEN
41389 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
41391 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
41392 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
41393 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
41394 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
41395 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
41396 ELSEIF(IPRT .EQ. -5) THEN
41397 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
41399 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
41400 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
41401 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
41402 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
41403 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
41404 ELSEIF(IPRT .EQ. -6) THEN
41405 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
41407 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
41408 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
41409 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
41410 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
41411 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
41415 C...Calculation of x * f(x, Q).
41416 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
41417 & *(LOG(1D0+1D0/X))**A5 )
41422 C*********************************************************************
41425 C...Gives the GRV 94 L (leading order) parton distribution function set
41426 C...in parametrized form.
41427 C...Authors: M. Glueck, E. Reya and A. Vogt.
41429 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41431 C...Double precision declaration.
41432 IMPLICIT DOUBLE PRECISION (A - Z)
41434 C...Common expressions.
41436 LAM2 = 0.2322D0 * 0.2322D0
41437 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41443 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
41444 AKU = 0.590D0 - 0.024D0 * S
41445 BKU = 0.131D0 + 0.063D0 * S
41446 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
41447 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
41448 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
41449 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
41450 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41453 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
41455 BKD = 0.486D0 + 0.062D0 * S
41456 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
41457 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
41458 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
41459 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
41460 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41463 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
41464 AKE = 0.409D0 - 0.005D0 * S
41465 BKE = 0.799D0 + 0.071D0 * S
41466 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
41467 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
41469 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
41470 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41475 AKX = 0.410D0 - 0.232D0 * S
41476 BKX = 0.534D0 - 0.457D0 * S
41477 AGX = 0.890D0 - 0.140D0 * S
41479 CX = 0.320D0 + 0.683D0 * S
41480 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
41481 EX = 4.119D0 + 1.713D0 * S
41482 ESX = 0.682D0 + 2.978D0 * S
41483 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41490 AKS = 1.798D0 - 0.596D0 * S
41491 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
41492 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
41493 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
41494 EST = 3.981D0 + 1.638D0 * S
41496 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41504 BC = 4.24D0 - 0.804D0 * S
41505 DCT = 3.46D0 - 1.076D0 * S
41506 ECT = 4.61D0 + 1.49D0 * S
41507 ESC = 2.555D0 + 1.961D0 * S
41508 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41517 DBT = 2.929D0 + 1.396D0 * S
41518 EBT = 4.71D0 + 1.514D0 * S
41519 ESB = 4.02D0 + 1.239D0 * S
41520 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41525 AKG = 1.742D0 - 0.930D0 * S
41526 BKG = - 0.399D0 * S2
41527 AG = 7.486D0 - 2.185D0 * S
41528 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
41529 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
41530 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
41531 EG = 0.807D0 + 2.005D0 * S
41532 ESG = 3.841D0 + 0.316D0 * S
41533 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
41539 C*********************************************************************
41542 C...Gives the GRV 94 M (MSbar) parton distribution function set
41543 C...in parametrized form.
41544 C...Authors: M. Glueck, E. Reya and A. Vogt.
41546 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41548 C...Double precision declaration.
41549 IMPLICIT DOUBLE PRECISION (A - Z)
41551 C...Common expressions.
41553 LAM2 = 0.248D0 * 0.248D0
41554 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41560 NU = 1.304D0 + 0.863D0 * S
41561 AKU = 0.558D0 - 0.020D0 * S
41563 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
41564 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
41565 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
41566 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
41567 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41570 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
41571 AKD = 0.270D0 - 0.019D0 * S
41573 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
41574 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
41575 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
41576 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
41577 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41580 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
41581 AKE = 0.409D0 - 0.007D0 * S
41582 BKE = 0.782D0 + 0.082D0 * S
41583 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
41584 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
41586 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
41587 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41595 BGX = 3.210D0 - 1.866D0 * S
41597 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
41598 EX = 3.077D0 + 1.446D0 * S
41599 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
41600 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41607 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
41608 AS = -4.329D0 + 1.131D0 * S
41609 BS = 9.568D0 - 1.744D0 * S
41610 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
41611 EST = 3.031D0 + 1.639D0 * S
41612 ESS = 5.837D0 + 0.815D0 * S
41613 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41619 AKC = -0.625D0 - 0.523D0 * S
41621 BC = 1.896D0 + 1.616D0 * S
41622 DCT = 4.12D0 + 0.683D0 * S
41623 ECT = 4.36D0 + 1.328D0 * S
41624 ESC = 0.677D0 + 0.679D0 * S
41625 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41631 AKB = - 0.193D0 * S
41634 DBT = 3.447D0 + 0.927D0 * S
41635 EBT = 4.68D0 + 1.259D0 * S
41636 ESB = 1.892D0 + 2.199D0 * S
41637 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41642 AKG = 1.724D0 + 0.157D0 * S
41643 BKG = 0.800D0 + 1.016D0 * S
41644 AG = 7.517D0 - 2.547D0 * S
41645 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
41646 CG = 4.039D0 + 1.491D0 * S
41647 DG = 3.404D0 + 0.830D0 * S
41648 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
41649 ESG = 3.256D0 - 0.436D0 * S
41650 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41655 C*********************************************************************
41658 C...Gives the GRV 94 D (DIS) parton distribution function set
41659 C...in parametrized form.
41660 C...Authors: M. Glueck, E. Reya and A. Vogt.
41662 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41664 C...Double precision declaration.
41665 IMPLICIT DOUBLE PRECISION (A - Z)
41667 C...Common expressions.
41669 LAM2 = 0.248D0 * 0.248D0
41670 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41676 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
41677 AKU = 0.563D0 - 0.025D0 * S
41678 BKU = 0.054D0 + 0.154D0 * S
41679 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
41680 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
41681 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
41682 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
41683 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41686 ND = 0.156D0 - 0.017D0 * S
41687 AKD = 0.299D0 - 0.022D0 * S
41688 BKD = 0.259D0 - 0.015D0 * S
41689 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
41690 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
41691 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
41692 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
41693 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41696 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
41697 AKE = 0.419D0 - 0.013D0 * S
41698 BKE = 1.064D0 - 0.038D0 * S
41699 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
41700 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
41701 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
41702 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
41703 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41708 AKX = 0.326D0 + 0.150D0 * S
41709 BKX = 0.956D0 + 0.405D0 * S
41711 BGX = 3.794D0 - 2.359D0 * DS
41713 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
41714 EX = 3.049D0 + 1.597D0 * S
41715 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
41716 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41723 AKS = 1.415D0 - 0.641D0 * DS
41724 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
41725 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
41726 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
41727 EST = 4.546D0 + 0.372D0 * S2
41728 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
41729 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41735 AKC = -0.625D0 - 0.523D0 * S
41737 BC = 1.896D0 + 1.616D0 * S
41738 DCT = 4.12D0 + 0.683D0 * S
41739 ECT = 4.36D0 + 1.328D0 * S
41740 ESC = 0.677D0 + 0.679D0 * S
41741 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41747 AKB = - 0.193D0 * S
41750 DBT = 3.447D0 + 0.927D0 * S
41751 EBT = 4.68D0 + 1.259D0 * S
41752 ESB = 1.892D0 + 2.199D0 * S
41753 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41759 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
41760 AG = 25.09D0 - 7.935D0 * S
41761 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41762 CG = 590.3D0 - 173.8D0 * S
41763 DG = 5.196D0 + 1.857D0 * S
41764 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41765 ESG = 3.232D0 - 0.542D0 * S
41766 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41771 C*********************************************************************
41774 C...Auxiliary for the GRV 94 parton distribution functions
41775 C...for u and d valence and d-u sea.
41776 C...Authors: M. Glueck, E. Reya and A. Vogt.
41778 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41780 C...Double precision declaration.
41781 IMPLICIT DOUBLE PRECISION (A - Z)
41785 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41791 C*********************************************************************
41794 C...Auxiliary for the GRV 94 parton distribution functions
41795 C...for d+u sea and gluon.
41796 C...Authors: M. Glueck, E. Reya and A. Vogt.
41798 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41800 C...Double precision declaration.
41801 IMPLICIT DOUBLE PRECISION (A - Z)
41805 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41806 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41811 C*********************************************************************
41814 C...Auxiliary for the GRV 94 parton distribution functions
41815 C...for s, c and b sea.
41816 C...Authors: M. Glueck, E. Reya and A. Vogt.
41818 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41820 C...Double precision declaration.
41821 IMPLICIT DOUBLE PRECISION (A - Z)
41829 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41830 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41836 C*********************************************************************
41839 C...Auxiliary function for parametrization of CTEQ5L.
41840 C...Author: J. Pumplin 9/99.
41842 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41843 C...in Parametrized Form
41844 C... September 15, 1999
41846 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41847 C... CTEQ5 PPARTON DISTRIBUTIONS"
41850 C...The CTEQ5M1 set given here is an updated version of the original
41851 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41852 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41853 C...almost all applications.
41854 C...The improvement is in the QCD evolution which is now more
41855 C...accurate, and which agrees completely with the benchmark work
41856 C...of the HERA 96/97 Workshop.
41857 C...The differences between the parametrized and the corresponding
41858 C...table versions (on which it is based) are of similar order as
41859 C...between the two version.
41861 C...!! Because accurate parametrizations over a wide range of (x,Q)
41862 C...is hard to obtain, only the most widely used sets CTEQ5M and
41863 C...CTEQ5L are available in parametrized form for now.
41865 C...These parametrizations were obtained by Jon Pumplin.
41867 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41868 C -------------------------------------------------------------------
41869 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41870 C 3 CTEQ5L Leading Order 0.127 192 146
41871 C -------------------------------------------------------------------
41872 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41873 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41876 C...The two Iset value are adopted to agree with the standard table
41879 C...Range of validity:
41880 C...The range of (x, Q) covered by this parametrization of the QCD
41881 C...evolved parton distributions is 1E-6 < x < 1 ;
41882 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41883 C...data only in a subset of that region; and the assumed DGLAP
41884 C...evolution is unlikely to be valid for all of it either.
41886 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41887 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41888 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41889 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41891 FUNCTION PYCT5L(IFL,X,Q)
41893 C...Double precision declaration.
41894 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41895 IMPLICIT INTEGER(I-N)
41897 PARAMETER (NEX=8, NLF=2)
41898 DIMENSION AM(0:NEX,0:NLF,-5:2)
41899 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41900 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41901 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41902 DIMENSION AF(0:NEX)
41904 DATA MEXVEC( 2) / 8 /
41905 DATA MLFVEC( 2) / 2 /
41906 DATA UT1VEC( 2) / 0.4971265E+01 /
41907 DATA UT2VEC( 2) / -0.1105128E+01 /
41908 DATA ALFVEC( 2) / 0.2987216E+00 /
41909 DATA QMAVEC( 2) / 0.0000000E+00 /
41910 DATA (AM( 0,K, 2),K=0, 2)
41911 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41912 DATA (AM( 1,K, 2),K=0, 2)
41913 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41914 DATA (AM( 2,K, 2),K=0, 2)
41915 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41916 DATA (AM( 3,K, 2),K=0, 2)
41917 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41918 DATA (AM( 4,K, 2),K=0, 2)
41919 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41920 DATA (AM( 5,K, 2),K=0, 2)
41921 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41922 DATA (AM( 6,K, 2),K=0, 2)
41923 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41924 DATA (AM( 7,K, 2),K=0, 2)
41925 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41926 DATA (AM( 8,K, 2),K=0, 2)
41927 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41929 DATA MEXVEC( 1) / 8 /
41930 DATA MLFVEC( 1) / 2 /
41931 DATA UT1VEC( 1) / 0.2612618E+01 /
41932 DATA UT2VEC( 1) / -0.1258304E+06 /
41933 DATA ALFVEC( 1) / 0.3407552E+00 /
41934 DATA QMAVEC( 1) / 0.0000000E+00 /
41935 DATA (AM( 0,K, 1),K=0, 2)
41936 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41937 DATA (AM( 1,K, 1),K=0, 2)
41938 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41939 DATA (AM( 2,K, 1),K=0, 2)
41940 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41941 DATA (AM( 3,K, 1),K=0, 2)
41942 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41943 DATA (AM( 4,K, 1),K=0, 2)
41944 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41945 DATA (AM( 5,K, 1),K=0, 2)
41946 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41947 DATA (AM( 6,K, 1),K=0, 2)
41948 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41949 DATA (AM( 7,K, 1),K=0, 2)
41950 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41951 DATA (AM( 8,K, 1),K=0, 2)
41952 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41954 DATA MEXVEC( 0) / 8 /
41955 DATA MLFVEC( 0) / 2 /
41956 DATA UT1VEC( 0) / -0.4656819E+00 /
41957 DATA UT2VEC( 0) / -0.2742390E+03 /
41958 DATA ALFVEC( 0) / 0.4491863E+00 /
41959 DATA QMAVEC( 0) / 0.0000000E+00 /
41960 DATA (AM( 0,K, 0),K=0, 2)
41961 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41962 DATA (AM( 1,K, 0),K=0, 2)
41963 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41964 DATA (AM( 2,K, 0),K=0, 2)
41965 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41966 DATA (AM( 3,K, 0),K=0, 2)
41967 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41968 DATA (AM( 4,K, 0),K=0, 2)
41969 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41970 DATA (AM( 5,K, 0),K=0, 2)
41971 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41972 DATA (AM( 6,K, 0),K=0, 2)
41973 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41974 DATA (AM( 7,K, 0),K=0, 2)
41975 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41976 DATA (AM( 8,K, 0),K=0, 2)
41977 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41979 DATA MEXVEC(-1) / 8 /
41980 DATA MLFVEC(-1) / 2 /
41981 DATA UT1VEC(-1) / 0.3862583E+01 /
41982 DATA UT2VEC(-1) / -0.1265969E+01 /
41983 DATA ALFVEC(-1) / 0.2457668E+00 /
41984 DATA QMAVEC(-1) / 0.0000000E+00 /
41985 DATA (AM( 0,K,-1),K=0, 2)
41986 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41987 DATA (AM( 1,K,-1),K=0, 2)
41988 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41989 DATA (AM( 2,K,-1),K=0, 2)
41990 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41991 DATA (AM( 3,K,-1),K=0, 2)
41992 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41993 DATA (AM( 4,K,-1),K=0, 2)
41994 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41995 DATA (AM( 5,K,-1),K=0, 2)
41996 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41997 DATA (AM( 6,K,-1),K=0, 2)
41998 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41999 DATA (AM( 7,K,-1),K=0, 2)
42000 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
42001 DATA (AM( 8,K,-1),K=0, 2)
42002 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
42004 DATA MEXVEC(-2) / 7 /
42005 DATA MLFVEC(-2) / 2 /
42006 DATA UT1VEC(-2) / 0.1895615E+00 /
42007 DATA UT2VEC(-2) / -0.3069097E+01 /
42008 DATA ALFVEC(-2) / 0.5293999E+00 /
42009 DATA QMAVEC(-2) / 0.0000000E+00 /
42010 DATA (AM( 0,K,-2),K=0, 2)
42011 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
42012 DATA (AM( 1,K,-2),K=0, 2)
42013 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
42014 DATA (AM( 2,K,-2),K=0, 2)
42015 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
42016 DATA (AM( 3,K,-2),K=0, 2)
42017 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
42018 DATA (AM( 4,K,-2),K=0, 2)
42019 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
42020 DATA (AM( 5,K,-2),K=0, 2)
42021 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
42022 DATA (AM( 6,K,-2),K=0, 2)
42023 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
42024 DATA (AM( 7,K,-2),K=0, 2)
42025 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
42027 DATA MEXVEC(-3) / 7 /
42028 DATA MLFVEC(-3) / 2 /
42029 DATA UT1VEC(-3) / 0.3753257E+01 /
42030 DATA UT2VEC(-3) / -0.1113085E+01 /
42031 DATA ALFVEC(-3) / 0.3713141E+00 /
42032 DATA QMAVEC(-3) / 0.0000000E+00 /
42033 DATA (AM( 0,K,-3),K=0, 2)
42034 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
42035 DATA (AM( 1,K,-3),K=0, 2)
42036 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
42037 DATA (AM( 2,K,-3),K=0, 2)
42038 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
42039 DATA (AM( 3,K,-3),K=0, 2)
42040 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
42041 DATA (AM( 4,K,-3),K=0, 2)
42042 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
42043 DATA (AM( 5,K,-3),K=0, 2)
42044 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
42045 DATA (AM( 6,K,-3),K=0, 2)
42046 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
42047 DATA (AM( 7,K,-3),K=0, 2)
42048 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
42050 DATA MEXVEC(-4) / 7 /
42051 DATA MLFVEC(-4) / 2 /
42052 DATA UT1VEC(-4) / 0.4400772E+01 /
42053 DATA UT2VEC(-4) / -0.1356116E+01 /
42054 DATA ALFVEC(-4) / 0.3712017E-01 /
42055 DATA QMAVEC(-4) / 0.1300000E+01 /
42056 DATA (AM( 0,K,-4),K=0, 2)
42057 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
42058 DATA (AM( 1,K,-4),K=0, 2)
42059 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
42060 DATA (AM( 2,K,-4),K=0, 2)
42061 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
42062 DATA (AM( 3,K,-4),K=0, 2)
42063 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
42064 DATA (AM( 4,K,-4),K=0, 2)
42065 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
42066 DATA (AM( 5,K,-4),K=0, 2)
42067 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
42068 DATA (AM( 6,K,-4),K=0, 2)
42069 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
42070 DATA (AM( 7,K,-4),K=0, 2)
42071 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
42073 DATA MEXVEC(-5) / 6 /
42074 DATA MLFVEC(-5) / 2 /
42075 DATA UT1VEC(-5) / 0.5562568E+01 /
42076 DATA UT2VEC(-5) / -0.1801317E+01 /
42077 DATA ALFVEC(-5) / 0.4952010E-02 /
42078 DATA QMAVEC(-5) / 0.4500000E+01 /
42079 DATA (AM( 0,K,-5),K=0, 2)
42080 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
42081 DATA (AM( 1,K,-5),K=0, 2)
42082 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
42083 DATA (AM( 2,K,-5),K=0, 2)
42084 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
42085 DATA (AM( 3,K,-5),K=0, 2)
42086 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
42087 DATA (AM( 4,K,-5),K=0, 2)
42088 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
42089 DATA (AM( 5,K,-5),K=0, 2)
42090 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
42091 DATA (AM( 6,K,-5),K=0, 2)
42092 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
42094 IF(Q .LE. QMAVEC(IFL)) THEN
42099 IF(X .GE. 1.D0) THEN
42104 TMP = LOG(Q/ALFVEC(IFL))
42105 IF(TMP .LE. 0.D0) THEN
42117 DO 100 K = 0, MLFVEC(IFL)
42118 AF(I) = AF(I) + SBX*AM(I,K,IFL)
42124 U = LOG(X/0.00001D0)
42126 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
42127 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
42128 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
42129 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
42130 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
42132 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
42134 C...Include threshold factor.
42135 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
42140 C*********************************************************************
42143 C...Auxiliary function for parametrization of CTEQ5M1.
42144 C...Author: J. Pumplin 9/99.
42146 FUNCTION PYCT5M(IFL,X,Q)
42148 C...Double precision declaration.
42149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42150 IMPLICIT INTEGER(I-N)
42152 PARAMETER (NEX=8, NLF=2)
42153 DIMENSION AM(0:NEX,0:NLF,-5:2)
42154 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
42155 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
42156 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
42157 DIMENSION AF(0:NEX)
42159 DATA MEXVEC( 2) / 8 /
42160 DATA MLFVEC( 2) / 2 /
42161 DATA UT1VEC( 2) / 0.5141718E+01 /
42162 DATA UT2VEC( 2) / -0.1346944E+01 /
42163 DATA ALFVEC( 2) / 0.5260555E+00 /
42164 DATA QMAVEC( 2) / 0.0000000E+00 /
42165 DATA (AM( 0,K, 2),K=0, 2)
42166 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
42167 DATA (AM( 1,K, 2),K=0, 2)
42168 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
42169 DATA (AM( 2,K, 2),K=0, 2)
42170 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
42171 DATA (AM( 3,K, 2),K=0, 2)
42172 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
42173 DATA (AM( 4,K, 2),K=0, 2)
42174 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
42175 DATA (AM( 5,K, 2),K=0, 2)
42176 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
42177 DATA (AM( 6,K, 2),K=0, 2)
42178 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
42179 DATA (AM( 7,K, 2),K=0, 2)
42180 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
42181 DATA (AM( 8,K, 2),K=0, 2)
42182 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
42184 DATA MEXVEC( 1) / 8 /
42185 DATA MLFVEC( 1) / 2 /
42186 DATA UT1VEC( 1) / 0.4138426E+01 /
42187 DATA UT2VEC( 1) / -0.3221374E+01 /
42188 DATA ALFVEC( 1) / 0.4960962E+00 /
42189 DATA QMAVEC( 1) / 0.0000000E+00 /
42190 DATA (AM( 0,K, 1),K=0, 2)
42191 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
42192 DATA (AM( 1,K, 1),K=0, 2)
42193 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
42194 DATA (AM( 2,K, 1),K=0, 2)
42195 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
42196 DATA (AM( 3,K, 1),K=0, 2)
42197 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
42198 DATA (AM( 4,K, 1),K=0, 2)
42199 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
42200 DATA (AM( 5,K, 1),K=0, 2)
42201 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
42202 DATA (AM( 6,K, 1),K=0, 2)
42203 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
42204 DATA (AM( 7,K, 1),K=0, 2)
42205 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
42206 DATA (AM( 8,K, 1),K=0, 2)
42207 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
42209 DATA MEXVEC( 0) / 8 /
42210 DATA MLFVEC( 0) / 2 /
42211 DATA UT1VEC( 0) / -0.1026789E+01 /
42212 DATA UT2VEC( 0) / -0.9051707E+01 /
42213 DATA ALFVEC( 0) / 0.9462977E+00 /
42214 DATA QMAVEC( 0) / 0.0000000E+00 /
42215 DATA (AM( 0,K, 0),K=0, 2)
42216 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
42217 DATA (AM( 1,K, 0),K=0, 2)
42218 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
42219 DATA (AM( 2,K, 0),K=0, 2)
42220 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
42221 DATA (AM( 3,K, 0),K=0, 2)
42222 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
42223 DATA (AM( 4,K, 0),K=0, 2)
42224 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
42225 DATA (AM( 5,K, 0),K=0, 2)
42226 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
42227 DATA (AM( 6,K, 0),K=0, 2)
42228 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
42229 DATA (AM( 7,K, 0),K=0, 2)
42230 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
42231 DATA (AM( 8,K, 0),K=0, 2)
42232 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
42234 DATA MEXVEC(-1) / 8 /
42235 DATA MLFVEC(-1) / 2 /
42236 DATA UT1VEC(-1) / 0.5243571E+01 /
42237 DATA UT2VEC(-1) / -0.2870513E+01 /
42238 DATA ALFVEC(-1) / 0.6701448E+00 /
42239 DATA QMAVEC(-1) / 0.0000000E+00 /
42240 DATA (AM( 0,K,-1),K=0, 2)
42241 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
42242 DATA (AM( 1,K,-1),K=0, 2)
42243 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
42244 DATA (AM( 2,K,-1),K=0, 2)
42245 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
42246 DATA (AM( 3,K,-1),K=0, 2)
42247 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
42248 DATA (AM( 4,K,-1),K=0, 2)
42249 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
42250 DATA (AM( 5,K,-1),K=0, 2)
42251 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
42252 DATA (AM( 6,K,-1),K=0, 2)
42253 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
42254 DATA (AM( 7,K,-1),K=0, 2)
42255 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
42256 DATA (AM( 8,K,-1),K=0, 2)
42257 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
42259 DATA MEXVEC(-2) / 7 /
42260 DATA MLFVEC(-2) / 2 /
42261 DATA UT1VEC(-2) / 0.4782210E+01 /
42262 DATA UT2VEC(-2) / -0.1976856E+02 /
42263 DATA ALFVEC(-2) / 0.7558374E+00 /
42264 DATA QMAVEC(-2) / 0.0000000E+00 /
42265 DATA (AM( 0,K,-2),K=0, 2)
42266 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
42267 DATA (AM( 1,K,-2),K=0, 2)
42268 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
42269 DATA (AM( 2,K,-2),K=0, 2)
42270 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
42271 DATA (AM( 3,K,-2),K=0, 2)
42272 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
42273 DATA (AM( 4,K,-2),K=0, 2)
42274 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
42275 DATA (AM( 5,K,-2),K=0, 2)
42276 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
42277 DATA (AM( 6,K,-2),K=0, 2)
42278 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
42279 DATA (AM( 7,K,-2),K=0, 2)
42280 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
42282 DATA MEXVEC(-3) / 7 /
42283 DATA MLFVEC(-3) / 2 /
42284 DATA UT1VEC(-3) / 0.4518239E+01 /
42285 DATA UT2VEC(-3) / -0.2690590E+01 /
42286 DATA ALFVEC(-3) / 0.6124079E+00 /
42287 DATA QMAVEC(-3) / 0.0000000E+00 /
42288 DATA (AM( 0,K,-3),K=0, 2)
42289 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
42290 DATA (AM( 1,K,-3),K=0, 2)
42291 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
42292 DATA (AM( 2,K,-3),K=0, 2)
42293 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
42294 DATA (AM( 3,K,-3),K=0, 2)
42295 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
42296 DATA (AM( 4,K,-3),K=0, 2)
42297 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
42298 DATA (AM( 5,K,-3),K=0, 2)
42299 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
42300 DATA (AM( 6,K,-3),K=0, 2)
42301 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
42302 DATA (AM( 7,K,-3),K=0, 2)
42303 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
42305 DATA MEXVEC(-4) / 7 /
42306 DATA MLFVEC(-4) / 2 /
42307 DATA UT1VEC(-4) / 0.2783230E+01 /
42308 DATA UT2VEC(-4) / -0.1746328E+01 /
42309 DATA ALFVEC(-4) / 0.1115653E+01 /
42310 DATA QMAVEC(-4) / 0.1300000E+01 /
42311 DATA (AM( 0,K,-4),K=0, 2)
42312 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
42313 DATA (AM( 1,K,-4),K=0, 2)
42314 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
42315 DATA (AM( 2,K,-4),K=0, 2)
42316 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
42317 DATA (AM( 3,K,-4),K=0, 2)
42318 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
42319 DATA (AM( 4,K,-4),K=0, 2)
42320 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
42321 DATA (AM( 5,K,-4),K=0, 2)
42322 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
42323 DATA (AM( 6,K,-4),K=0, 2)
42324 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
42325 DATA (AM( 7,K,-4),K=0, 2)
42326 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
42328 DATA MEXVEC(-5) / 6 /
42329 DATA MLFVEC(-5) / 2 /
42330 DATA UT1VEC(-5) / 0.1619654E+02 /
42331 DATA UT2VEC(-5) / -0.3367346E+01 /
42332 DATA ALFVEC(-5) / 0.5109891E-02 /
42333 DATA QMAVEC(-5) / 0.4500000E+01 /
42334 DATA (AM( 0,K,-5),K=0, 2)
42335 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
42336 DATA (AM( 1,K,-5),K=0, 2)
42337 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
42338 DATA (AM( 2,K,-5),K=0, 2)
42339 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
42340 DATA (AM( 3,K,-5),K=0, 2)
42341 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
42342 DATA (AM( 4,K,-5),K=0, 2)
42343 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
42344 DATA (AM( 5,K,-5),K=0, 2)
42345 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
42346 DATA (AM( 6,K,-5),K=0, 2)
42347 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
42349 IF(Q .LE. QMAVEC(IFL)) THEN
42354 IF(X .GE. 1.D0) THEN
42359 TMP = LOG(Q/ALFVEC(IFL))
42360 IF(TMP .LE. 0.D0) THEN
42372 DO 100 K = 0, MLFVEC(IFL)
42373 AF(I) = AF(I) + SBX*AM(I,K,IFL)
42379 U = LOG(X/0.00001D0)
42381 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
42382 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
42383 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
42384 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
42385 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
42387 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
42389 C...Include threshold factor.
42390 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
42395 C*********************************************************************
42398 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
42399 C...a few older parametrizations, now obsolete but convenient for
42400 C...backwards checks.
42402 SUBROUTINE PYPDPO(X,Q2,XPPR)
42404 C...Double precision and integer declarations.
42405 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42406 IMPLICIT INTEGER(I-N)
42407 INTEGER PYK,PYCHGE,PYCOMP
42409 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42410 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42411 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42412 COMMON/PYINT1/MINT(400),VINT(400)
42413 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
42414 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
42415 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
42418 C...The following data lines are coefficients needed in the
42419 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
42420 C...parametrizations, see below.
42421 C...Powers of 1-x in different cases.
42422 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
42423 C...Expansion coefficients for up valence quark distribution.
42424 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
42425 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
42426 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
42427 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
42428 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
42429 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
42430 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
42431 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
42432 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
42433 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
42434 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
42435 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
42436 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
42437 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
42438 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
42439 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
42440 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
42441 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
42442 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
42443 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
42444 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
42445 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
42446 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
42447 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
42448 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
42449 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
42450 C...Expansion coefficients for down valence quark distribution.
42451 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
42452 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
42453 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
42454 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
42455 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
42456 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
42457 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
42458 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
42459 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
42460 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
42461 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
42462 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
42463 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
42464 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
42465 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
42466 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
42467 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
42468 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
42469 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
42470 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
42471 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
42472 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
42473 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
42474 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
42475 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
42476 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
42477 C...Expansion coefficients for up and down sea quark distributions.
42478 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
42479 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
42480 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
42481 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
42482 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
42483 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
42484 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
42485 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
42486 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
42487 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
42488 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
42489 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
42490 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
42491 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
42492 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
42493 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
42494 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
42495 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
42496 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
42497 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
42498 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
42499 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
42500 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
42501 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
42502 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
42503 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
42504 C...Expansion coefficients for gluon distribution.
42505 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
42506 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
42507 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
42508 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
42509 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
42510 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
42511 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
42512 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
42513 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
42514 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
42515 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
42516 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
42517 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
42518 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
42519 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
42520 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
42521 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
42522 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
42523 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
42524 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
42525 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
42526 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
42527 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
42528 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
42529 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
42530 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
42531 C...Expansion coefficients for strange sea quark distribution.
42532 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
42533 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
42534 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
42535 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
42536 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
42537 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
42538 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
42539 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
42540 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
42541 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
42542 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
42543 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
42544 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
42545 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
42546 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
42547 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
42548 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
42549 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
42550 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
42551 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
42552 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
42553 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
42554 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
42555 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
42556 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
42557 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
42558 C...Expansion coefficients for charm sea quark distribution.
42559 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
42560 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
42561 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
42562 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
42563 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
42564 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
42565 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
42566 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
42567 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
42568 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
42569 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
42570 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
42571 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
42572 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
42573 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
42574 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
42575 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
42576 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
42577 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
42578 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
42579 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
42580 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
42581 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
42582 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
42583 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
42584 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
42585 C...Expansion coefficients for bottom sea quark distribution.
42586 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
42587 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
42588 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
42589 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
42590 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
42591 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
42592 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
42593 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
42594 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
42595 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
42596 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
42597 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
42598 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
42599 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
42600 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
42601 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
42602 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
42603 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
42604 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
42605 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
42606 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
42607 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
42608 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
42609 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
42610 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
42611 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
42612 C...Expansion coefficients for top sea quark distribution.
42613 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
42614 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
42615 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
42616 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
42617 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
42618 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
42619 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
42620 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
42621 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
42622 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
42623 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
42624 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
42625 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
42626 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
42627 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
42628 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
42629 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
42630 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
42631 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
42632 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
42633 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
42634 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
42635 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
42636 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
42637 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
42638 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
42640 C...The following data lines are coefficients needed in the
42641 C...Duke, Owens proton structure function parametrizations, see below.
42642 C...Expansion coefficients for (up+down) valence quark distribution.
42643 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
42644 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42645 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42646 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
42647 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
42648 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42649 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42650 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
42651 C...Expansion coefficients for down valence quark distribution.
42652 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
42653 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42654 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
42655 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
42656 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
42657 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42658 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
42659 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
42660 C...Expansion coefficients for (up+down+strange) sea quark distribution.
42661 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
42662 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42663 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
42664 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
42665 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
42666 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42667 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
42668 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
42669 C...Expansion coefficients for charm sea quark distribution.
42670 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
42671 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42672 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
42673 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
42674 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
42675 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42676 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
42677 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
42678 C...Expansion coefficients for gluon distribution.
42679 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
42680 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
42681 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
42682 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
42683 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
42684 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
42685 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
42686 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
42688 C...Euler's beta function, requires ordinary Gamma function
42689 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
42691 C...Leading order proton parton distributions from Glueck, Reya and
42692 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
42694 IF(MSTP(51).EQ.11) THEN
42696 C...Determine s expansion variable and some x expressions.
42697 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
42698 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
42703 C...Evaluate valence, gluon and sea distributions.
42704 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
42705 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
42706 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
42707 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
42708 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
42709 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
42710 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
42711 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
42712 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
42713 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
42714 & SQRT(4.066D0*SD**1.218D0*XL)))*
42715 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
42716 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
42717 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
42718 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
42719 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
42720 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
42721 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
42722 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
42723 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
42724 IF(SD.LE.0.888D0) THEN
42727 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
42728 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
42729 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
42731 IF(SD.LE.1.351D0) THEN
42734 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
42735 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
42736 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
42739 C...Put into output array.
42741 XPPR(1)=XFVDD+XFSEA
42742 XPPR(2)=XFVUD-XFVDD+XFSEA
42752 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
42753 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
42754 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
42756 C...Determine set, Lambda and x and t expansion variables.
42758 IF(NSET.EQ.1) ALAM=0.2D0
42759 IF(NSET.EQ.2) ALAM=0.29D0
42760 TMIN=LOG(5D0/ALAM**2)
42761 TMAX=LOG(1D8/ALAM**2)
42762 T=LOG(MAX(1D0,Q2/ALAM**2))
42763 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42765 IF(X.LE.0.1D0) NX=2
42766 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42767 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42769 C...Chebyshev polynomials for x and t expansion.
42772 TX(3)=2D0*VX**2-1D0
42773 TX(4)=4D0*VX**3-3D0*VX
42774 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42775 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42778 TT(3)=2D0*VT**2-1D0
42779 TT(4)=4D0*VT**3-3D0*VT
42780 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42781 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42783 C...Calculate structure functions.
42788 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42791 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42794 C...Put into output array.
42796 XPPR(1)=XQ(2)+XQ(3)
42797 XPPR(2)=XQ(1)+XQ(3)
42805 C...Special expansion for bottom (threshold effects).
42806 IF(MSTP(58).GE.5) THEN
42807 IF(NSET.EQ.1) TMIN=8.1905D0
42808 IF(NSET.EQ.2) TMIN=7.4474D0
42810 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42813 TT(3)=2D0*VT**2-1D0
42814 TT(4)=4D0*VT**3-3D0*VT
42815 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42816 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42820 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42823 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42828 C...Special expansion for top (threshold effects).
42829 IF(MSTP(58).GE.6) THEN
42830 IF(NSET.EQ.1) TMIN=11.5528D0
42831 IF(NSET.EQ.2) TMIN=10.8097D0
42832 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42833 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42835 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42838 TT(3)=2D0*VT**2-1D0
42839 TT(4)=4D0*VT**3-3D0*VT
42840 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42841 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42845 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42848 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42853 C...Proton parton distributions from Duke, Owens.
42854 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42855 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42857 C...Determine set, Lambda and s expansion parameter.
42859 IF(NSET.EQ.1) ALAM=0.2D0
42860 IF(NSET.EQ.2) ALAM=0.4D0
42861 Q2IN=MIN(1D6,MAX(4D0,Q2))
42862 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42864 C...Calculate structure functions.
42867 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42868 & CDO(3,IS,KFL,NSET)*SD**2
42871 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42872 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42874 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42875 & TS(5)*X**2+TS(6)*X**3)
42879 C...Put into output arrays.
42881 XPPR(1)=XQ(2)+XQ(3)/6D0
42882 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42895 C*********************************************************************
42898 C...Gives threshold attractive/repulsive factor for heavy flavour
42901 FUNCTION PYHFTH(SH,SQM,FRATT)
42903 C...Double precision and integer declarations.
42904 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42905 IMPLICIT INTEGER(I-N)
42906 INTEGER PYK,PYCHGE,PYCOMP
42908 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42909 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42910 COMMON/PYINT1/MINT(400),VINT(400)
42911 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42913 C...Value for alpha_strong.
42914 IF(MSTP(35).LE.1) THEN
42919 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42925 C...Evaluate attractive and repulsive factors.
42926 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42927 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42928 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42929 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42930 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42936 C*********************************************************************
42939 C...Splits a hadron remnant into two (partons or hadron + parton)
42940 C...in case it is more complicated than just a quark or a diquark.
42942 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42944 C...Double precision and integer declarations.
42945 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42946 IMPLICIT INTEGER(I-N)
42947 INTEGER PYK,PYCHGE,PYCOMP
42948 C...Commonblocks. PYDAT1 temporary
42949 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42950 COMMON/PYINT1/MINT(400),VINT(400)
42951 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42952 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42956 C...Preliminaries. Parton composition.
42959 KFL(1)=MOD(KFA/1000,10)
42960 KFL(2)=MOD(KFA/100,10)
42961 KFL(3)=MOD(KFA/10,10)
42962 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42963 KFL(2)=INT(1.5D0+PYR(0))
42964 IF(MINT(105).EQ.333) KFL(2)=3
42965 IF(MINT(105).EQ.443) KFL(2)=4
42967 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42970 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42973 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42974 KFL(2)=MOD(KFA/10,10)
42975 KFL(3)=MOD(KFA/100,10)
42977 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42984 C...Subdivide lepton.
42985 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42986 IF(KFLR.EQ.KFA) THEN
42988 ELSEIF(KFLR.EQ.22) THEN
42990 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42992 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42994 ELSEIF(KFLR.EQ.21) THEN
43002 C...Subdivide photon.
43003 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
43004 IF(KFLR.NE.21) THEN
43009 IF(RAGR.GT.0.125D0) KFLSP=2
43010 IF(RAGR.GT.0.625D0) KFLSP=3
43011 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
43015 C...Subdivide Reggeon or Pomeron.
43016 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
43017 IF(KFLIN.EQ.21) THEN
43023 C...Subdivide meson.
43024 ELSEIF(KFL(1).EQ.0) THEN
43025 KFL(2)=KFL(2)*(-1)**KFL(2)
43026 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
43027 IF(KFLR.EQ.KFL(2)) THEN
43029 ELSEIF(KFLR.EQ.KFL(3)) THEN
43031 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
43034 ELSEIF(KFLR.EQ.21) THEN
43037 ELSEIF(KFLR*KFL(2).GT.0) THEN
43040 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
43041 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43043 ELSEIF(KFLCH.EQ.0) THEN
43044 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43052 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
43053 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43055 ELSEIF(KFLCH.EQ.0) THEN
43056 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43063 C...Special case for extracting photon from baryon without splitting
43064 C...the latter. (Currently only used by external programs.)
43065 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
43069 C...Subdivide baryon.
43073 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
43076 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
43079 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
43080 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
43083 IAGR=1.00001D0+2.99998D0*PYR(0)
43086 IF(IAGR.EQ.1) ID1=2
43087 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
43090 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
43091 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
43092 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
43093 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
43094 ELSEIF(MOD(KFA,10).EQ.2) THEN
43095 IF(IAGR.EQ.1) KSP=1
43096 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
43098 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
43099 IF(KFLR.EQ.21) THEN
43101 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
43104 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
43105 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43107 ELSEIF(KFLCH.EQ.0) THEN
43108 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43112 ELSEIF(NAGR.EQ.0) THEN
43115 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
43116 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43118 ELSEIF(KFLCH.EQ.0) THEN
43119 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43127 C...Add on correct sign for result.
43134 C*********************************************************************
43137 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
43138 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
43139 C...(Dover, 1965) 6.1.36.
43143 C...Double precision and integer declarations.
43144 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43145 IMPLICIT INTEGER(I-N)
43146 INTEGER PYK,PYCHGE,PYCOMP
43147 C...Local array and data.
43149 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
43150 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
43159 PYGAMM=PYGAMM+B(I)*DXP
43165 PYGAMM=(X-IX)*PYGAMM
43172 C***********************************************************************
43175 C...Calculates real and imaginary parts of the auxiliary functions W1
43176 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
43177 C...der Bij, Nucl. Phys. B297 (1988) 221.
43179 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
43181 C...Double precision and integer declarations.
43182 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43183 IMPLICIT INTEGER(I-N)
43184 INTEGER PYK,PYCHGE,PYCOMP
43186 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43189 ASINH(X)=LOG(X+SQRT(X**2+1D0))
43190 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
43192 IF(EPS.LT.0D0) THEN
43193 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
43194 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
43196 ELSEIF(EPS.LT.1D0) THEN
43197 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
43198 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
43199 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
43200 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
43202 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
43203 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
43210 C***********************************************************************
43213 C...Calculates real and imaginary parts of the auxiliary function I3;
43214 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
43215 C...Nucl. Phys. B297 (1988) 221.
43217 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
43219 C...Double precision and integer declarations.
43220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43221 IMPLICIT INTEGER(I-N)
43222 INTEGER PYK,PYCHGE,PYCOMP
43224 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43227 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
43228 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
43230 IF(EPS.LT.0D0) THEN
43231 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43232 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
43233 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
43234 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
43235 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
43236 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
43237 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
43238 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
43240 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
43241 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
43242 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
43243 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
43244 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
43245 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
43246 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
43247 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
43248 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43249 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
43250 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
43251 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
43252 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
43253 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
43254 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
43255 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
43257 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
43258 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
43259 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
43260 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
43261 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
43264 ELSEIF(EPS.LT.1D0) THEN
43265 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43266 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
43267 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
43268 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
43269 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
43270 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
43271 & (0.25D0*(RAT+1D0)*EPS))
43272 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
43273 & (0.25D0*(RAT+1D0)*EPS))
43274 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
43275 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
43276 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
43277 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
43278 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
43279 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
43280 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
43281 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
43282 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43283 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
43284 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
43285 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
43286 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
43287 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
43288 & (1D0+0.25D0*RAT*EPS-GA))
43289 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
43290 & (1D0+0.25D0*RAT*EPS-GA))
43292 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
43293 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
43294 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
43295 & LOG((GA+BE-1D0)/(BE-GA))
43296 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
43299 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
43300 RCTHE=RSQ*(1D0-2D0*BE/EPS)
43301 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
43302 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
43303 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
43305 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
43306 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
43307 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
43308 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
43309 & (PHI-THE)*(PHI+THE-PARU(1))
43310 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
43311 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
43314 Y3RE=2D0/(2D0*BE-1D0)*F3RE
43315 Y3IM=2D0/(2D0*BE-1D0)*F3IM
43320 C***********************************************************************
43323 C...Calculates real and imaginary part of Spence function; see
43324 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
43326 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
43328 C...Double precision and integer declarations.
43329 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43330 IMPLICIT INTEGER(I-N)
43331 INTEGER PYK,PYCHGE,PYCOMP
43333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43335 C...Local array and data.
43338 &1.000000D+00, -5.000000D-01, 1.666667D-01,
43339 &0.000000D+00, -3.333333D-02, 0.000000D+00,
43340 &2.380952D-02, 0.000000D+00, -3.333333D-02,
43341 &0.000000D+00, 7.575757D-02, 0.000000D+00,
43342 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
43346 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
43347 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
43348 IF(IREIM.EQ.2) PYSPEN=0D0
43352 XMOD=SQRT(XRE**2+XIM**2)
43353 IF(XMOD.LT.1D-6) THEN
43354 IF(IREIM.EQ.1) PYSPEN=0D0
43355 IF(IREIM.EQ.2) PYSPEN=0D0
43359 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43363 IF(XMOD.GT.1D0) THEN
43365 ALGXIM=XARG-SIGN(PARU(1),XARG)
43366 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
43367 SP0IM=-ALGXRE*ALGXIM
43374 IF(XRE.GT.0.5D0) THEN
43379 XMOD=SQRT(XRE**2+XIM**2)
43380 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43383 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
43384 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
43390 XMOD=SQRT(XRE**2+XIM**2)
43391 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43400 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
43401 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
43402 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
43405 SPRE=SPRE+B(I)*TERMRE
43406 SPIM=SPIM+B(I)*TERMIM
43409 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
43410 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
43415 C***********************************************************************
43418 C...Calculates the matrix element for the processes
43419 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
43420 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
43421 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
43423 SUBROUTINE PYQQBH(WTQQBH)
43425 C...Double precision and integer declarations.
43426 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43427 IMPLICIT INTEGER(I-N)
43428 INTEGER PYK,PYCHGE,PYCOMP
43430 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43431 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43432 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43433 COMMON/PYINT1/MINT(400),VINT(400)
43434 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43435 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
43436 C...Local arrays and function.
43437 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
43438 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
43441 C...Mass parameters.
43444 SHPR=SQRT(VINT(26))*VINT(1)
43445 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
43446 PH=SQRT(VINT(21))*VINT(1)
43450 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
43452 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43453 PP(I,1)=PT*COS(VINT(198+5*I))
43454 PP(I,2)=PT*SIN(VINT(198+5*I))
43456 PP(3,1)=-PP(1,1)-PP(2,1)
43457 PP(3,2)=-PP(1,2)-PP(2,2)
43458 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
43459 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
43460 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
43462 PP(3,3)=PMT3*SINH(VINT(211))
43463 PP(3,4)=PMT3*COSH(VINT(211))
43464 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
43465 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43466 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
43467 PP(2,3)=-PP(1,3)-PP(3,3)
43468 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
43469 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
43471 C...Set up incoming kinematics and derived momentum combinations.
43475 PP(I,3)=-0.5D0*SHPR*(-1)**I
43476 PP(I,4)=-0.5D0*SHPR
43479 PP(6,J)=PP(1,J)+PP(2,J)
43480 PP(7,J)=PP(1,J)+PP(3,J)
43481 PP(8,J)=PP(1,J)+PP(4,J)
43482 PP(9,J)=PP(1,J)+PP(5,J)
43483 PP(10,J)=-PP(2,J)-PP(3,J)
43484 PP(11,J)=-PP(2,J)-PP(4,J)
43485 PP(12,J)=-PP(2,J)-PP(5,J)
43486 PP(13,J)=-PP(4,J)-PP(5,J)
43489 C...Derived kinematics invariants.
43518 C...Define colour coefficients for g + g -> Q + Qbar + H.
43519 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
43523 CLR(I+3,J+3)=16D0/3D0
43524 CLR(I,J+3)=-2D0/3D0
43525 CLR(I+3,J)=-2D0/3D0
43538 CLR(6+K1,6+K2)=12D0
43542 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
43543 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
43544 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
43545 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
43546 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
43547 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
43548 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
43550 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
43551 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
43552 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
43553 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
43554 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
43555 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
43556 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
43557 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
43558 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
43559 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
43560 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
43561 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
43562 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
43563 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
43564 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
43565 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
43566 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
43567 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
43569 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
43570 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
43571 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
43572 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
43573 & +X4*X9*X5+X4*X5**2)
43574 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
43575 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
43576 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
43577 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
43578 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
43579 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
43580 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
43581 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
43582 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
43583 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
43584 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
43585 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
43586 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
43587 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
43588 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
43589 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
43590 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
43591 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
43592 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
43593 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
43595 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
43596 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
43597 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
43598 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
43599 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
43600 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
43601 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
43603 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
43604 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
43605 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
43606 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
43607 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
43608 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
43610 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
43611 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
43612 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
43613 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
43614 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
43615 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
43616 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
43618 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
43619 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
43620 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
43621 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
43622 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
43623 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
43624 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
43625 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
43626 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
43627 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
43628 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
43629 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
43630 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
43631 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
43632 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
43633 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
43634 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
43635 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
43636 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
43637 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
43638 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
43639 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
43640 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
43641 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
43642 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
43643 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
43644 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
43645 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
43646 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
43647 & +X3*X8*X5+X3*X5**2)
43648 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
43649 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
43650 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
43651 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
43652 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
43653 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
43654 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
43656 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
43657 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
43658 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
43659 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
43660 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
43661 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
43662 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
43663 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
43664 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
43665 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
43666 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
43667 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
43668 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
43669 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
43670 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
43671 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
43672 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
43673 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
43674 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
43675 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
43676 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
43677 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
43678 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
43679 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
43680 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
43681 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
43683 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
43684 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
43685 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
43686 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
43687 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
43688 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
43689 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
43690 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
43691 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
43692 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
43693 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
43694 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
43695 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
43696 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
43697 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
43698 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
43699 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
43700 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
43701 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
43702 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
43703 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
43704 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
43705 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
43706 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
43707 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
43708 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
43710 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
43711 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
43712 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
43713 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
43714 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
43715 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
43716 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
43717 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
43718 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
43719 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
43720 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
43721 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
43722 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
43723 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
43724 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
43725 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
43726 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
43727 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
43728 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
43729 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
43730 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
43731 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
43732 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
43733 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
43734 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
43735 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
43736 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
43737 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
43738 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
43739 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
43740 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
43741 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
43742 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
43743 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
43744 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
43745 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
43746 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
43747 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
43748 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
43749 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
43750 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
43751 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
43752 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
43753 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
43755 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
43756 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
43757 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
43758 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
43759 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43760 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43761 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43762 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43763 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43764 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43765 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43767 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43768 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43769 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43770 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43771 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43772 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43774 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43775 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43776 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43778 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43779 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43780 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43781 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43783 C...Repackage matrix elements.
43789 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43790 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43791 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43793 C...Produce final result: matrix elements * colours * propagators.
43798 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43801 WTQQBH=-WTQQBH/256D0
43804 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43805 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43806 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43808 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43809 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43810 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43812 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43813 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43816 C...Produce final result: matrix elements * propagators.
43818 A12=A12/(DX(7)*DX(8))
43820 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43826 C*********************************************************************
43828 C...PYSTBH (and auxiliaries)
43829 C.. Evaluates the matrix elements for t + b + H production.
43831 SUBROUTINE PYSTBH(WTTBH)
43833 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43835 IMPLICIT INTEGER(I-N)
43836 INTEGER PYK,PYCHGE,PYCOMP
43839 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43840 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43841 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43842 COMMON/PYINT1/MINT(400),VINT(400)
43843 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43844 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43845 COMMON/PYINT4/MWID(500),WIDS(500,5)
43846 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43847 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43848 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43849 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43850 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43851 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43852 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43853 DOUBLE PRECISION MW2
43854 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43855 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43857 C...LOCAL ARRAYS AND COMPLEX VARIABLES
43858 DIMENSION QQ(4,2),PP(4,3)
43863 C...KINEMATIC PARAMETERS.
43864 SHPR=SQRT(VINT(26))*VINT(1)
43865 PH=SQRT(VINT(21))*VINT(1)
43868 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43870 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43871 PP(1,I)=PT*COS(VINT(198+5*I))
43872 PP(2,I)=PT*SIN(VINT(198+5*I))
43874 PP(1,3)=-PP(1,1)-PP(1,2)
43875 PP(2,3)=-PP(2,1)-PP(2,2)
43876 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43877 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43878 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43880 PP(3,3)=PMT3*SINH(VINT(211))
43881 PP(4,3)=PMT3*COSH(VINT(211))
43882 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43883 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43884 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43885 PP(3,2)=-PP(3,1)-PP(3,3)
43886 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43887 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43889 C...CM SYSTEM, INGOING QUARKS/GLUONS
43890 QQ(3,1) = SHPR/2.D0
43895 C...PARAMETERS FOR AMPLITUDE METHOD
43899 MW2 = PMAS(24,1)**2
43902 RMB=PYMRUN(5,VINT(52))
43906 IF (ISUB.EQ.401) THEN
43907 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43908 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43909 ELSE IF (ISUB.EQ.402) THEN
43910 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43911 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43916 C------------------------------------------------------------------
43917 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43918 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43919 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43920 IMPLICIT INTEGER(I-N)
43921 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43922 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43925 C TOP WIDTH CALCULATION
43932 IF (MT .LT. (MHP+MB)) THEN
43934 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43935 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43936 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43939 C T ->BW +T ->B H^+
43940 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43941 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43942 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43944 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43945 & -4.D0*(MHP*MB/MT**2)**2 )
43946 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43947 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43948 GAMT = GAMTBW+GAMTBH
43955 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43956 C GG->TBH^+, QQBAR->TBH^+
43957 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43958 C (FOR INSTANCE WITH PYTHIA)
43959 C------------------------------------------------------------
43960 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43961 C PHYS REV. D 60 (1999) 115011
43962 C (THESE FILES PREPARED BY J.-L. KNEUR)
43963 C------------------------------------------------------------
43965 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43967 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43969 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43970 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43971 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43972 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43973 C "PHYSICAL PARAMETERS" INPUT:
43974 C MT,MB TOP AND BOTTOM MASSES;
43975 C MHP CHARGED HIGGS MASS
43976 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43978 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43979 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43980 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43981 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43982 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43983 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43984 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43987 IMPLICIT INTEGER(I-N)
43988 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43989 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43990 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43991 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43992 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43994 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43995 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43996 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43997 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43998 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43999 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
44000 C (TAN BETA) VALUES
44002 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44003 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44008 C COLLECTING THE RELEVANT OVERALL FACTORS:
44009 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
44010 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
44011 C COUPLING CONSTANT (OVERALL NORMALIZATION)
44012 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44013 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44014 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44015 C ALPHAS IS ALPHA_STRONG;
44016 C SW2 IS SIN(THETA_W)**2.
44019 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44021 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44022 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44023 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44025 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44026 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44028 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44030 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44031 S = 2*PYTBHS(Q1,Q2)
44038 C TOP WIDTH CALCULATION
44039 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44040 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44041 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44042 A1INV= S -2*P1Q1 -2*P1Q2
44043 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44044 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44045 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
44047 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44048 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44049 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44050 C NOW COMES THE AMP**2:
44051 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
44052 C THE EXPRESSIONS BELOW
44055 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
44056 &512*A1*A2*MB*MT/3-
44057 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
44058 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
44059 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
44060 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
44061 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
44062 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
44063 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
44064 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
44065 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
44066 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
44067 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
44068 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
44069 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
44070 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
44071 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
44072 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
44073 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
44074 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
44075 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
44076 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
44077 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
44078 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
44079 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
44080 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
44081 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
44082 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
44083 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
44084 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
44085 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
44086 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
44087 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
44088 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
44089 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
44090 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
44091 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
44092 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
44093 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
44094 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
44095 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
44096 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
44097 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
44098 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
44099 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
44100 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
44101 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
44102 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
44103 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
44104 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
44105 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
44106 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
44107 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
44108 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
44109 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
44110 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
44111 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
44112 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
44113 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
44114 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
44115 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
44116 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
44117 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
44118 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44119 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44120 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
44121 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
44122 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
44123 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
44124 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
44125 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
44126 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
44127 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
44128 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
44129 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44130 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
44131 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44132 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
44133 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
44134 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
44135 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
44136 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44137 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44138 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
44139 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
44140 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
44141 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
44142 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
44143 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
44144 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
44145 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
44146 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44147 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44148 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44149 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
44150 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
44151 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
44152 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
44153 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
44154 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
44155 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
44156 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44157 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44158 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44159 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44160 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44161 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
44162 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44163 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
44164 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44165 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
44166 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
44167 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44168 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44169 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44170 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44171 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
44172 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44173 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44174 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44175 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44176 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44177 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
44178 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44179 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44180 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44181 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44182 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44183 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
44184 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
44185 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44186 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44187 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44188 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
44189 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44190 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44191 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44192 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44193 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44194 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
44195 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44196 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
44197 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44198 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44199 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
44200 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44201 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
44202 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
44203 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44204 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44205 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
44206 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44207 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44208 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44209 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44210 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44211 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44212 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44213 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
44214 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44215 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44216 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44217 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44218 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44219 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
44220 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44221 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44222 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44223 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44224 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44225 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44226 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
44227 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44228 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
44229 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44230 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44231 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44232 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44233 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44234 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44235 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44236 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44237 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
44238 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44239 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44240 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
44241 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44242 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44243 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44244 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44245 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44246 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
44247 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44248 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44249 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44250 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
44251 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44252 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44253 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
44254 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44255 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44256 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44257 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44258 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44259 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44260 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44261 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44262 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44263 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44264 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44265 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44266 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44267 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44268 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44269 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44270 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44271 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44272 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44273 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
44274 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44275 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44276 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44277 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44278 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44279 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44280 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44281 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44282 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
44283 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44284 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44285 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44286 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44287 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44288 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44289 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44290 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44291 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
44292 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44293 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44294 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44295 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44296 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44297 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
44298 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44299 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44300 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44301 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44302 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44303 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44304 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44305 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44306 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
44307 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44308 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44309 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44310 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44311 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44312 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44313 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44314 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44315 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44316 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44317 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44318 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44319 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44320 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44321 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44322 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44323 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
44324 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44325 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44326 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44327 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
44328 &384*A12*MB*MT*P1Q1**2/S**2+
44329 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44330 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
44331 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44332 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44333 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44334 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44335 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
44336 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44337 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44338 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44339 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44340 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44341 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44342 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44343 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44344 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
44345 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44346 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
44347 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
44348 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
44349 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
44350 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
44351 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44352 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
44353 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
44354 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
44355 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
44356 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
44357 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
44358 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44359 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
44360 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44361 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
44362 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
44363 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44364 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44365 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
44366 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
44367 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
44368 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
44369 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44370 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44371 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44372 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44373 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
44374 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44375 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
44376 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
44377 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
44378 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
44379 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
44380 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44381 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
44382 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44383 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44384 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44385 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44386 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44387 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44388 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44389 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44390 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44391 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44392 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
44393 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
44394 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
44395 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
44396 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
44397 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
44398 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44399 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44400 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44401 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
44402 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44403 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
44404 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44405 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44406 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44407 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44408 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44409 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44410 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
44411 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44412 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
44413 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44414 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
44415 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44416 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44417 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
44418 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
44419 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44420 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44421 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44422 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44423 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
44424 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44425 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
44426 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44427 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44428 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44429 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
44430 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44431 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
44432 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44433 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
44434 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
44435 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
44436 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44437 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
44438 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
44439 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44440 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44441 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44442 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44443 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44444 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44445 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44446 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
44447 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
44448 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
44449 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44450 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44451 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44452 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44453 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44454 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44455 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44456 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44457 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44458 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
44459 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44460 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
44461 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44462 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44463 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44464 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44465 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
44466 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
44467 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44468 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
44469 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
44470 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44471 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44472 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
44473 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44474 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44475 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
44476 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44477 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44478 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44479 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
44480 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
44481 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44482 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
44483 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
44484 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44485 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44486 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44487 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44488 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44489 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44490 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
44491 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
44492 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
44493 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44494 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44495 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44496 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44497 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44498 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
44499 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
44500 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44501 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44502 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44503 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
44504 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
44507 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44508 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44509 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44510 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44511 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44512 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44513 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44514 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44515 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44516 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44517 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
44518 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44519 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44520 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
44521 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44522 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
44523 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
44524 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
44525 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44526 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44527 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44528 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44529 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44530 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44531 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
44532 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
44533 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44534 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44535 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
44536 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
44537 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44538 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
44539 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
44540 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
44541 &272*A1*A2*P1Q1*S/(3*P1Q2)+
44542 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
44543 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44544 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
44545 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44546 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44547 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44548 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44549 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44550 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
44551 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44552 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44553 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
44554 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44555 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
44556 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
44557 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44558 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44559 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
44560 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
44561 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
44562 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44563 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
44564 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44565 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
44566 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44567 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44568 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
44569 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44570 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44571 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
44572 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44573 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
44574 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
44575 &32*A12*P2Q1*S/(3*P1Q1)-
44576 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44577 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
44578 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
44579 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44580 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44581 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44582 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44583 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44584 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
44585 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44586 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44587 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
44588 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44589 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44590 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
44591 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
44592 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
44593 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44594 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
44595 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44596 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44597 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
44598 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44599 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
44600 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44601 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
44602 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44603 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44604 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44605 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44606 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44607 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
44608 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
44609 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
44610 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44611 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
44612 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
44613 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
44614 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44615 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44616 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44617 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44618 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44619 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44620 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44621 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44622 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44623 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44624 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
44625 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
44626 &272*A1*A2*P2Q1*S/(3*P2Q2)-
44627 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
44628 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44629 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
44630 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44631 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44632 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44633 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44634 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44635 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44636 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44637 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
44638 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44639 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44640 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44641 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
44642 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
44643 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44644 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44645 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
44646 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
44647 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44648 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44649 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44652 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
44653 &512*A1*A2*MB*MT/3+
44654 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
44655 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
44656 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
44657 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
44658 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
44659 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
44660 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
44661 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
44662 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
44663 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
44664 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
44665 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
44666 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
44667 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
44668 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
44669 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
44670 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
44671 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
44672 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
44673 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
44674 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
44675 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
44676 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
44677 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
44678 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
44679 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
44680 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
44681 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
44682 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
44683 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
44684 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
44685 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
44686 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
44687 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
44688 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
44689 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
44690 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
44691 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
44692 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
44693 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
44694 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
44695 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
44696 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
44697 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
44698 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
44699 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
44700 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
44701 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
44702 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
44703 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
44704 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
44705 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
44706 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
44707 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
44708 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
44709 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
44710 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
44711 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
44712 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
44713 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
44714 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
44715 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44716 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
44717 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
44718 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
44719 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
44720 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
44721 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
44722 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
44723 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
44724 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
44725 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
44726 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44727 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44728 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44729 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
44730 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
44731 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
44732 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
44733 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44734 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
44735 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
44736 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
44737 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
44738 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
44739 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
44740 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
44741 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
44742 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
44743 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44744 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
44745 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44746 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
44747 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
44748 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
44749 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
44750 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
44751 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
44752 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
44753 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44754 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44755 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44756 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44757 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44758 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
44759 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44760 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44761 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44762 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44763 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44764 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44765 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44766 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44767 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44768 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44769 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44770 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44771 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44772 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44773 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44774 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44775 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44776 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44777 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44778 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44779 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44780 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44781 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44782 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44783 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44784 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44785 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44786 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44787 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44788 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44789 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44790 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44791 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44792 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44793 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44794 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44795 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44796 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44797 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44798 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44799 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44800 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44801 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44802 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44803 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44804 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44805 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44806 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44807 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44808 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44809 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44810 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44811 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44812 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44813 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44814 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44815 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44816 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44817 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44818 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44819 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44820 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44821 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44822 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44823 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44824 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44825 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44826 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44827 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44828 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44829 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44830 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44831 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44832 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44833 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44834 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44835 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44836 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44837 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44838 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44839 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44840 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44841 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44842 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44843 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44844 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44845 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44846 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44847 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44848 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44849 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44850 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44851 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44852 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44853 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44854 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44855 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44856 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44857 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44858 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44859 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44860 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44861 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44862 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44863 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44864 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44865 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44866 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44867 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44868 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44869 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44870 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44871 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44872 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44873 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44874 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44875 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44876 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44877 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44878 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44879 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44880 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44881 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44882 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44883 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44884 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44885 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44886 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44887 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44888 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44889 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44890 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44891 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44892 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44893 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44894 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44895 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44896 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44897 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44898 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44899 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44900 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44901 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44902 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44903 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44904 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44905 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44906 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44907 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44908 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44909 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44910 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44911 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44912 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44913 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44914 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44915 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44916 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44917 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44918 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44919 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44920 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44921 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44922 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44923 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44924 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44925 &384*A12*MB*MT*P1Q1**2/S**2+
44926 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44927 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44928 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44929 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44930 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44931 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44932 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44933 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44934 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44935 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44936 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44937 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44938 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44939 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44940 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44941 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44942 &384*A2**2*MB*MT*P2Q2**2/S**2+
44943 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44944 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44945 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44946 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44947 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44948 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44949 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44950 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44951 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44952 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44953 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44954 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44955 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44956 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44957 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44958 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44959 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44960 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44961 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44962 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44963 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44964 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44965 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44966 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44967 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44968 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44969 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44970 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44971 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44972 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44973 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44974 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44975 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44976 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44977 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44978 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44979 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44980 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44981 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44982 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44983 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44984 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44985 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44986 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44987 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44988 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44989 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44990 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44991 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44992 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44993 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44994 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44995 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44996 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44997 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44998 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44999 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
45000 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
45001 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
45002 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
45003 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
45004 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
45005 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
45006 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
45007 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
45008 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
45009 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
45010 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
45011 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
45012 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
45013 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
45014 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
45015 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
45016 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
45017 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
45018 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
45019 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
45020 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
45021 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
45022 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
45023 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
45024 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
45025 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
45026 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
45027 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
45028 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
45029 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
45030 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
45031 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
45032 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
45033 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
45034 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
45035 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
45036 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
45037 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
45038 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
45039 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
45040 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
45041 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
45042 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
45043 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
45044 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
45045 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
45046 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45047 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45048 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45049 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45050 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45051 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
45052 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
45053 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
45054 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
45055 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
45056 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
45057 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
45058 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
45059 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
45060 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
45061 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
45062 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
45063 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
45064 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
45065 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
45066 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
45067 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
45068 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
45069 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
45070 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
45071 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
45072 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
45073 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
45074 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
45075 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
45076 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
45077 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
45078 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
45079 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
45080 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
45081 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
45082 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
45083 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
45084 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
45085 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
45086 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
45087 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
45088 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
45089 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
45090 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
45091 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
45092 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
45093 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
45094 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
45095 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
45096 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
45097 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
45098 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45099 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45100 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45101 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45102 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45103 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45104 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
45105 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
45106 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
45107 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
45108 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
45109 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
45110 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
45111 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
45112 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
45113 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
45114 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
45115 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
45116 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
45117 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
45118 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
45119 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
45120 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
45121 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
45122 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
45123 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
45124 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
45125 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
45126 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
45127 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
45128 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
45129 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
45130 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
45131 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
45132 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
45133 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
45134 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
45135 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
45138 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
45139 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
45140 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
45141 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
45142 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
45143 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
45144 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
45145 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
45146 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
45147 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
45148 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
45149 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
45150 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
45151 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
45152 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
45153 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
45154 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
45156 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
45157 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
45158 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
45159 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
45160 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
45161 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
45162 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
45163 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
45164 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
45165 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
45166 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
45167 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
45168 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
45169 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
45170 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
45171 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
45172 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
45173 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
45174 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
45175 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
45176 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
45177 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
45178 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
45179 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
45180 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
45181 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
45182 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
45183 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
45184 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
45185 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
45186 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
45187 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
45188 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
45189 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
45190 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
45191 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
45192 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
45193 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
45194 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
45195 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
45196 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
45197 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
45198 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
45199 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
45200 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
45201 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
45202 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
45203 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
45204 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
45205 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
45206 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
45207 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
45208 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
45209 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
45210 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45211 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45212 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45213 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45214 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45215 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45216 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45217 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
45218 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
45219 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
45220 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
45221 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
45222 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
45223 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
45224 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
45225 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
45226 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
45227 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
45228 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
45229 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
45230 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
45231 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
45232 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
45233 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
45234 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
45235 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
45236 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
45237 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
45238 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
45239 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
45240 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
45241 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
45245 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
45246 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
45247 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45248 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45249 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
45250 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
45251 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45252 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
45253 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
45254 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
45255 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45256 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45257 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
45258 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
45259 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
45260 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
45261 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
45262 V910=V910+96*A1*A2*P1P2*P2Q1/S-
45263 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
45264 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
45265 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
45266 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
45267 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
45269 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
45270 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
45271 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45272 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45273 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
45274 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
45275 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45276 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
45277 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
45278 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
45279 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45280 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45281 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
45282 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
45283 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
45284 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
45285 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
45286 A910=A910+96*A1*A2*P1P2*P2Q1/S-
45287 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
45288 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
45289 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
45290 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
45291 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
45295 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
45298 C---------------------------------------------------------
45299 C 2) Q QBAR ->TBH^+
45300 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
45302 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
45303 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
45304 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45305 IMPLICIT INTEGER(I-N)
45306 DOUBLE PRECISION MW2,MT,MB,MHP,MW
45307 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
45308 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45309 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45310 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45311 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
45312 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
45313 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
45314 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
45315 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
45316 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
45318 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
45319 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
45326 C COLLECTING THE RELEVANT OVERALL FACTORS:
45327 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
45328 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
45329 C COUPLING CONSTANT (OVERALL NORMALIZATION)
45330 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
45331 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
45332 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
45333 C ALPHAS IS ALPHA_STRONG;
45334 C SW2 IS SIN(THETA_W)**2.
45337 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
45339 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
45340 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
45341 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
45343 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
45344 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
45346 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
45348 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
45349 S = 2*PYTBHS(Q1,Q2)
45356 C TOP WIDTH CALCULATION
45357 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
45358 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
45359 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
45360 A1INV= S -2*P1Q1 -2*P1Q2
45361 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
45362 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
45363 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
45364 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
45365 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
45366 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
45367 C NOW COMES THE AMP**2:
45368 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
45369 C THE EXPRESSIONS BELOW
45370 YY(1, 1) = -16*A**2*A2**2*MB*MT+
45371 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
45372 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
45373 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
45374 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45375 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45376 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
45377 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
45378 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
45379 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
45380 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
45381 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
45382 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
45383 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
45384 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
45385 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
45386 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
45387 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
45388 &32*A2**2*MB**2*P1P2*V**2/S+
45389 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
45390 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
45391 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
45392 YY(1, 1)=2*YY(1, 1)
45394 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
45395 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
45396 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45397 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45398 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
45399 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
45400 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
45401 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45402 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
45403 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
45404 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
45405 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
45406 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
45407 &64*A**2*A1*A2*MB*MT*P1P2/S+
45408 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
45409 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
45410 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
45411 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
45412 &64*A**2*A1*A2*P1Q1*P2Q1/S-
45413 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
45414 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
45415 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
45416 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
45417 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
45418 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
45419 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
45420 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
45421 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
45422 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
45423 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
45424 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
45425 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
45426 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
45427 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
45428 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
45429 &32*A1*A2*P1P2*P1Q1*V**2/S+
45430 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
45431 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
45432 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
45433 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
45436 YY(2, 2) =-16*A**2*A12*MB*MT+
45437 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
45438 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
45439 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
45440 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
45441 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
45442 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
45443 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
45444 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
45445 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
45446 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
45447 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
45448 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
45449 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
45450 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
45451 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
45452 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
45453 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
45454 &32*A12*MT**2*P2Q2*V**2/S-
45455 &32*A12*P1Q2*P2Q2*V**2/S
45456 YY(2, 2)=2*YY(2, 2)
45458 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
45459 AMP2= FACT*PS*VTB**2*RES
45462 C=====================================================================
45463 C ************* FUNCTION SCALAR PRODUCTS *************************
45464 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
45465 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45466 IMPLICIT INTEGER(I-N)
45467 DIMENSION A(4),B(4)
45470 DUM=DUM-A(ID)*B(ID)
45476 C*********************************************************************
45479 C...Initializes supersymmetry: finds sparticle masses and
45480 C...branching ratios and stores this information.
45481 C...AUTHOR: STEPHEN MRENNA
45482 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
45486 C...Double precision and integer declarations.
45487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45488 IMPLICIT INTEGER(I-N)
45489 INTEGER PYK,PYCHGE,PYCOMP
45490 C...Parameter statement to help give large particle numbers.
45491 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45492 &KEXCIT=4000000,KDIMEN=5000000)
45494 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45495 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45496 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45497 COMMON/PYDAT4/CHAF(500,2)
45499 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45500 COMMON/PYINT4/MWID(500),WIDS(500,5)
45501 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45502 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45503 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45504 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45505 COMMON/PYHTRI/HHH(7)
45506 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45507 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
45508 &/PYMSSM/,/PYMSRV/,/PYSSMT/
45510 C...Local variables.
45511 DOUBLE PRECISION ALFA,BETA
45512 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
45513 INTEGER I,J,J1,I1,K1
45514 INTEGER KC,LKNT,IDLAM(400,3)
45515 DOUBLE PRECISION XLAM(0:400)
45516 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
45517 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
45518 DOUBLE PRECISION DELM,XMDIF
45519 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
45520 DOUBLE PRECISION ARG,SGNMU,R
45523 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
45526 &1000001,2000001,1000002,2000002,1000003,2000003,
45527 &1000004,2000004,1000005,2000005,1000006,2000006,
45528 &1000011,2000011,1000012,2000012,1000013,2000013,
45529 &1000014,2000014,1000015,2000015,1000016,2000016,
45530 &1000021,1000022,1000023,1000025,1000035,1000024,
45531 &1000037,1000039, 25, 35, 36, 37,
45532 & 6, 24, 45, 46,1000045, 9*0/
45535 C...Automatically read QNUMBERS, MASS, and DECAY tables
45536 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
45538 CALL PYSLHA(0,0,IFAIL)
45539 CALL PYSLHA(5,0,IFAIL)
45541 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
45543 C...Do nothing further if SUSY not requested
45545 IF(IMSSM.EQ.0) RETURN
45547 C...Save copy of MWID(KC) and MDCY(KC,1) values before
45548 C...they are set to zero for the LSP.
45555 MDCYSU(I)=MDCY(KC,1)
45559 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
45563 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
45565 MDCY(KC,1)=MDCYSU(I)
45569 C...First part of routine: set masses and couplings.
45571 C...Reset mixing values in sfermion sector to pure left/right.
45579 C...Add NMSSM states if NMSSM switched on, and change old names.
45580 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
45581 C... Switch on NMSSM
45582 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
45612 DO 123 KCT=100,MSTU(6)
45613 IF(KCHG(KCT,4).GT.100) KCN=KCT
45619 C... Set stable for now
45625 CHAF(KCN,1)='~chi_50'
45629 C...Read spectrum from SLHA file.
45630 IF (IMSSM.EQ.11) THEN
45631 CALL PYSLHA(1,0,IFAIL)
45634 C...Common couplings.
45639 COS2B=COS(2D0*BETA)
45645 C...Define sparticle masses for a general MSSM simulation.
45646 IF(IMSSM.EQ.1) THEN
45647 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
45649 KC=PYCOMP(KSUSY1+I)
45650 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
45651 KC=PYCOMP(KSUSY2+I)
45652 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
45653 KC=PYCOMP(KSUSY1+I+1)
45654 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
45655 KC=PYCOMP(KSUSY2+I+1)
45656 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
45658 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
45659 IF(XARG.LT.0D0) THEN
45660 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45661 & ' FROM THE SUM RULE. '
45662 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45668 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
45669 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
45670 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45671 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45673 IF(IMSS(8).EQ.1) THEN
45678 C...Alternatively derive masses from SUGRA relations.
45679 ELSEIF(IMSSM.EQ.2) THEN
45683 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
45692 C...Add in extra D-term contributions.
45693 IF(IMSS(7).EQ.1) THEN
45698 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45699 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
45700 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
45701 WRITE(MSTU(11),*) 'C DX = ',DX
45702 WRITE(MSTU(11),*) 'C DY = ',DY
45703 WRITE(MSTU(11),*) 'C DS = ',DS
45704 WRITE(MSTU(11),*) 'C '
45705 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
45706 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
45707 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45708 DQ2=DY/6D0-DX/3D0-DS/3D0
45709 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
45710 DD2=DY/3D0+DX-2D0*DS/3D0
45711 DL2=-DY/2D0+DX-2D0*DS/3D0
45712 DE2=DY-DX/3D0-DS/3D0
45713 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
45714 DHD2=-DY/2D0-2D0*DX/3D0+DS
45715 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
45717 DMA2 = 2D0*DMU2+DHU2+DHD2
45719 KC=PYCOMP(KSUSY1+I)
45720 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
45721 KC=PYCOMP(KSUSY2+I)
45722 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
45723 KC=PYCOMP(KSUSY1+I+1)
45724 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
45725 KC=PYCOMP(KSUSY2+I+1)
45726 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
45729 KC=PYCOMP(KSUSY1+I)
45730 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
45731 KC=PYCOMP(KSUSY2+I)
45732 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
45733 KC=PYCOMP(KSUSY1+I+1)
45734 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
45736 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
45737 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
45740 SGNMU=SIGN(1D0,RMSS(4))
45741 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
45742 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
45743 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
45744 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
45745 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
45746 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
45747 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
45748 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
45749 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
45750 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
45751 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
45752 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
45753 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
45756 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
45757 RMSS(6)=SQRT(RMSS(6)**2+DL2)
45758 RMSS(7)=SQRT(RMSS(7)**2+DE2)
45759 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45760 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45761 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45762 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45763 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45766 C...Fix the third generation sfermions.
45769 C...Fix the neutralino--chargino--gluino sector.
45772 C...Fix the Higgs sector.
45775 C...Choose the Gunion-Haber convention.
45779 C...Print information on mass parameters.
45780 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45781 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45782 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45783 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45784 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45785 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45786 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45787 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45788 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45789 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45790 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45792 IF(IMSS(20).EQ.1) THEN
45793 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45794 WRITE(MSTU(11),*) ' DEBUG MODE '
45795 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45796 & UMIX(2,1),UMIX(2,2)
45797 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45798 & UMIXI(2,1),UMIXI(2,2)
45799 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45800 & VMIX(2,1),VMIX(2,2)
45801 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45802 & VMIXI(2,1),VMIXI(2,2)
45803 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45804 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45805 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45806 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45807 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45808 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45809 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45810 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45811 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45812 WRITE(MSTU(11),*) ' BETA = ',BETA
45813 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45814 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45815 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45818 C...Set up the Higgs couplings - needed here since initialization
45819 C...in PYINRE did not yet occur when PYWIDT is called below.
45831 C2B=COSB**2-SINB**2
45832 C...tanb (used for H+)
45836 C...Coupling to d-type quarks
45837 PARU(161)=SINA/COSB
45838 C...Coupling to u-type quarks
45839 PARU(162)=-COSA/SINB
45840 C...Coupling to leptons
45841 PARU(163)=PARU(161)
45845 PARU(165)=PARU(164)
45848 C...Coupling to d-type quarks
45849 PARU(171)=-COSA/COSB
45850 C...Coupling to u-type quarks
45851 PARU(172)=-SINA/SINB
45852 C...Coupling to leptons
45853 PARU(173)=PARU(171)
45857 PARU(175)=PARU(174)
45859 IF(IMSS(4).GE.2) THEN
45860 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45862 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45863 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45864 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45865 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45866 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45870 IF(IMSS(4).GE.2) THEN
45871 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45873 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45874 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45875 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45876 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45879 IF(IMSS(4).GE.2) THEN
45880 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45882 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45883 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45884 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45885 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45888 IF(IMSS(4).GE.2) THEN
45889 PARU(178)=PARU(177)
45891 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45894 C...Coupling to d-type quarks
45896 C...Coupling to u-type quarks
45897 PARU(182)=1D0/PARU(181)
45898 C...Coupling to leptons
45899 PARU(183)=PARU(181)
45902 C...Coupling to Z h
45903 PARU(186)=COS(BE-AL)
45904 C...Coupling to Z H
45905 PARU(187)=SIN(BE-AL)
45911 C...Coupling to W h
45912 PARU(195)=COS(BE-AL)
45914 C...Tell that all Higgs couplings have been set.
45917 C...Set R-Violating couplings.
45918 C...Set lambda couplings to common value or "natural values".
45919 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45920 VIR3=1D0/(126D0)**3
45924 IF (IRI.NE.IRJ) THEN
45925 IF (IRI.LT.IRJ) THEN
45926 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45927 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45928 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45929 & PMAS(9+2*IRK,1)*VIR3)
45931 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45934 RVLAM(IRI,IRJ,IRK)=0D0
45940 C...Set lambda' couplings to common value or "natural values".
45941 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45942 VIR3=1D0/(126D0)**3
45946 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45947 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45948 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45949 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45954 C...Set lambda'' couplings to common value or "natural values".
45955 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45956 VIR3=1D0/(126D0)**3
45960 IF (IRJ.NE.IRK) THEN
45961 IF (IRJ.LT.IRK) THEN
45962 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45963 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45964 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45965 & PMAS(2*IRK-1,1)*VIR3)
45967 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45970 RVLAMB(IRI,IRJ,IRK) = 0D0
45977 C...Antisymmetrize couplings set by user
45978 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45982 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45983 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45984 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45986 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45987 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45988 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45995 C...Write spectrum to SLHA file
45996 IF (IMSS(23).NE.0) THEN
45998 CALL PYSLHA(3,0,IFAIL)
46001 C...Second part of routine: set decay modes and branching ratios.
46003 C...Allow chi10 -> gravitino + gamma or not.
46004 KC=PYCOMP(KSUSY1+39)
46005 IF( IMSS(11) .NE. 0 ) THEN
46006 PMAS(KC,1)=RMSS(21)/1D9
46009 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
46010 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
46012 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
46013 & ' ALLOWING SUSY LLE DECAYS'
46014 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
46015 & ' ALLOWING SUSY LQD DECAYS'
46016 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
46017 & ' ALLOWING SUSY UDD DECAYS'
46018 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
46019 & ' --- Warning: R-Violating couplings possibly',
46020 & ' incompatible with proton decay'
46026 C...Loop over sparticle and Higgs species.
46027 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
46028 C...Find the LSP or NLSP for a gravitino LSP
46033 IF(KF.EQ.1000039) GOTO 300
46035 IF(PMAS(KC,1).LT.PMLSP) THEN
46041 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
46043 IF (KF.EQ.0) GOTO 370
46047 C...Check if there are any decays listed for this sparticle
46049 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
46051 CALL PYSLHA(2,KF,IFAIL)
46052 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
46053 ELSEIF (I.GE.37) THEN
46057 C...Sfermion decays.
46059 C...First check to see if sneutrino is lighter than chi10.
46060 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
46061 & PMAS(KC,1).LT.PMCHI1) THEN
46063 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
46067 ELSEIF(I.EQ.25) THEN
46068 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
46069 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
46071 C...Neutralino decays.
46072 ELSEIF(I.GE.26.AND.I.LE.29) THEN
46073 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
46074 C...chi10 stable or chi10 -> gravitino + gamma.
46075 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
46081 C...Chargino decays.
46082 ELSEIF(I.GE.30.AND.I.LE.31) THEN
46083 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
46085 C...Gravitino is stable.
46086 ELSEIF(I.EQ.32) THEN
46091 ELSEIF(I.GE.33.AND.I.LE.36) THEN
46092 C...Calculate decays to non-SUSY particles.
46093 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
46098 DO 330 I1=1,MDCY(KC,3)
46100 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
46101 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
46103 XLAM(0)=XLAM(0)+XLAM(I1)
46105 IDLAM(I1,J1)=KFDP(K1,J1)
46109 C...Add the decays to SUSY particles.
46110 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
46112 C...Zero the branching ratios for use in loop mode
46113 C...thanks to K. Matchev (FNAL)
46114 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46118 C...Set stable particles.
46126 C...Store branching ratios in the standard tables.
46128 IDC=MDCY(KC,2)+MDCY(KC,3)-1
46134 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
46135 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
46136 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
46137 BRAT(IDC)=XLAM(IL)/XLAM(0)
46139 IF(MDME(IDC,1).GE.1) THEN
46140 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
46141 & PMAS(PYCOMP(KFDP(IDC,2)),1)
46142 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
46143 & PMAS(PYCOMP(KFDP(IDC,3)),1)
46146 IF(XMDIF.GE.0D0) THEN
46147 DELM=MIN(DELM,XMDIF)
46149 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
46150 WRITE(MSTU(11),*) ' KF = ',KF
46151 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
46155 ELSEIF(IDC.EQ.IDCSV) THEN
46156 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
46157 & 'channel not recognized:'
46158 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
46165 C...Store width, cutoff and lifetime.
46167 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
46168 PMAS(KC,3)=PMAS(KC,2)*10D0
46170 PMAS(KC,3)=0.95D0*DELM
46172 IF(PMAS(KC,2).NE.0D0) THEN
46173 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
46175 C...Write decays to SLHA file
46176 IF (IMSS(24).NE.0) THEN
46178 CALL PYSLHA(4,KF,IFAIL)
46186 C*********************************************************************
46189 C...Read/write spectrum or decay data from SLHA standard file(s).
46191 C...DECAY TABLE writeout by Nils-Erik Bomark (2010)
46193 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
46194 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
46195 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
46196 C... (KFORIG=0 : read all decay tables)
46197 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
46198 C...MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24)
46199 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
46200 C... (KFORIG=0 : read all MASS entries)
46202 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
46204 C...Double precision and integer declarations.
46205 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46206 IMPLICIT INTEGER(I-N)
46207 INTEGER PYK,PYCHGE,PYCOMP
46208 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46209 &KEXCIT=4000000,KDIMEN=5000000)
46211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46212 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46213 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
46214 COMMON/PYDAT4/CHAF(500,2)
46216 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46217 CHARACTER*40 ISAVER,VISAJE
46218 COMMON/PYINT4/MWID(500),WIDS(500,5)
46219 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
46221 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46222 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46223 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46224 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
46225 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
46227 C...Local arrays, character variables and data.
46228 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46229 & AU(3,3),AD(3,3),AE(3,3)
46230 COMMON/PYLH3C/CPRO(2),CVER(2)
46231 C...The common block of new states (QNUMBERS / PARTICLE)
46232 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
46233 C...- NQNUM : Number of QNUMBERS blocks that have been read in
46234 C...- KQNUM(I,0) : KF of new state
46235 C...- KQNUM(I,1) : 3 times electric charge
46236 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
46237 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
46238 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
46239 C...- KQNUM(I,5:9) : space available for further quantum numbers
46240 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
46241 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
46242 C...MMOD: flags to set for each block read in.
46243 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
46244 C...MSPC: Flags to set for each block read in.
46245 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
46246 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
46247 C...11: AD 12: AE 13: YU 14: YD 15: YE
46248 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
46249 CHARACTER CPRO*12,CVER*12,CHNLIN*6
46250 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
46251 CHARACTER CHINL*120,CHKF*9,CHTMP*16
46254 C...Date of last Change
46255 PARAMETER (DOC='10 Jun 2010')
46256 C...Local arrays and initial values
46257 DIMENSION IDC(5),KFSUSY(50)
46266 &1000001,1000002,1000003,1000004,1000005,1000006,
46267 &2000001,2000002,2000003,2000004,2000005,2000006,
46268 &1000011,1000012,1000013,1000014,1000015,1000016,
46269 &2000011,2000012,2000013,2000014,2000015,2000016,
46270 &1000021,1000022,1000023,1000025,1000035,1000024,
46271 &1000037,1000039, 25, 35, 36, 37,
46272 & 6, 24, 45, 46,1000045, 9*0/
46274 RMFUN(IP)=PMAS(PYCOMP(IP),1)
46276 C...Shorthand for spectrum and decay table unit numbers
46280 C...Default for LHEF input: read header information
46281 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
46282 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
46283 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
46284 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
46287 IF (NHELLO.EQ.0) THEN
46288 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
46289 WRITE(MSTU(11),5000) DOC
46294 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
46297 IF (MUPDA.EQ.2) LFN=IMSS22
46298 IF (MUPDA.EQ.3) LFN=IMSS(23)
46299 IF (MUPDA.EQ.4) LFN=IMSS(24)
46300 C...Flag that we have not yet found whatever we were asked to find.
46302 C...Flag that we are skipping until <slha> tag found (if LHEF)
46304 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
46306 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46308 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
46312 C...If reading LHEF header, start by rewinding file
46313 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
46315 C...If told to read spectrum, first zero all previous information.
46316 IF (MUPDA.EQ.1) THEN
46317 C...Zero all block read flags
46322 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
46324 KC=PYCOMP(KFSUSY(ISUSY))
46327 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
46335 IF (J.LE.2.AND.L.LE.2) THEN
46342 C...Zero signed masses.
46344 IF (J.LE.2) SMW(J)=0D0
46347 C...If reading decays, reset PYTHIA decay counters.
46348 ELSEIF (MUPDA.EQ.2) THEN
46349 C...Check if DECAY for this KF already read
46350 IF (KFORIG.NE.0) THEN
46351 DO 140 IDEC=1,NDECAY
46352 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
46361 DO 150 KC=1,MSTU(6)
46362 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
46363 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
46365 ELSEIF (MUPDA.EQ.5) THEN
46366 C...Zero block read flags
46373 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
46374 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
46375 C...Initialize program and version strings
46376 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
46381 C...Initialize read loop
46385 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
46387 READ(LFN,'(A120)',END=400) CHINL
46388 C...Count which line number we're at.
46390 WRITE(CHNLIN,'(I6)') NLINE
46392 C...Skip comment and empty lines without processing.
46393 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
46395 C...We assume all upper case below. Rewrite CHINL to all upper case.
46399 IF (CHINL(INL:INL).NE.'#') THEN
46401 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
46403 C...Extra safety. Chek for sensible input on line
46404 IF (IGOOD.EQ.0) THEN
46406 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
46409 IF (INL.LT.120) GOTO 180
46411 IF (IGOOD.EQ.0) GOTO 170
46413 C...If reading from LHEF file, skip until <slha> begin tag found
46414 IF (ISKIP.NE.0) THEN
46416 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
46418 IF (ISKIP.NE.0) GOTO 170
46421 C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
46423 IF (CHINL(I1:I1+5).EQ.'</SLHA'
46424 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
46425 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
46431 C...Check for BLOCK begin statement (spectrum).
46432 IF (CHINL(1:5).EQ.'BLOCK') THEN
46434 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
46435 C...Check if another of this type of block was already read.
46436 C...(logarithmic interpolation not yet implemented, so duplicates always
46438 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
46439 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
46440 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
46441 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
46442 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
46443 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
46444 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
46445 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
46446 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
46447 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
46448 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
46449 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
46450 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
46451 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
46452 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
46453 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
46454 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
46455 C...Check for new particles
46456 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
46458 MSPC(19)=MSPC(19)+1
46460 READ(CHBLCK(9:60),*) KFQ
46463 IF (KQNUM(MQ,0).EQ.KFQ) THEN
46468 IF (NHELLO.EQ.0) THEN
46469 WRITE(MSTU(11),5000) DOC
46472 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46473 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
46477 MSPC(19)=MSPC(19)+1
46479 C...Only read in new codes (also OK to overwrite if KF > 3000000)
46480 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
46482 DO 230 KCT=100,MSTU(6)
46483 IF(KCHG(KCT,4).GT.100) KCQ=KCT
46489 C...First write PDG code as name
46491 WRITE(CHTMP,'(A)') CHTMP(2:10)
46492 C...Then look for real name
46495 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
46497 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
46500 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
46501 IF (IEND.LT.59) THEN
46502 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
46503 IF (CHDUM.NE.' ') CHTMP=CHDUM
46505 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
46507 C...Set stable for now
46515 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
46516 & CHAF(KCQ,1), '. Entry ignored.'
46520 C...Finalize this line and read next.
46522 C...Check for DECAY begin statement (decays).
46523 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
46527 C...Read KF code and WIDTH
46529 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
46534 C...If this is not the KF we're looking for...
46535 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
46536 C...Set block skip flag and read next line.
46540 C...Check whether decay table for this particle already read in
46541 DO 280 IDECAY=1,NDECAY
46542 IF (KFDEC(IDECAY).EQ.KF) THEN
46543 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
46544 & ' * (PYSLHA:) Ignoring DECAY table ',
46545 & 'for KF =',KF,' on line ',CHNLIN,
46553 C...Determine PYTHIA KC code of particle
46559 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
46563 IF (KCREP.NE.0) THEN
46564 C...Particle is already known. Do not overwrite low-mass SM particles,
46565 C...since this could give problems at hadronization / hadron decay stage.
46566 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
46567 C...Set block skip flag and read next line
46568 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46569 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
46570 & KF, ' (SLHA read-in not allowed)'
46573 ELSEIF (IABS(KF).EQ.6.OR.IABS(KF).EQ.23.OR.IABS(KF).EQ.24)
46575 C...Set block skip flag and read next line
46576 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46577 & ' * (PYSLHA:) Allowing DECAY table for KF =',
46578 & KF, ' but this is NOT recommended.'
46581 C... Add new particle. Actually, this should not happen.
46582 C... New particles should be added already when reading the spectrum
46583 C... information, so go under previously stable category.
46588 IF (WIDTH.LE.0D0) THEN
46589 C...Stable (i.e. LSP)
46590 WRITE(MSTU(11),'(A,I9,A,A)')
46591 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
46592 & KF,', ',CHAF(KCREP,1)(1:16)
46593 IF (WIDTH.LT.0D0) THEN
46594 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
46601 C...Ignore any decay lines that may be present for this KF
46608 C...Finalize and start reading in decay modes.
46610 ELSEIF (MOD(MERR,10).GE.6) THEN
46611 C...If ignore block flag set, skip directly to next line.
46616 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
46617 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
46619 READ(CHINL,*) INDX, IVAL
46620 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
46621 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
46622 IF (INDX.EQ.3) KCHG(KCQ,2)=0
46623 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
46624 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
46625 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
46626 IF (INDX.EQ.4) THEN
46628 IF (IVAL.EQ.1) THEN
46630 IF (CHTMP.EQ.' ') THEN
46631 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
46632 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
46636 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
46637 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
46638 CHTMP(ILAST:ILAST)='-'
46640 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
46649 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
46650 C...MASS: Mass spectrum
46651 IF (CHBLCK(1:4).EQ.'MASS') THEN
46652 READ(CHINL,*) KF, VAL
46655 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
46656 C...Read in masses for almost anything
46660 C...Don't read in masses for special code particles
46661 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
46662 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46663 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46664 & KF, ' (KF reserved by PYTHIA)'
46667 C...Be careful with light SM particles / hadrons
46668 IF (PMAS(KC,1).LE.20D0) THEN
46669 IF (IABS(KF).LE.22) THEN
46670 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46671 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46672 & KF, ' (SLHA read-in not allowed)'
46675 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
46676 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46677 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46678 & KF, ' (SLHA read-in not allowed)'
46683 PMAS(KC,1) = ABS(VAL)
46684 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
46685 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46686 & ' * (PYSLHA:) Reading MASS entry for KF =',
46687 & KF, ', pole mass =', VAL
46690 C...Check Z, W and top masses
46691 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
46693 WRITE(CHTMP,8500) PMAS(PYCOMP(23),1)
46694 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
46697 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
46699 WRITE(CHTMP,8500) PMAS(PYCOMP(24),1)
46700 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
46703 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
46705 WRITE(CHTMP,8500) PMAS(PYCOMP(6),1)
46706 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
46710 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
46711 IF (KF.EQ.1000022) SMZ(1)=VAL
46712 IF (KF.EQ.1000023) SMZ(2)=VAL
46713 IF (KF.EQ.1000025) SMZ(3)=VAL
46714 IF (KF.EQ.1000035) SMZ(4)=VAL
46715 IF (KF.EQ.1000024) SMW(1)=VAL
46716 IF (KF.EQ.1000037) SMW(2)=VAL
46718 ELSEIF (MUPDA.EQ.5) THEN
46721 C... MODSEL: Model selection and global switches
46722 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
46723 READ(CHINL,*) INDX, IVAL
46724 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46725 IF (IMSS(1).EQ.0) IMSS(1)=11
46728 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
46729 C... Switch on NMSSM
46730 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
46731 IMSS(13)=MAX(1,IMSS(13))
46732 C... Add NMSSM states if not already done
46762 DO 310 KCT=100,MSTU(6)
46763 IF(KCHG(KCT,4).GT.100) KCN=KCT
46769 C... Set stable for now
46775 CHAF(KCN,1)='~chi_50'
46781 ELSEIF (MUPDA.EQ.5) THEN
46782 C...If MUPDA = 5, skip all except MASS, return if MODSEL
46784 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46785 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46786 C...Don't print a warning for QNUMBERS when reading spectrum
46788 C...MINPAR: Minimal model parameters
46789 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46790 READ(CHINL,*) INDX, VAL
46791 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46797 IF (MMOD(3).NE.0) THEN
46799 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46803 IF (INDX.EQ.3) RMSS(5)=VAL
46804 C...EXTPAR: non-minimal model parameters.
46805 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46806 IF (MMOD(1).NE.0) THEN
46807 READ(CHINL,*) INDX, VAL
46808 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46816 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46820 IF (INDX.EQ.25) RMSS(5)=VAL
46821 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46822 READ(CHINL,*) INDX, VAL
46823 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46825 ELSEIF (INDX.EQ.4) THEN
46826 PMAS(PYCOMP(23),1)=VAL
46827 ELSEIF (INDX.EQ.6) THEN
46828 PMAS(PYCOMP(6),1)=VAL
46830 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46831 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46832 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46834 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46836 IF (CHBLCK(5:6).EQ.'IM') IM=1
46837 320 READ(CHINL,*) INDX1, INDX2, VAL
46838 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46839 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46840 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46842 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46843 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46844 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46846 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46847 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46848 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46850 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46851 $ .CHBLCK(1:4).EQ.'STAU') THEN
46852 IF (CHBLCK(1:4).EQ.'STOP') THEN
46855 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46858 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46862 C...Set SFMIX element
46863 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46864 MSPC(ISPC)=MSPC(ISPC)+1
46866 C...Running parameters
46867 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46868 READ(CHBLCK(8:25),*,ERR=620) Q
46869 READ(CHINL,*) INDX, VAL
46871 IF (INDX.EQ.1) THEN
46877 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46878 READ(CHINL,*,ERR=630) VAL
46880 MSPC(17)=MSPC(17)+1
46881 C...Higgs parameters set manually or with FeynHiggs.
46882 IMSS(4)=MAX(2,IMSS(4))
46883 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46884 & .CHBLCK(1:2).EQ.'AE') THEN
46885 READ(CHBLCK(9:26),*,ERR=620) Q
46886 READ(CHINL,*) INDX1, INDX2, VAL
46887 IF (CHBLCK(2:2).EQ.'U') THEN
46888 AU(INDX1,INDX2)=VAL
46889 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46890 MSPC(11)=MSPC(11)+1
46891 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46892 AD(INDX1,INDX2)=VAL
46893 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46894 MSPC(10)=MSPC(10)+1
46895 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46896 AE(INDX1,INDX2)=VAL
46897 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46898 MSPC(12)=MSPC(12)+1
46902 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46903 IF (MSPC(18).EQ.0) THEN
46904 READ(CHBLCK(9:25),*,ERR=620) Q
46907 READ(CHINL,*) INDX, VAL
46909 MSPC(18)=MSPC(18)+1
46910 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46912 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46913 & .CHBLCK(1:2).EQ.'YE') THEN
46915 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46916 READ(CHINL(1:6),*) INDX
46920 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46921 C...Don't read index
46922 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46926 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46927 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46929 C... Set unrecognized block flag.
46934 C...Read in decay information
46935 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46936 C...Read new decay chanel
46937 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46939 C...Read in branching ratio and number of daughters for this mode.
46940 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46941 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46943 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46944 & '(PYSLHA:) Decay data arrays full by KF = '
46946 C...If first decay channel, set decays start point in decay table
46947 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46948 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46949 & '* (PYSLHA:) Reading DECAY table for '//
46950 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46951 C...Set particle parameters (mass set when reading BLOCK MASS above)
46953 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46954 WRITE(MSTU(11),'(1x,A)')
46955 & '* Note: the Pythia gg->h/H/A cross section'//
46956 & ' is proportional to the h/H/A->gg width'
46957 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46958 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46959 WRITE(MSTU(11),'(1x,A,A16)')
46960 & '* Warning: will use DECAY table (fixed-width,'//
46961 & ' flat PS) for ',CHAF(KC,1)(1:16)
46964 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46969 C...Add to list of DECAY blocks currently read
46975 C... Count up number of decay modes for this particle
46976 MDCY(KC,3)=MDCY(KC,3)+1
46977 C... Read in decay daughters.
46978 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46979 C... Flip sign if reading antiparticle decays (if antipartner exists)
46981 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46982 & IDC(IDA)=MPSIGN*IDC(IDA)
46984 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46986 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46987 BRSUM=BRSUM+ABS(BRAT(NDC))
46988 BRAT(NDC)=ABS(BRAT(NDC))
46991 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46993 IDC(IDA)=IDC(IDA+1)
46998 IF (IFLIP.GT.0) GOTO 350
46999 C...Treat as ordinary decay, no fancy stuff.
47002 IF (IDA.LE.NDA) THEN
47003 KFDP(NDC,IDA)=IDC(IDA)
47008 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
47009 C & (KFDP(NDC,J),J=1,NDA)
47011 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
47016 ELSEIF(CHINL(1:1).EQ.'+') THEN
47018 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
47025 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
47026 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
47029 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
47030 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
47031 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
47032 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
47033 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
47034 & //CHBLCK(1:INL)//'... on line'//CHNLIN
47035 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
47036 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
47037 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
47038 & //'... on line'//CHNLIN
47039 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
47040 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
47041 & /CHBLCK(1:INL)//'... on line'//CHNLIN
47042 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
47045 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
47046 & CHTMP(1:9)//' on line'//CHNLIN
47048 C...Iterate read loop
47051 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
47052 & ', ignoring subsequent lines.'
47053 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
47056 C...End of read loop
47058 C...Set flag that KC codes have been rearranged.
47062 C...Perform possible tests that new information is consistent.
47063 IF (MUPDA.EQ.1) THEN
47069 C...Don't complain about right-handed neutrinos
47070 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
47072 C...Only check gravitino in GMSB scenarios
47073 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
47075 IF (PMAS(KC,1).EQ.0D0) THEN
47078 & ,'(PYSLHA:) No mass information found for KF ='
47082 C...Check mixing matrices (MSSM only)
47083 IF (IMSS(13).EQ.0) THEN
47084 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
47085 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
47086 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
47087 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
47088 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
47089 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
47090 IF (MSPC(5).NE.4) CALL PYERRM(9
47091 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
47092 IF (MSPC(6).NE.4) CALL PYERRM(9
47093 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
47094 IF (MSPC(7).NE.4) CALL PYERRM(9
47095 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
47096 IF (MSPC(8).LT.1) CALL PYERRM(9
47097 & ,'(PYSLHA:) Too few elements in HMIX')
47098 IF (MSPC(10).EQ.0) CALL PYERRM(9
47099 & ,'(PYSLHA:) Missing A_b trilinear coupling')
47100 IF (MSPC(11).EQ.0) CALL PYERRM(9
47101 & ,'(PYSLHA:) Missing A_t trilinear coupling')
47102 IF (MSPC(12).EQ.0) CALL PYERRM(9
47103 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
47104 IF (MSPC(17).LT.1) CALL PYERRM(9
47105 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
47107 C...Check wavefunction normalizations.
47110 IF (MSPC(ISPC).EQ.4) THEN
47112 IF (ISPC.EQ.7) KFSM=15
47113 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
47115 IF (ABS(1D0-CHECK).GT.1D-3) THEN
47118 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
47121 C...Bug fix 30/09 2008: PS
47122 C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
47123 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
47124 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
47125 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
47129 C...Neutralinos + charginos
47138 CN1=CN1+ZMIX(J,L)**2
47139 CN2=CN2+ZMIX(L,J)**2
47140 IF (J.LE.2.AND.L.LE.2) THEN
47141 CU1=CU1+UMIX(J,L)**2
47142 CU2=CU2+UMIX(L,J)**2
47143 CV1=CV1+VMIX(J,L)**2
47144 CV2=CV2+VMIX(L,J)**2
47147 C...NMIX normalization
47148 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
47149 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
47151 & '(PYSLHA:) NMIX: Inconsistent normalization.')
47152 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
47154 C...UMIX, VMIX normalizations
47155 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
47157 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
47159 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
47160 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
47163 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
47165 & '(PYSLHA:) VMIX: Inconsistent normalization.')
47166 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
47172 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
47173 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
47174 & '* (PYSLHA:) No spectrum inconsistencies were found.'
47176 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
47177 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
47178 & ,' Warning: one or more (serious)'//
47179 & ' inconsistencies were found in the spectrum !'
47180 & ,' Read the error messages above and check your'//
47183 C...Increase precision in Higgs sector using FeynHiggs
47184 IF (IMSS(4).EQ.3) THEN
47185 C...FeynHiggs needs MSOFT.
47187 IF (MSPC(18).EQ.0) THEN
47188 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
47189 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
47190 & ' Cannot call FeynHiggs.'
47193 WRITE(MSTU(11),'(1x,/1x,A/)')
47194 & '* (PYSLHA:) Now calling FeynHiggs.'
47196 IF (IERR.NE.0) IMSS(4)=2
47199 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
47201 IF (KFORIG.NE.0) IBEG=NDECAY
47202 DO 490 IDECAY=IBEG,NDECAY
47205 WRITE(CHKF,8300) KF
47206 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
47207 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
47208 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
47209 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
47213 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47214 IF(MDME(IDA,2).GT.80) GOTO 460
47216 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
47220 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
47222 ELSEIF(PYCOMP(KP).EQ.0) THEN
47227 PMS=PMS-PMAS(KPC,1)
47228 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
47232 IF(KQ.NE.0) MERR=MAX(2,MERR)
47233 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
47235 IF(MERR.EQ.3) CALL PYERRM(17,
47236 & '(PYSLHA:) Unknown particle code in decay of KF ='
47238 IF(MERR.EQ.2) CALL PYERRM(17,
47239 & '(PYSLHA:) Charge not conserved in decay of KF ='
47241 IF(MERR.EQ.1) CALL PYERRM(7,
47242 & '(PYSLHA:) Kinematically unallowed decay of KF ='
47244 BRSUM=BRSUM+BRAT(IDA)
47245 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
47247 C...Check branching ratio sum.
47248 IF (BROPN.LE.0D0) THEN
47249 C...If zero, set stable.
47250 WRITE(CHTMP,8500) BROPN
47252 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
47253 & CHTMP(9:16)//'. Changed to stable.')
47256 C...If BR's > 1, rescale.
47257 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
47258 WRITE(CHTMP,8500) BRSUM
47259 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
47260 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
47261 & ' ; sum was'//CHTMP(9:16)//'.')
47263 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47264 IF(MDME(IDA,2).GT.80) GOTO 470
47265 BRAT(IDA)=FAC*BRAT(IDA)
47267 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
47268 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
47269 WRITE(CHTMP,8500) BRSUM
47270 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
47271 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
47272 & CHTMP(9:16)//'. Dummy mode will be inserted.')
47273 C...Move table and insert dummy mode
47274 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47276 BRAT(NDC)=BRAT(IDA)
47277 KFDP(NDC,1)=KFDP(IDA,1)
47278 KFDP(NDC,2)=KFDP(IDA,2)
47279 KFDP(NDC,3)=KFDP(IDA,3)
47280 KFDP(NDC,4)=KFDP(IDA,4)
47281 KFDP(NDC,5)=KFDP(IDA,5)
47282 MDME(NDC,1)=MDME(IDA,1)
47285 BRAT(NDC)=1D0-BRSUM
47294 MDCY(KC,3)=MDCY(KC,3)+1
47295 MDCY(KC,2)=NDC-MDCY(KC,3)+1
47301 C...WRITE SPECTRUM ON SLHA FILE
47302 ELSEIF(MUPDA.EQ.3) THEN
47303 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
47304 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
47309 PARMIN(4)=SIGN(1D0,RMSS(4))
47313 WRITE(LFN,7000) 'SLHA MSSM spectrum'
47314 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
47316 WRITE(LFN,7010) 'MODSEL', 'Model selection'
47317 WRITE(LFN,7110) 1, MODSEL(1)
47318 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
47319 IF (MODSEL(1).EQ.1) THEN
47320 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
47321 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
47322 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
47323 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
47324 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
47325 ELSEIF(MODSEL(2).EQ.2) THEN
47326 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
47327 WRITE(LFN,7210) 2, PARMIN(2), 'M'
47328 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
47329 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
47330 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
47331 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
47333 WRITE(LFN,7000) ' '
47334 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
47338 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
47340 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
47341 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
47342 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
47343 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
47344 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
47345 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
47346 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
47348 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
47352 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
47353 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
47354 WRITE(LFN,7210) 1, RMSS(4),'mu'
47355 WRITE(LFN,7010) 'ALPHA',' '
47356 C WRITE(LFN,7210) 1, RMSS(18), 'alpha'
47357 WRITE(LFN,7200) RMSS(18), 'alpha'
47358 WRITE(LFN,7020) 'AU',RMSUSY
47359 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
47360 WRITE(LFN,7020) 'AD',RMSUSY
47361 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
47362 WRITE(LFN,7020) 'AE',RMSUSY
47363 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
47364 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
47365 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
47366 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
47367 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
47368 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
47369 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
47370 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
47371 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
47372 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
47373 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
47374 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
47375 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
47376 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
47377 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
47378 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
47379 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
47382 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
47385 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
47388 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
47391 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
47394 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
47397 WRITE(LFN,7010) 'SPINFO'
47398 IF (IMSS(1).EQ.2) THEN
47401 ELSEIF (IMSS(1).EQ.12) THEN
47404 CVER(1)=ISAVER(1:12)
47406 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
47407 WRITE(LFN,7310) 2, CVER(1), 'Version number'
47410 C...Print user information about spectrum
47411 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
47412 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
47413 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
47414 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
47415 IF (MUPDA.EQ.1) THEN
47416 WRITE(MSTU(11),5020) LFN
47418 WRITE(MSTU(11),5010) LFN
47421 WRITE(MSTU(11),5400)
47422 WRITE(MSTU(11),5500) 'Pole masses'
47423 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
47424 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
47425 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
47426 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
47427 IF (IMSS(13).EQ.0) THEN
47428 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
47429 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
47430 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
47431 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
47432 & CHAF(37,1), ' ', ' ',' ',' ',
47433 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
47434 ELSEIF (IMSS(13).EQ.1) THEN
47443 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
47444 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
47445 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
47446 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
47447 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
47448 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
47449 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
47450 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
47451 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
47454 WRITE(MSTU(11),5400)
47455 WRITE(MSTU(11),5500) 'Mixing structure'
47456 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47457 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47458 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47459 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47460 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47461 & ),(SFMIX(15,J),J=3,4)
47462 WRITE(MSTU(11),5400)
47463 WRITE(MSTU(11),5500) 'Couplings'
47464 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
47465 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
47466 WRITE(MSTU(11),5400)
47467 WRITE(MSTU(11),6500)
47469 C...DECAY TABLES writeout
47470 C...Write decay information by Nils-Erik Bomark 3/29/2010
47471 ELSEIF (MUPDA.EQ.4) THEN
47476 WRITE(LFN,7000) ' PDG Width'
47477 WRITE(LFN,7500) KF,PMAS(KC,2), CHAF(KC,1)
47479 & ' BR NDA ID1 ID2 ID3'
47480 DO 575 I=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47483 IF (KFDP(I,J).NE.0) NDA = NDA+1
47486 & WRITE(LFN,7512) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47487 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47488 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47490 & WRITE(LFN,7513) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47491 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47492 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47494 & WRITE(LFN,7514) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47495 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47496 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47498 & WRITE(LFN,7515) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47499 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47500 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47503 C....End of DECAY TABLES writeout
47507 C...Only rewind when reading
47508 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
47512 C...Serious error catching
47513 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
47514 write(*,*) CHINL(1:80)
47516 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
47517 WRITE(*,*) CHINL(1:72)
47519 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
47520 WRITE(*,*) CHINL(1:80)
47522 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
47523 WRITE(*,*) CHINL(1:80)
47524 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
47526 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
47527 WRITE(*,*) CHINL(1:80)
47533 C...Formats for user information printout.
47534 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.14: SUSY/BSM SPECTRUM '
47535 & ,'INTERFACE',1x,17('*')/1x,'*',1x
47536 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
47537 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
47538 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
47539 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
47540 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
47541 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
47542 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47543 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47544 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
47545 & ,'----------------')
47546 5400 FORMAT(1x,'*',1x,A)
47547 5500 FORMAT(1x,'*',1x,A,':')
47548 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47549 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47550 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
47551 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
47552 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
47553 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
47554 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
47555 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
47556 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47557 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47558 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47559 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
47560 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47561 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47562 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47563 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47564 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47565 & ,1x,F6.3,1x),'|')
47566 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47567 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47568 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47569 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47570 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47571 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47572 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47573 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47574 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47575 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47576 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47577 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47578 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
47579 & ,'A_tau = ',F8.2)
47580 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
47582 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
47584 C...Format to use for comments
47585 7000 FORMAT('# ',A)
47586 C...Format to use for block statements
47587 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
47588 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
47590 7110 FORMAT(1x,I4,1x,I4,3x,'#')
47591 C...Non-Indexed Double
47592 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
47594 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
47595 C...Long Indexed Double (PDG + double)
47596 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
47597 C...Indexed Char(12)
47598 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
47600 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
47602 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
47603 C...Write Decay Table
47604 7500 FORMAT('Decay',1x,I9,1x,1P,E16.8,0P,3x,'#',1x,A)
47605 7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
47606 7512 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,2(1x,I9),13x,
47607 & '#',1x,'BR(',A10,1x,'->',2(1x,A10),')')
47608 7513 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,3(1x,I9),3x,
47609 & '#',1x,'BR(',A10,1x,'->',3(1x,A10),')')
47610 7514 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,4(1x,I9),3x,
47611 & '#',1x,'BR(',A10,1x,'->',4(1x,A10),')')
47612 7515 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,5(1x,I9),3x,
47613 & '#',1x,'BR(',A10,1x,'->',5(1x,A10),')')
47618 C*********************************************************************
47621 C...Uses approximate analytical formulae to determine the full set of
47622 C...MSSM parameters from SUGRA input.
47623 C...See M. Drees and S.P. Martin, hep-ph/9504124
47627 C...Double precision and integer declarations.
47628 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47629 IMPLICIT INTEGER(I-N)
47630 INTEGER PYK,PYCHGE,PYCOMP
47631 C...Parameter statement to help give large particle numbers.
47632 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47633 &KEXCIT=4000000,KDIMEN=5000000)
47635 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47636 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47637 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47638 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
47640 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
47641 &' not intended for serious physics studies'
47654 C...Temporary sign change for AT. Others unchanged.
47658 SINB=TANB/SQRT(TANB**2+1D0)
47661 DTERM=XMZ2*COS(2D0*BETA)
47662 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
47663 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
47666 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
47667 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
47668 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
47669 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
47671 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
47672 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
47673 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
47674 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
47676 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
47677 IF(XARG.LT.0D0) THEN
47678 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
47679 & ' FROM THE SUM RULE. '
47680 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47686 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
47687 PMAS(PYCOMP(KSUSY2+I),1)=XMER
47688 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
47689 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
47691 RMT=PYMRUN(6,PMAS(6,1)**2)
47692 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
47693 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
47694 RMB=PYMRUN(5,PMAS(6,1)**2)
47695 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
47696 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
47697 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
47698 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
47701 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
47702 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
47703 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
47704 XMU=SIGN(SQRT(XMU2),RMSS(4))
47706 IF(XMA2.GT.0D0) THEN
47707 RMSS(19)=SQRT(XMA2)
47709 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
47712 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
47713 IF(ARG.GT.0D0) THEN
47716 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
47719 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
47720 IF(ARG.GT.0D0) THEN
47723 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
47726 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
47727 IF(ARG.GT.0D0) THEN
47730 RMSS(10)=-SQRT(-ARG)
47732 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
47733 IF(ARG.GT.0D0) THEN
47736 RMSS(12)=-SQRT(-ARG)
47738 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
47739 IF(ARG.GT.0D0) THEN
47742 RMSS(11)=-SQRT(-ARG)
47748 C*********************************************************************
47751 C...Interface to ISASUSY version 7.71.
47752 C...Warning: this interface should not be used with earlier versions
47753 C...of ISASUSY, since common block incompatibilities may then arise.
47754 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
47755 C...Then converts to Gunion-Haber conventions.
47758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47760 INTEGER PYK,PYCHGE,PYCOMP
47761 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47762 &KEXCIT=4000000,KDIMEN=5000000)
47766 PARAMETER (DOC='01 May 2006')
47768 C...ISASUGRA Input:
47769 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
47770 C...XISAIN contains the MSSMi inputs in natural order.
47771 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
47773 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
47775 C...ISASUGRA Output
47776 CHARACTER*40 ISAVER,VISAJE
47778 COMMON /SSPAR/ SUPER(72)
47779 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
47780 $FBGUT,FTAGUT,FNGUT
47781 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
47782 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
47783 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
47784 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
47785 $VUMT,VDMT,ASMTP,ASMSS,M3Q
47786 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
47787 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
47788 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
47789 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
47791 SAVE /SUGMG/,/SSPAR/
47792 C SUPER: Filled by ISASUGRA.
47793 C SUPER(1) = mass of ~g
47794 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
47795 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
47796 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
47798 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
47799 C SUPER(29) = Higgsino mass = - mu
47800 C SUPER(30) = ratio v2/v1 of vev's
47801 C SUPER(31:34) = Signed neutralino masses
47802 C SUPER(35:50) = Neutralino mixing matrix
47803 C SUPER(51:52) = Signed chargino masses
47804 C SUPER(53:54) = Chargino left, right mixing angles
47805 C SUPER(55:58) = mass of h0, H0, A0, H+
47806 C SUPER(59) = Higgs mixing angle alpha
47807 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
47808 C SUPER(66) = Gravitino mass
47809 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
47810 C SUPER(70) = b-Yukawa at mA scale (not used)
47811 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47812 C GSS: Filled by ISASUGRA
47813 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47814 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47815 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47816 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47817 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47818 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47819 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47820 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47821 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47822 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47823 C GSS(31) = log(vuq)
47824 C MSS: Filled by ISASUGRA
47825 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47826 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47827 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47828 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47829 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47830 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47831 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47832 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47833 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47834 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47835 C MSS(31) = ha0 MSS(32) = h+
47836 C Unification, filled by ISASUGRA if applicable.
47837 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47839 C...SPYTHIA Input/Output
47841 DOUBLE PRECISION RMSS
47842 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47843 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47844 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47845 C...SLHA Input/Output
47846 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47847 & AU(3,3),AD(3,3),AE(3,3)
47848 C...PYTHIA common blocks
47849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47850 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47851 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47853 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47854 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47857 CHARACTER*20 CHMOD(5)
47860 COMMON /SUGNU/ XNUSUG(18)
47864 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47865 & 'truly unified SUGRA', 'non-minimal GMSB'/
47867 C...Start by checking for incompatibilities/inconsistencies:
47869 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47870 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47871 & ,' option not used by PYSUGI'
47874 C...ISAJET works with REAL numbers.
47875 MZERO=REAL(RMSS(8))
47877 AZERO=REAL(RMSS(16))
47879 SGNMU=REAL(RMSS(4))
47880 MTOP=REAL(PMAS(6,1))
47882 IF (IMSS(1).EQ.12) THEN
47885 ELSEIF(IMSS(1).EQ.13) THEN
47886 C...Read from isajet par file in IMSS(20)
47888 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47890 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47893 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47894 CMrenna change to allow any susy model
47895 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47896 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47897 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47898 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47899 & ' gauge couplings:'
47900 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47902 IF (IMODEL.EQ.4) THEN
47906 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47907 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47908 & //' sgn(mu), M_t:'
47909 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47910 IF (IMODEL.EQ.3) THEN
47912 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47913 & //' 0 to continue:'
47914 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47915 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47916 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47917 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47918 & //' generation masses'
47920 & ' NUSUG5 = GUT scale 3rd generation masses'
47922 IF (INUSUG.EQ.0) THEN
47924 ELSEIF (INUSUG.EQ.1) THEN
47925 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47926 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47927 IF (XNUSUG(3).LE.0.) THEN
47928 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47931 ELSEIF (INUSUG.EQ.2) THEN
47932 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47933 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47934 ELSEIF (INUSUG.EQ.3) THEN
47935 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47936 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47937 ELSEIF (INUSUG.EQ.4) THEN
47938 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47939 & //' M(ur), M(el), M(er):'
47940 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47941 & XNUSUG(10),XNUSUG(9)
47942 ELSEIF (INUSUG.EQ.5) THEN
47943 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47944 & //' M(Ll), M(Lr):'
47945 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47946 & XNUSUG(15),XNUSUG(14)
47950 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47952 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47953 & ,' sgn(mu), M_t, C_gv:'
47954 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47957 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47959 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47960 IF (IMODEL.EQ.5) THEN
47962 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47963 & ,' masses at M_mes'
47964 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47965 & ,' shifts at M_mes'
47966 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47968 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47970 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47972 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47973 $ XGMIN(13),XGMIN(14)
47976 WRITE(MSTU(11),*) 'Invalid model choice.'
47984 C TANB=REAL(RMSS(5))
47985 C SGNMU=REAL(RMSS(4))
47988 C...Initialize MSSM parameter array
47989 130 DO 140 IPAR=1,72
47993 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47994 C...Check whether ISASUSY thought the model was OK.
47995 IF (NOGOOD.NE.0) THEN
47996 IF (NOGOOD.EQ.1) CALL PYERRM(26
47997 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47998 IF (NOGOOD.EQ.2) CALL PYERRM(26
47999 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
48000 IF (NOGOOD.EQ.3) CALL PYERRM(26
48001 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
48002 IF (NOGOOD.EQ.4) CALL PYERRM(26
48003 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
48004 IF (NOGOOD.EQ.7) CALL PYERRM(26
48005 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
48006 IF (NOGOOD.EQ.8) CALL PYERRM(26
48007 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
48008 C...Give warning, but don't stop, if LSP not ~chi_10.
48009 IF (NOGOOD.EQ.5) CALL PYERRM(16
48010 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
48012 C...Warn about possible GUT scale tachyons.
48013 IF (ITACHY.NE.0) CALL PYERRM(16,
48014 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
48015 C...Finalize spectrum (last iteration)
48016 C...(Thanks to A. Raklev for pointing this out.)
48017 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
48018 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
48019 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
48020 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
48021 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
48022 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
48026 RMSS(1)=dble(GSS(7))
48027 RMSS(2)=dble(GSS(8))
48028 RMSS(3)=dble(GSS(9))
48029 RMSOFT(1)=dble(GSS(7))
48030 RMSOFT(2)=dble(GSS(8))
48031 RMSOFT(3)=dble(GSS(9))
48032 C...Mu = - Higgsino mass.
48035 C...Slepton and squark masses. 2 first generations.
48036 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
48037 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
48038 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
48039 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
48040 C...Third generation.
48041 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
48046 C...SLHA: store exact soft spectrum in RMSOFT
48047 RMSOFT(31)=SUPER(18)
48048 RMSOFT(32)=SUPER(20)
48049 RMSOFT(33)=SUPER(22)
48050 RMSOFT(34)=SUPER(19)
48051 RMSOFT(35)=SUPER(21)
48052 RMSOFT(36)=SUPER(23)
48053 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
48054 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
48055 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
48056 RMSOFT(44)=SUPER(3)
48057 RMSOFT(45)=SUPER(9)
48058 RMSOFT(46)=SUPER(15)
48059 RMSOFT(47)=SUPER(5)
48060 RMSOFT(48)=SUPER(7)
48061 RMSOFT(49)=SUPER(11)
48063 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
48070 C...SLHA trilinears
48081 C...Higgs mixing angle alpha (Gunion-Haber convention).
48082 RMSS(18)=-SUPER(59)
48085 C...GUT scale coupling
48087 C...Gravitino mass (for future compatibility)
48088 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
48090 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
48092 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
48093 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
48094 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
48095 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
48097 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
48098 C...Squarks and Sleptons.
48101 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
48102 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
48103 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
48104 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
48105 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
48106 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
48107 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
48108 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
48109 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
48111 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
48112 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
48113 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
48115 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
48116 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
48117 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
48118 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
48119 C...Signed masses (extra minus from going to G-H convention).
48125 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
48126 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
48127 C...Signed masses (extra minus from going to G-H convention).
48131 C... Neutralino Mixing.
48133 ZMIX(IN,1)= SUPER(38+4*(IN-1))
48134 ZMIX(IN,2)= SUPER(37+4*(IN-1))
48135 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
48136 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
48138 C...Chargino Mixing (PYTHIA same angle as HERWIG).
48141 IF (SUPER(53).GT.0) THX=-1D0
48142 IF (SUPER(54).GT.0) THY=-1D0
48143 UMIX(1,1) = -SIN(SUPER(53))
48144 UMIX(1,2) = -COS(SUPER(53))
48145 UMIX(2,1) = -THX*COS(SUPER(53))
48146 UMIX(2,2) = THX*SIN(SUPER(53))
48147 VMIX(1,1) = -SIN(SUPER(54))
48148 VMIX(1,2) = -COS(SUPER(54))
48149 VMIX(2,1) = -THY*COS(SUPER(54))
48150 VMIX(2,2) = THY*SIN(SUPER(54))
48151 C...Sfermion mixing (PYTHIA same angle as ISAJET)
48152 SFMIX(5,1)=COS(SUPER(63))
48153 SFMIX(5,2)=SIN(SUPER(63))
48154 SFMIX(5,3)=-SIN(SUPER(63))
48155 SFMIX(5,4)=COS(SUPER(63))
48156 SFMIX(6,1)=COS(SUPER(61))
48157 SFMIX(6,2)=SIN(SUPER(61))
48158 SFMIX(6,3)=-SIN(SUPER(61))
48159 SFMIX(6,4)=COS(SUPER(61))
48160 SFMIX(15,1)=COS(SUPER(65))
48161 SFMIX(15,2)=SIN(SUPER(65))
48162 SFMIX(15,3)=-SIN(SUPER(65))
48163 SFMIX(15,4)=COS(SUPER(65))
48165 IF (MSTP(122).NE.0) THEN
48166 C...Print a few lines to make the user know what's happening
48168 WRITE(MSTU(11),5000) DOC, ISAVER
48169 WRITE(MSTU(11),5100)
48170 IF (IMODEL.EQ.1) THEN
48171 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
48173 WRITE(MSTU(11),5300)
48175 WRITE(MSTU(11),5500) 'Pole masses'
48176 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
48177 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
48178 & ,(SUPER(IP),IP=19,25,2)
48179 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
48181 WRITE(MSTU(11),5400)
48182 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
48183 WRITE(MSTU(11),5400)
48184 WRITE(MSTU(11),5500) 'EW scale mixing structure'
48185 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
48186 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
48187 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
48188 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
48189 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
48190 & ),(SFMIX(15,J),J=3,4)
48191 WRITE(MSTU(11),5400)
48192 WRITE(MSTU(11),6450) RMSS(18)
48193 WRITE(MSTU(11),5400)
48194 WRITE(MSTU(11),5500) 'Couplings'
48195 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
48196 WRITE(MSTU(11),5400)
48199 C...Call FeynHiggs to improve Higgs sector if requested
48200 IF (IMSS(4).EQ.3) THEN
48201 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
48202 & ' (PYSUGI:) Now calling FeynHiggs.'
48204 IF (IERR.EQ.0) THEN
48206 IF (MSTP(122).NE.0) THEN
48207 WRITE(MSTU(11),5400)
48208 WRITE(MSTU(11),5500)
48209 & 'Corrected Higgs masses and mixing'
48210 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
48212 WRITE(MSTU(11),6450) RMSS(18)
48213 WRITE(MSTU(11),5400)
48218 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
48220 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
48221 C...output by ISASUSY.
48222 IMSS(4)=MAX(2,IMSS(4))
48224 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
48225 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
48226 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
48227 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
48228 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
48229 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
48230 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
48231 & ,'----------------')
48232 5400 FORMAT(1x,'*',1x,A)
48233 5500 FORMAT(1x,'*',1x,A,':')
48234 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
48235 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
48236 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
48237 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
48238 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
48240 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
48241 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
48242 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
48244 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
48245 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
48246 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
48247 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48248 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
48249 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48250 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
48251 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
48252 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
48253 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
48254 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
48255 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
48256 & ,1x,F6.3,1x),'|')
48257 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
48258 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
48259 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
48260 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
48261 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
48262 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
48263 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
48264 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
48265 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
48266 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
48267 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
48268 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
48269 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
48270 & ,4x,'Alpha_GUT = ',F8.2)
48271 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
48272 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
48277 C*********************************************************************
48280 C...Interface to FeynHiggs for MSSM Higgs sector.
48281 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
48284 SUBROUTINE PYFEYN(IERR)
48286 C...Double precision and integer declarations.
48287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48288 IMPLICIT INTEGER(I-N)
48289 INTEGER PYK,PYCHGE,PYCOMP
48291 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48292 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48294 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48295 C...FeynHiggs variables
48296 DOUBLE PRECISION RMHIGG(4)
48297 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
48298 DOUBLE COMPLEX DMU,
48299 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
48301 C...SLHA Common Block
48302 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
48303 & AU(3,3),AD(3,3),AE(3,3)
48304 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
48307 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
48308 IF (IERR.NE.0) THEN
48309 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
48310 & //'Will not use FeynHiggs for this run.')
48348 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
48349 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
48350 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
48351 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
48352 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
48353 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
48354 IF (IERR.NE.0) THEN
48355 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
48356 & //' Will not use FeynHiggs for this run.')
48359 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
48361 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
48362 IF (IERR.NE.0) THEN
48363 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
48364 & 'GSCORR. Will not use FeynHiggs for this run.')
48367 ALPHA = ASIN(DBLE(SAEFF))
48369 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
48370 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
48371 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
48372 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
48374 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
48375 & 1.15D0*PMAS(25,1)) THEN
48376 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
48377 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
48378 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
48381 PMAS(25,1)=RMHIGG(1)
48382 PMAS(35,1)=RMHIGG(2)
48383 PMAS(36,1)=RMHIGG(3)
48384 PMAS(37,1)=RMHIGG(4)
48389 C*********************************************************************
48392 C...Determines the running mass of Squarks.
48394 FUNCTION PYRNMQ(ID,DTERM)
48396 C...Double precision and integer declarations.
48397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48398 IMPLICIT INTEGER(I-N)
48399 INTEGER PYK,PYCHGE,PYCOMP
48401 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48404 C...Local variables.
48405 DOUBLE PRECISION PI,R
48406 DOUBLE PRECISION TOL
48407 DOUBLE PRECISION CI(3)
48409 DOUBLE PRECISION PYALPS
48411 DATA PI,R/3.141592654D0,.61803399D0/
48412 DATA CI/0.47D0,0.07D0,0.02D0/
48416 AG=(0.71D0)**2/4D0/PI
48423 AS=PYALPS(XM02+6D0*XMG2)
48424 CG=8D0/9D0*((AS/AG)**2-1D0)
48425 BX=XM02+(CA+CG)*XMG2+DTERM
48426 AX=MIN(50D0**2,0.5D0*BX)
48427 CX=MAX(2000D0**2,2D0*BX)
48431 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48439 CG=8D0/9D0*((AS1/AG)**2-1D0)
48440 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
48442 CG=8D0/9D0*((AS2/AG)**2-1D0)
48443 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
48444 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48451 CG=8D0/9D0*((AS2/AG)**2-1D0)
48452 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
48459 CG=8D0/9D0*((AS1/AG)**2-1D0)
48460 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
48475 C*********************************************************************
48478 C...Calculates the mass eigenstates of the third generation sfermions.
48479 C...Created: 5-31-96
48483 C...Double precision and integer declarations.
48484 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48485 IMPLICIT INTEGER(I-N)
48486 INTEGER PYK,PYCHGE,PYCOMP
48487 C...Parameter statement to help give large particle numbers.
48488 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48489 &KEXCIT=4000000,KDIMEN=5000000)
48491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48492 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48493 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48494 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48495 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48496 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48498 C...Local variables.
48499 DOUBLE PRECISION BETA
48500 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
48501 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
48502 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
48503 DOUBLE PRECISION ATR,AMQR,AMQL
48504 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
48505 INTEGER IF,I,J,II,JJ,IT,L
48519 COS2B=COS(2D0*BETA)
48521 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
48531 XMQL2=CTT2*XM12+STT2*XM22
48532 XMQR2=STT2*XM12+CTT2*XM22
48533 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
48534 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48536 C......SUBTRACT OUT D-TERM AND FERMION MASS
48537 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
48538 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
48539 IF(XMQL2.GE.0D0) THEN
48540 RMSS(10)=SQRT(XMQL2)
48542 RMSS(10)=-SQRT(-XMQL2)
48544 IF(XMQR2.GE.0D0) THEN
48545 RMSS(12)=SQRT(XMQR2)
48547 RMSS(12)=-SQRT(-XMQR2)
48550 C SAME FOR BOTTOM SQUARK
48556 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
48557 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
48558 IF(ABS(CTT).GE..9999D0) THEN
48561 ELSEIF(ABS(CTT).LE.1D-4) THEN
48565 XM12=(XMQL2-STT2*XM22)/CTT2
48566 XMQR2=STT2*XM12+CTT2*XM22
48567 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48570 C......SUBTRACT OUT D-TERM AND FERMION MASS
48571 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
48572 IF(XMQR2.GE.0D0) THEN
48573 RMSS(11)=SQRT(XMQR2)
48575 RMSS(11)=-SQRT(-XMQR2)
48577 C SAME FOR TAU SLEPTON
48584 XMQL2=CTT2*XM12+STT2*XM22
48585 XMQR2=STT2*XM12+CTT2*XM22
48588 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48590 C......SUBTRACT OUT D-TERM AND FERMION MASS
48591 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
48592 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
48593 IF(XMQL2.GE.0D0) THEN
48594 RMSS(13)=SQRT(XMQL2)
48596 RMSS(13)=-SQRT(-XMQL2)
48598 IF(XMQR2.GE.0D0) THEN
48599 RMSS(14)=SQRT(XMQR2)
48601 RMSS(14)=-SQRT(-XMQR2)
48606 IF(AMQL.LT.0D0) THEN
48613 IF(AMQR.LT.0D0) THEN
48619 XMF=PYMRUN(IF,PMAS(6,1)**2)
48621 AM2(1,1)=XMQL2+XMF2
48622 AM2(2,2)=XMQR2+XMF2
48623 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
48626 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
48627 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
48628 AM2(1,2)=XMF*(ATR+XMU*TANB)
48629 ELSEIF(L.EQ.2) THEN
48630 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
48631 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
48632 AM2(1,2)=XMF*(ATR+XMU/TANB)
48633 ELSEIF(L.EQ.3) THEN
48634 IF(IMSS(8).EQ.1) THEN
48635 AM2(1,1)=RMSS(6)**2
48636 AM2(2,2)=RMSS(7)**2
48641 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
48642 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
48643 AM2(1,2)=XMF*(ATR+XMU*TANB)
48648 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
48649 IF(DETM.LT.0D0) THEN
48650 WRITE(MSTU(11),*) ID2(L),DETM,AM2
48651 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
48653 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
48654 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
48658 IF(XMF22-XMF12.GT.0D0) THEN
48659 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
48661 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
48662 & AM2(1,2)/(XMF22-XMF12))
48678 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
48684 IF(DI(1,1).GT.DI(2,2)) THEN
48685 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
48686 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
48687 WRITE(MSTU(11),*) AM2
48688 WRITE(MSTU(11),*) DI
48689 WRITE(MSTU(11),*) RT
48700 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
48701 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
48702 & ' OFF DIAGONAL ELEMENTS '
48703 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
48704 WRITE(MSTU(11),*) DI
48705 WRITE(MSTU(11),*) ' ROTATION = ',RT
48707 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
48708 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
48709 & ' NEGATIVE MASSES '
48712 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
48713 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
48714 SFMIX(IF,1)=RT(1,1)
48715 SFMIX(IF,2)=RT(1,2)
48716 SFMIX(IF,3)=RT(2,1)
48717 SFMIX(IF,4)=RT(2,2)
48720 C.....TAU SNEUTRINO MASS...L=3
48722 XARG=AM2(1,1)+XMW2*COS2B
48723 IF(XARG.LT.0D0) THEN
48724 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
48725 & ' FROM THE SUM RULE. '
48726 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
48729 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
48734 C*********************************************************************
48737 C...Finds the mass eigenstates and mixing matrices for neutralinos
48742 C...Double precision and integer declarations.
48743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48744 IMPLICIT INTEGER(I-N)
48746 C...Parameter statement to help give large particle numbers.
48747 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48748 &KEXCIT=4000000,KDIMEN=5000000)
48750 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48751 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48752 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48753 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48754 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48755 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48757 C...Local variables.
48758 DOUBLE PRECISION XMW,XMZ,XM(4)
48759 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
48760 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
48761 DOUBLE PRECISION COSW,SINW
48762 DOUBLE PRECISION XMU
48763 DOUBLE PRECISION TANB,COSB,SINB
48764 DOUBLE PRECISION XM1,XM2,XM3,BETA
48765 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
48766 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
48767 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
48768 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
48769 DOUBLE PRECISION PYALPS,PYALEM
48770 DOUBLE PRECISION PYRNM3
48771 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
48772 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
48773 DATA KFNCHI/1000022,1000023,1000025,1000035/
48776 IF(IMSS(1).EQ.2) THEN
48779 C...M1, M2, AND M3 ARE INDEPENDENT
48784 ELSEIF(IOPT.GE.1) THEN
48788 A1=AEM/(1D0-PARU(102))
48791 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
48793 XM2=XM1*A2/A1*3D0/5D0
48795 ELSEIF(IOPT.EQ.3) THEN
48796 XM1=XM2*5D0/3D0*A1/A2
48801 IF(XM3.LE.0D0) THEN
48802 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
48808 IF(IMSS(3).EQ.1) THEN
48809 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48814 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48815 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48816 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48822 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48823 RM2=PMAS(I,1)**2/XM3**2
48824 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48825 IF(ARG.GE.0D0) THEN
48826 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48828 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48833 ELSEIF(X0.EQ.0D0) THEN
48837 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48838 & 0.5D0*X0**2*LOG(AX0)
48839 BT=(-1D0-2D0*X0)/4D0
48844 ELSEIF(X1.EQ.0D0) THEN
48848 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48849 & X1**2*LOG(AX1)+AT
48850 BT=(-1D0-2D0*X1)/4D0+BT
48854 X0=0.5D0*(1D0+RM2-RM1)
48855 Y0=-0.5D0*SQRT(-ARG)
48856 AMGX0=SQRT(X0**2+Y0**2)
48857 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48858 ARGX0=ATAN2(-X0,-Y0)
48859 AR1X0=ATAN2(1D0-X0,Y0)
48864 ARGX1=ATAN2(-X1,-Y1)
48865 AR1X1=ATAN2(1D0-X1,Y1)
48866 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48867 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48868 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48869 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48870 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48871 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48876 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48877 & /(2D0*PARU(2))*(15D0+AQ))
48880 C...NEUTRALINO MASSES
48886 XMZ=PMAS(23,1)/100D0
48887 XMW=PMAS(24,1)/100D0
48889 SINW=SQRT(PARU(102))
48890 COSW=SQRT(1D0-PARU(102))
48901 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48902 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48903 AR(1,1) = XM1*COS(RMSS(30))
48904 AI(1,1) = XM1*SIN(RMSS(30))
48905 AR(2,2) = XM2*COS(RMSS(31))
48906 AI(2,2) = XM2*SIN(RMSS(31))
48911 AR(1,3) = -XMZ*SINW*COSB
48913 AR(1,4) = XMZ*SINW*SINB
48915 AR(2,3) = XMZ*COSW*COSB
48917 AR(2,4) = -XMZ*COSW*SINB
48919 AR(3,4) = -XMU*COS(RMSS(33))
48920 AI(3,4) = -XMU*SIN(RMSS(33))
48921 AR(4,3) = -XMU*COS(RMSS(33))
48922 AI(4,3) = -XMU*SIN(RMSS(33))
48923 C CALL PYEIG4(AR,WR,ZR)
48924 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48925 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48926 & 'PROBLEM WITH PYEICG IN PYINOM ')
48934 IF(XM(K).LT.XM(J)) THEN
48952 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48955 S=S+ZR(J,K)**2+ZI(J,K)**2
48958 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48959 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48960 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48961 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48965 C...CHARGINO MASSES
48966 C.....Find eigenvectors of X X^*
48975 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48976 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48977 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48978 &XMU*COS(RMSS(33))*SINB)
48979 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48980 &XMU*SIN(RMSS(33))*SINB)
48981 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48982 &XMU*COS(RMSS(33))*SINB)
48983 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48984 &XMU*SIN(RMSS(33))*SINB)
48985 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48986 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48987 & 'PROBLEM WITH PYEICG IN PYINOM ')
48990 IF(WR(2).LT.WR(1)) THEN
48998 SMW(I)=SQRT(WR(K))*100D0
49001 S=S+ZR(J,K)**2+ZI(J,K)**2
49004 UMIX(I,J)=ZR(J,K)/SQRT(S)
49005 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
49006 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
49007 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
49010 C...Force chargino mass > neutralino mass
49012 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
49013 CALL PYERRM(8,'(PYINOM:) '//
49014 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
49015 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
49018 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
49019 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
49021 C.....Find eigenvectors of X^* X
49032 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
49033 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
49034 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
49035 &XMU*COS(RMSS(33))*COSB)
49036 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
49037 &XMU*SIN(RMSS(33))*COSB)
49038 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
49039 &XMU*COS(RMSS(33))*COSB)
49040 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
49041 &XMU*SIN(RMSS(33))*COSB)
49042 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
49043 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
49044 & 'PROBLEM WITH PYEICG IN PYINOM ')
49047 IF(WR(2).LT.WR(1)) THEN
49057 S=S+ZR(J,K)**2+ZI(J,K)**2
49058 SIMAG=SIMAG+ZI(J,K)**2
49061 VMIX(I,J)=ZR(J,K)/SQRT(S)
49062 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
49063 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
49064 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
49068 C.....Simplify if no phases
49069 IF(SIMAG.LT.1D-6) THEN
49070 AR(1,1) = XM2*COS(RMSS(31))
49071 AR(2,2) = XMU*COS(RMSS(33))
49072 AR(1,2) = SQRT(2D0)*XMW*SINB
49073 AR(2,1) = SQRT(2D0)*XMW*COSB
49086 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
49091 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
49092 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
49093 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
49094 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
49095 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
49096 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
49097 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
49101 C.....Must deal with phases
49103 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
49104 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
49105 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
49106 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
49112 CAI(I,J)=CMPLX(0D0,0D0)
49120 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
49121 & CMPLX(VMIX(J,L),VMIXI(J,L))
49127 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
49128 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
49131 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
49132 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
49135 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
49136 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
49139 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
49140 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
49143 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
49144 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
49145 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
49146 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
49147 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
49148 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
49156 C*********************************************************************
49159 C...Calculates the running of M3, the SU(3) gluino mass parameter.
49161 FUNCTION PYRNM3(RGUT)
49163 C...Double precision and integer declarations.
49164 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49165 IMPLICIT INTEGER(I-N)
49166 INTEGER PYK,PYCHGE,PYCOMP
49168 C...Local variables.
49170 DOUBLE PRECISION TOL
49172 DOUBLE PRECISION PYALPS
49174 DATA R/0.61803399D0/
49178 BX=RGUT*PYALPS(RGUT**2)
49179 AX=MIN(50D0,BX*0.5D0)
49180 CX=MAX(2000D0,2D0*BX)
49184 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
49192 F1=ABS(X1-RGUT*AS1)
49194 F2=ABS(X2-RGUT*AS2)
49195 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
49202 F2=ABS(X2-RGUT*AS2)
49209 F1=ABS(X1-RGUT*AS1)
49224 C*********************************************************************
49227 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
49228 C...Specific application: mixing in neutralino sector.
49230 SUBROUTINE PYEIG4(A,W,Z)
49232 C...Double precision and integer declarations.
49233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49234 IMPLICIT INTEGER(I-N)
49235 INTEGER PYK,PYCHGE,PYCOMP
49237 C...Arrays: in call and local.
49238 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
49240 C...Coefficients of fourth-degree equation from matrix.
49241 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
49242 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
49246 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
49255 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
49256 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
49257 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
49258 B0=B0+(-1D0)**(I+1)*A(1,I)*(
49259 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
49260 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
49261 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
49264 C...Coefficients of third-degree equation needed for
49265 C...separation into two second-degree equations.
49266 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
49269 C0=-B1**2-B0*B3**2+4D0*B0*B2
49270 CQ=C1/3D0-C2**2/9D0
49271 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
49274 C...Cases with one or three real roots.
49275 IF(CQR.GE.0D0) THEN
49276 S1=(CR+SQRT(CQR))**(1D0/3D0)
49277 S2=(CR-SQRT(CQR))**(1D0/3D0)
49281 THE=ACOS(CR/SABS**3)/3D0
49286 C...Find and solve two second-degree equations.
49287 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
49288 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
49289 Q1=U/2D0+SQRT(U**2/4D0-B0)
49290 Q2=U/2D0-SQRT(U**2/4D0-B0)
49291 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
49296 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
49297 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
49298 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
49299 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
49301 C...Order eigenvalues in asceding mass.
49304 DO 130 I2=I1-1,1,-1
49305 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
49311 C...Find equation system for eigenvectors.
49314 D(J1,J1)=A(J1,J1)-W(I)
49321 C...Find largest element in matrix.
49325 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
49328 DAMAX=ABS(D(J1,J2))
49332 C...Subtract others by multiple of row selected above.
49334 DO 210 J3=JA+1,JA+3
49336 RL=D(J1,JB)/D(JA,JB)
49338 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
49339 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
49342 DAMAX=ABS(D(J1,J2))
49346 C...Do one more subtraction of a row.
49348 DO 230 J3=JC+1,JC+3
49350 IF(J1.EQ.JA) GOTO 230
49351 RL=D(J1,JD)/D(JC,JD)
49353 IF(J2.EQ.JB) GOTO 220
49354 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
49355 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
49357 DAMAX=ABS(D(J1,J2))
49361 C...Construct unnormalized eigenvector.
49363 JF2=JD+2-4*((JD+1)/4)
49364 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
49365 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
49368 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
49369 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
49372 C...Normalize and fill in final array.
49373 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
49374 SGN=(-1D0)**INT(PYR(0)+0.5D0)
49383 C*********************************************************************
49386 C...Determines the Higgs boson mass spectrum using several inputs.
49388 SUBROUTINE PYHGGM(ALPHA)
49390 C...Double precision and integer declarations.
49391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49392 IMPLICIT INTEGER(I-N)
49393 INTEGER PYK,PYCHGE,PYCOMP
49394 C...Parameter statement to help give large particle numbers.
49395 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49396 &KEXCIT=4000000,KDIMEN=5000000)
49398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49399 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49400 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
49401 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49402 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
49404 C...Local variables.
49405 DOUBLE PRECISION AT,AB,XMU,TANB
49406 DOUBLE PRECISION ALPHA
49408 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
49409 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
49410 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
49411 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
49414 IF(IHOPT.EQ.2) THEN
49430 DMC=PMAS(PYCOMP(KSUSY1+37),1)
49437 IF(IHOPT.EQ.0) THEN
49438 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
49439 & DMHCH,DSA,DCA,DTANBA)
49440 ELSEIF(IHOPT.EQ.1) THEN
49441 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
49442 & DMHCH,DSA,DCA,DTANBA)
49443 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
49444 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
49445 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
49451 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
49452 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
49453 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
49454 & PMAS(PYCOMP(1000006),1),DSTOP2
49456 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
49457 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
49458 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
49459 & PMAS(PYCOMP(2000006),1),DSTOP1
49461 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
49462 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
49463 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
49464 & PMAS(PYCOMP(1000005),1),DSBOT2
49466 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
49467 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
49468 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
49469 & PMAS(PYCOMP(2000005),1),DSBOT1
49472 ELSEIF (IHOPT.EQ.3) THEN
49473 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
49474 C...Currently only available for SLHA spectrum read-in.
49475 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
49476 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
49477 & //' spectrum, change IMSS(1) or IMSS(4) option.')
49493 C*********************************************************************
49496 C...This routine computes the renormalization group improved
49497 C...values of Higgs masses and couplings in the MSSM.
49499 C...Program based on the work by M. Carena, J.R. Espinosa,
49500 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
49502 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
49503 C...All masses in GeV units. MA is the CP-odd Higgs mass,
49504 C...MTOP is the physical top mass, MQ and MUR are the soft
49505 C...supersymmetry breaking mass parameters of left handed
49506 C...and right handed stops respectively, AU and AD are the
49507 C...stop and sbottom trilinear soft breaking terms,
49508 C...respectively, and MU is the supersymmetric
49509 C...Higgs mass parameter. We use the conventions from
49510 C...the physics report of Haber and Kane: left right
49511 C...stop mixing term proportional to (AU - MU/TANB)
49512 C...We use as input TANB defined at the scale MTOP
49514 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
49515 C...where MH and HM are the lightest and heaviest CP-even
49516 C...Higgs masses, MHCH is the charged Higgs mass and
49517 C...ALPHA is the Higgs mixing angle
49518 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
49520 C...Range of validity:
49521 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
49522 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
49523 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
49524 C...are the sbottom mass eigenvalues, respectively. This
49525 C...range automatically excludes the existence of tachyons.
49526 C...For the charged Higgs mass computation, the method is
49528 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
49529 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
49530 C...where M_SUSY**2 is the average of the squared stop mass
49531 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
49532 C...masses have been assumed to be of order of the stop ones
49533 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
49535 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
49536 &XMHCH,SA,CA,TANBA)
49538 C...Double precision and integer declarations.
49539 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49540 IMPLICIT INTEGER(I-N)
49541 INTEGER PYK,PYCHGE,PYCOMP
49542 C...Parameter statement to help give large particle numbers.
49543 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49544 &KEXCIT=4000000,KDIMEN=5000000)
49546 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49547 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49548 COMMON/PYHTRI/HHH(7)
49549 SAVE /PYDAT1/,/PYDAT2/
49551 C...Local variables.
49552 DOUBLE PRECISION PYALEM,PYALPS
49553 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
49554 DOUBLE PRECISION XMHCH,SA,CA
49555 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
49556 DOUBLE PRECISION Q02
49557 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
49558 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
49559 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
49560 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
49561 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
49562 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
49563 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
49564 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
49569 ALP1=AEM/(1D0-PARU(102))
49582 C...MBOTTOM(MTOP) = 3. GEV
49583 XMB = PYMRUN(5,XMTOP**2)
49584 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
49585 &LOG(XMTOP**2/XMZ**2))
49587 C...RMTOP= RUNNING TOP QUARK MASS
49588 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
49589 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
49590 T = LOG(XMS**2/XMTOP**2)
49591 SINB = TANB/((1D0 + TANB**2)**0.5D0)
49593 C...IF(MA.LE.XMTOP) TANBA = TANBT
49595 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
49596 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
49597 &LOG(XMA**2/XMTOP**2))
49599 SINBT = TANBT/SQRT(1D0 + TANBT**2)
49600 COSBT = 1D0/SQRT(1D0 + TANBT**2)
49601 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
49602 G1 = SQRT(ALP1*4D0*PI)
49603 G2 = SQRT(ALP2*4D0*PI)
49604 G3 = SQRT(ALP3*4D0*PI)
49619 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
49620 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
49621 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
49622 &+ 3D0*(AU + AD)**2/XMS2)/6D0
49623 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
49624 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
49625 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
49626 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
49627 &- 16D0*G3**2) *T/16D0/PI2)
49628 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
49629 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
49630 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
49631 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
49632 &- 16D0*G3**2) *T/16D0/PI2)
49633 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49634 &(HU2 + HD2)*T/16D0/PI2)
49635 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
49636 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
49637 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
49638 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
49639 &- 16D0*G3**2) *T/16D0/PI2)
49640 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
49641 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
49642 &- 16D0*G3**2) *T/16D0/PI2)
49643 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
49644 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
49645 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
49646 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
49648 &(1+ (6D0*HU2 -2D0* HD2
49649 &- 16D0*G3**2) *T/16D0/PI2)
49650 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
49652 &(1+ (6D0*HD2 -2D0* HU2/2D0
49653 &- 16D0*G3**2) *T/16D0/PI2)
49654 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
49655 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
49656 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
49657 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
49658 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
49659 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49660 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
49661 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49662 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
49663 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49664 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
49665 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49673 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
49674 &2D0* XLAM6*SINBT*COSBT
49675 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
49677 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
49679 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
49680 &2D0* XLAM6* COSBT*SINBT
49681 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49682 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
49683 &((XLAM1* COSBT**2 +2D0*
49684 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
49685 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
49687 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
49688 &+ XLAM4) + XLAM6*COSBT**2
49689 &+ XLAM7* SINBT**2))
49691 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
49692 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
49695 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
49696 XMHCH = SQRT(XMHCH2)
49698 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
49699 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
49700 &XLAM6* COSBT*SINBT
49701 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
49702 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49703 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
49704 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
49706 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
49707 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
49708 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
49709 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
49710 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
49711 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
49712 &XLAM6* COSBT*SINBT
49713 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
49714 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49715 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
49725 C*********************************************************************
49728 C...This subroutine computes the CP-even higgs and CP-odd pole
49729 c...Higgs masses and mixing angles.
49731 C...Program based on the work by M. Carena, M. Quiros
49732 C...and C.E.M. Wagner, "Effective potential methods and
49733 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
49735 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
49737 C...where MCHI is the largest chargino mass, MA is the running
49738 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
49739 C...expectaion values at the scale MTOP, MQ is the third generation
49740 C...left handed squark mass parameter, MUR is the third generation
49741 C...right handed stop mass parameter, MDR is the third generation
49742 C...right handed sbottom mass parameter, MTOP is the pole top quark
49743 C...mass; AT,AB are the soft supersymmetry breaking trilinear
49744 C...couplings of the stop and sbottoms, respectively, and MU is the
49745 C...supersymmetric mass parameter
49747 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
49748 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
49749 C...masses are given, what makes the running of the program
49750 c...much faster and it is quite generally a good approximation
49751 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
49752 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
49753 c...and if IHIGGS=3, then h,H,A polarizations are computed
49755 C...Output: MH and MHP which are the lightest CP-even Higgs running
49756 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
49757 C...Higgs running and pole masses, repectively; SA and CA are the
49758 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
49759 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
49760 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
49761 C...the value of TANB at the CP-odd Higgs mass scale
49763 C...This subroutine makes use of CERN library subroutine
49764 C...integration package, which makes the computation of the
49765 C...pole Higgs masses somewhat faster. We thank P. Janot for this
49766 C...improvement. Those who are not able to call the CERN
49767 C...libraries, please use the subroutine SUBHPOLE2.F, which
49768 C...although somewhat slower, gives identical results
49770 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
49771 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
49773 C...Double precision and integer declarations.
49774 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49775 IMPLICIT INTEGER(I-N)
49778 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49780 INTEGER PYK,PYCHGE,PYCOMP
49782 C...Local variables.
49783 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
49784 &SSBOT2(2),B(2,2),COUPB(2,2),
49785 &HCOUPT(2,2),HCOUPB(2,2),
49786 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
49795 RXMT=PYMRUN(6,XMT**2)
49796 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
49797 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
49799 SINB = TANB/(TANB**2+1D0)**0.5D0
49800 COSB = 1D0/(TANB**2+1D0)**0.5D0
49801 COS2B = SINB**2 - COSB**2
49802 SINBPA = SINB*CA + COSB*SA
49803 COSBPA = COSB*CA - SINB*SA
49804 RMBOT = PYMRUN(5,XMT**2)
49807 IF(XMUR.LT.0D0) XMUR2=-XMUR2
49809 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
49810 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49811 IF(XMST11.LT.0D0) GOTO 500
49812 IF(XMST22.LT.0D0) GOTO 500
49813 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49814 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49815 IF(XMSB11.LT.0D0) GOTO 500
49816 IF(XMSB22.LT.0D0) GOTO 500
49817 C WMST11 = RXMT**2 + XMQ2
49818 C WMST22 = RXMT**2 + XMUR2
49819 XMST12 = RXMT*(AT - XMU/TANB)
49820 XMSB12 = RMBOT*(AB - XMU*TANB)
49822 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49823 C...STOP EIGENVALUES CALCULATION
49824 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49826 STOP12 = 0.5D0*(XMST11+XMST22) +
49827 &0.5D0*((XMST11+XMST22)**2 -
49828 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49829 STOP22 = 0.5D0*(XMST11+XMST22) -
49830 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49831 &XMST12**2))**0.5D0
49833 IF(STOP22.LT.0D0) GOTO 500
49836 STOP1 = STOP12**0.5D0
49837 STOP2 = STOP22**0.5D0
49841 IF(XMST12.EQ.0D0) XST11 = 1D0
49842 IF(XMST12.EQ.0D0) XST12 = 0D0
49843 IF(XMST12.EQ.0D0) XST21 = 0D0
49844 IF(XMST12.EQ.0D0) XST22 = 1D0
49846 IF(XMST12.EQ.0D0) GOTO 110
49848 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49849 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49850 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49851 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49858 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49859 &0.5D0*((XMSB11+XMSB22)**2 -
49860 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49861 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49862 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49863 &XMSB12**2))**0.5D0
49864 IF(SBOT22.LT.0D0) GOTO 500
49865 SBOT1 = SBOT12**0.5D0
49866 SBOT2 = SBOT22**0.5D0
49871 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49872 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49873 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49874 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49876 IF(XMSB12.EQ.0D0) GOTO 130
49878 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49879 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49880 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49881 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49893 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49894 C...STARTING OF LIGHT HIGGS
49895 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49897 IF(IHIGGS.EQ.0) GOTO 490
49902 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49903 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49904 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49905 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49914 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49915 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49916 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49917 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49925 180 ITER = ITER + 1
49928 PR(I3)=PRUN+(I3-2)*EPS/2
49933 POLT = POLT + COUPT(I,J)**2*3D0*
49934 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49941 POLB = POLB + COUPB(I,J)**2*3D0*
49942 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49949 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49951 & (-2D0*XMT**2+0.5D0*P2)*
49952 & PYFINT(P2,XMT2,XMT2)
49954 POL = POLT + POLB + POLTT
49955 POLAR(I3) = P2 - XMH**2 - POL
49957 DERIV = (POLAR(3)-POLAR(1))/EPS
49958 DRUN = - POLAR(2)/DERIV
49961 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49967 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49968 C...END OF LIGHT HIGGS
49969 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49971 250 IF(IHIGGS.EQ.1) GOTO 490
49973 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49974 C... STARTING OF HEAVY HIGGS
49975 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49980 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49981 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49982 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49983 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49991 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49992 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49993 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49994 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
50003 300 ITER = ITER + 1
50005 PR(I3)=PRUN+(I3-2)*EPS/2
50011 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
50012 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
50019 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
50020 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
50028 & 3D0*RXMT**2/8D0/PI**2/ V **2*
50030 & (-2D0*XMT**2+0.5D0*HP2)*
50031 & PYFINT(HP2,XMT2,XMT2)
50033 HPOL = HPOLT + HPOLB + HPOLTT
50034 POLAR(I3) =HP2-HM**2-HPOL
50036 DERIV = (POLAR(3)-POLAR(1))/EPS
50037 DRUN = - POLAR(2)/DERIV
50040 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
50048 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50049 C... END OF HEAVY HIGGS
50050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50052 IF(IHIGGS.EQ.2) GOTO 490
50054 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50055 C...BEGINNING OF PSEUDOSCALAR HIGGS
50056 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50061 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
50062 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
50068 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
50069 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
50076 420 ITER = ITER + 1
50078 PR(I3)=PRUN+(I3-2)*EPS/2
50083 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
50084 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
50090 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
50091 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
50097 & 3D0*RXMT**2/8D0/PI**2/ V **2*
50098 & COSB**2/SINB**2 *
50100 & PYFINT(AP2,XMT2,XMT2)
50101 APOL = APOLT + APOLB + APOLTT
50102 POLAR(I3) = AP2 - XMA**2 -APOL
50104 DERIV = (POLAR(3)-POLAR(1))/EPS
50105 DRUN = - POLAR(2)/DERIV
50108 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
50114 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50115 C...END OF PSEUDOSCALAR HIGGS
50116 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50118 IF(IHIGGS.EQ.3) GOTO 490
50123 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
50124 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
50125 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
50126 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
50130 C*********************************************************************
50133 C...Auxiliary to PYPOLE.
50135 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
50136 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
50137 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
50138 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
50141 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50152 C MBOTTOM(MTOP) = 3. GEV
50153 MB = PYMRUN(5,MTOP**2)
50154 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
50155 *LOG(MTOP**2/MZ**2))
50156 C RMTOP= RUNNING TOP QUARK MASS
50157 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
50158 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
50159 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
50160 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
50161 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50163 C NEW DEFINITION, TGLU.
50165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50166 TGLU = LOG(MGLU**2/MTOP**2)
50167 SINB = TANB/DSQRT(1D0 + TANB**2)
50170 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
50171 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
50172 *LOG(MA**2/MTOP**2))
50173 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
50174 SINB = TANBT/SQRT(1D0 + TANBT**2)
50175 COSB = 1D0/DSQRT(1D0 + TANBT**2)
50176 G1 = SQRT(ALPHA1*4D0*PI)
50177 G2 = SQRT(ALPHA2*4D0*PI)
50178 G3 = SQRT(ALPHA3*4D0*PI)
50181 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
50182 *SBOT1,SBOT2,DELTAMT,DELTAMB)
50183 IF(MQ.GT.MUR) TP = TQ - TU
50184 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
50185 IF(MQ.GT.MUR) TDP = TU
50186 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
50187 IF(MQ.GT.MD) TPD = TQ - TD
50188 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
50189 IF(MQ.GT.MD) TDPD = TD
50190 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
50192 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
50193 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
50194 * HD**2*(G1**2/3D0+G2**2)*TPD
50196 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
50197 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
50198 * HU**2*(-G1**2/3D0+G2**2)*TP
50200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50202 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
50203 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
50204 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
50208 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50211 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
50212 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
50213 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
50216 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
50217 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
50220 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
50221 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
50224 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
50225 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
50228 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
50229 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
50232 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
50233 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
50238 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
50239 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
50240 *(G2**2-G1**2/3D0)*TPD
50241 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
50242 *1D0/16D0/PI**2*G1**2*HU**2*TP
50243 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
50244 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
50245 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
50246 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
50248 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
50249 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
50250 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
50251 *+ (3D0*HD**2/2D0 + HU**2/2D0
50252 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
50253 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
50254 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
50255 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
50256 *(TP + TDP)/8D0/PI**2)
50257 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
50258 *+ (3D0*HU**2/2D0 + HD**2/2D0
50259 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
50260 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
50261 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
50262 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
50263 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
50264 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
50265 LAMBDA4 = (- G2**2/2D0)*(1D0
50266 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
50267 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
50273 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
50274 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
50276 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
50277 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
50278 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
50279 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
50282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50283 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
50284 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50286 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
50288 IF(MCHI.GT.MSSUSY) GOTO 100
50289 IF(MCHI.LT.MTOP) MCHI=MTOP
50291 TCHAR=LOG(MSSUSY**2/MCHI**2)
50293 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
50294 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
50295 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
50297 DELTAM112=2D0*DELTAL12*V**2*COSB**2
50298 DELTAM222=2D0*DELTAL12*V**2*SINB**2
50299 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
50301 M2(1,1)=M2(1,1)+DELTAM112
50302 M2(2,2)=M2(2,2)+DELTAM222
50303 M2(1,2)=M2(1,2)+DELTAM122
50304 M2(2,1)=M2(2,1)+DELTAM122
50308 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50309 CCC END OF CHARGINOS/NEUTRALINOS
50310 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50314 M2P(I,J) = M2(I,J) + VH(I,J)
50317 TRM2P = M2P(1,1) + M2P(2,2)
50318 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
50319 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
50320 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
50322 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
50324 IF(MH2P.LT.0.) GOTO 130
50326 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
50327 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
50328 IF(COS2ALPHA.GE.0.) THEN
50329 ALPHA = ASIN(SIN2ALPHA)/2D0
50331 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
50335 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50337 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
50338 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
50339 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
50342 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50343 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
50344 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
50349 C*********************************************************************
50352 C...Auxiliary to PYRGHM.
50354 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
50355 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
50356 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
50357 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
50359 INTEGER MSTU,MSTJ,KCHG
50360 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50361 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50362 SAVE /PYDAT1/,/PYDAT2/
50364 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
50366 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
50367 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
50369 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
50374 SINBA = TANBA/DSQRT(TANBA**2+1D0)
50375 COSBA = SINBA/TANBA
50377 SINB = TANB/DSQRT(TANB**2+1D0)
50383 SW = 1D0-MW**2/MZ**2
50386 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
50387 G2 = DSQRT(0.0336D0*4D0*PI)
50388 G1 = DSQRT(0.0101D0*4D0*PI)
50390 IF(MQ.GT.MUR) MST = MQ
50391 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
50393 MSUSYT = DSQRT(MST**2 + MTOP**2)
50395 IF(MQ.GT.MD) MSB = MQ
50396 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
50398 MB = PYMRUN(5,MSB**2)
50399 MSUSYB = DSQRT(MSB**2 + MB**2)
50400 TT = LOG(MSUSYT**2/MTOP**2)
50401 TB = LOG(MSUSYB**2/MTOP**2)
50403 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
50404 HT = RMTOP/(V*SINB)
50407 G32 = ALPHA3*4D0*PI
50408 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
50409 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
50410 AL2 = 3D0/8D0/PI**2*HT**2
50411 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
50412 C ALST = 3./8./PI**2*HTST**2
50413 AL1 = 3D0/8D0/PI**2*HB**2
50416 AL(1,2) = (AL2+AL1)/2D0
50417 AL(2,1) = (AL2+AL1)/2D0
50420 IF(MA.GT.MTOP) THEN
50421 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
50422 * LOG(MTOP**2/MA**2))
50425 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
50426 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
50427 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
50428 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
50433 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
50434 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
50435 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
50436 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
50440 SINBT = TANBST/DSQRT(1D0+TANBST**2)
50443 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
50444 COSBB = SINBB/TANBSB
50449 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
50450 MTOP2 = DSQRT(MTOP4)
50451 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
50452 * /(1D0+DELTAMB)**4
50453 MBOT2 = DSQRT(MBOT4)
50455 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
50456 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50457 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50458 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
50459 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
50460 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50461 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50462 * MQ2 - MUR2)**2*0.25D0
50463 * + MTOP2*(AT-XMU/TANBST)**2)
50464 IF(STOP22.LT.0.) GOTO 120
50465 SBOT12 = (MQ2 + MD2)*.5D0
50466 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50467 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50468 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50469 SBOT22 = (MQ2 + MD2)*.5D0
50470 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50471 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50472 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50473 IF(SBOT22.LT.0.) SBOT22 = 10000D0
50475 STOP1 = DSQRT(STOP12)
50476 STOP2 = DSQRT(STOP22)
50477 SBOT1 = DSQRT(SBOT12)
50478 SBOT2 = DSQRT(SBOT22)
50480 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50482 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
50483 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
50484 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
50485 C INDUCED CORRECTIONS.
50487 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50492 IF(X.EQ.Y) X = X - 0.00001D0
50493 IF(X.EQ.Z) X = X - 0.00002D0
50494 IF(Y.EQ.Z) Y = Y - 0.00003D0
50500 IF(X.EQ.Y) X = X - 0.00001D0
50501 IF(X.EQ.Z) X = X - 0.00002D0
50502 IF(Y.EQ.Z) Y = Y - 0.00003D0
50504 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
50505 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
50509 IF(X.EQ.Y) X = X - 0.00001D0
50510 IF(X.EQ.Z) X = X - 0.00002D0
50511 IF(Y.EQ.Z) Y = Y - 0.00003D0
50513 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
50515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50517 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
50518 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
50519 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
50520 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
50521 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
50522 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
50523 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
50524 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
50525 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
50526 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
50527 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
50530 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50532 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
50533 MTOP2 = DSQRT(MTOP4)
50534 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
50535 * /(1D0+DELTAMB)**4
50536 MBOT2 = DSQRT(MBOT4)
50538 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
50539 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50540 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50541 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
50542 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
50543 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50544 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50545 * MQ2 - MUR2)**2*0.25D0
50546 * + MTOP2*(AT-XMU/TANBST)**2)
50548 IF(STOP22.LT.0.) GOTO 120
50549 SBOT12 = (MQ2 + MD2)*.5D0
50550 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50551 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50552 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50553 SBOT22 = (MQ2 + MD2)*.5D0
50554 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50555 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50556 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50557 IF(SBOT22.LT.0.) GOTO 120
50560 STOP1 = DSQRT(STOP12)
50561 STOP2 = DSQRT(STOP22)
50562 SBOT1 = DSQRT(SBOT12)
50563 SBOT2 = DSQRT(SBOT22)
50565 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50567 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50570 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
50572 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
50573 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
50575 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
50577 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
50578 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
50580 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
50581 * (-.5D0*LOG(STOP12/STOP22)
50582 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
50583 * G(STOP12,STOP22))
50585 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
50586 * (.5D0*LOG(SBOT12/SBOT22)
50587 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
50588 * G(SBOT12,SBOT22))
50590 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
50591 * (MQ2+MBOT2)/(MD2+MBOT2))
50592 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
50593 * LOG(SBOT1**2/SBOT2**2)) +
50594 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
50595 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
50598 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
50599 * -STOP2**2))**2*G(STOP12,STOP22)
50601 VH3B(1,1)=VH3B(1,1)+
50602 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
50604 VH3T(1,1) = VH3T(1,1) +
50605 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
50607 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
50608 * (MQ2+MTOP2)/(MUR2+MTOP2))
50609 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
50610 * LOG(STOP1**2/STOP2**2)) +
50611 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
50612 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
50615 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
50616 * -SBOT2**2))**2*G(SBOT12,SBOT22)
50618 VH3T(2,2)=VH3T(2,2)+
50619 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
50620 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
50622 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
50623 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
50624 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
50627 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
50628 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
50629 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
50632 VH3T(1,2)=VH3T(1,2) +
50633 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
50635 VH3B(1,2)=VH3B(1,2) +
50636 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
50638 VH3T(2,1) = VH3T(1,2)
50639 VH3B(2,1) = VH3B(1,2)
50641 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
50642 C TU = LOG((MUR2+MTOP2)/MTOP2)
50643 C TQD = LOG((MQ2 + MB**2)/MB**2)
50644 C TD = LOG((MD2+MB**2)/MB**2)
50649 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
50650 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
50651 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
50652 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
50671 C*********************************************************************
50674 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
50676 FUNCTION PYFINT(A,B,C)
50678 C...Double precision and integer declarations.
50679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50680 IMPLICIT INTEGER(I-N)
50681 INTEGER PYK,PYCHGE,PYCOMP
50683 COMMON/PYINTS/XXM(20)
50686 C...Local variables.
50688 DOUBLE PRECISION PYFISB
50695 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
50700 C*********************************************************************
50703 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
50707 C...Double precision and integer declarations.
50708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50709 IMPLICIT INTEGER(I-N)
50710 INTEGER PYK,PYCHGE,PYCOMP
50712 COMMON/PYINTS/XXM(20)
50715 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
50716 &(X*(XXM(2)-XXM(3))+XXM(3)))
50721 C*********************************************************************
50724 C...Calculates decays of sfermions.
50726 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
50728 C...Double precision and integer declarations.
50729 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50730 IMPLICIT INTEGER(I-N)
50731 INTEGER PYK,PYCHGE,PYCOMP
50732 C...Parameter statement to help give large particle numbers.
50733 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50734 &KEXCIT=4000000,KDIMEN=5000000)
50736 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50737 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50738 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50739 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50740 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50741 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50743 C...Local variables.
50744 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
50745 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
50747 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
50748 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50749 DOUBLE PRECISION PYLAMF,XL
50750 DOUBLE PRECISION TANW,XW,AEM,C1,AS
50751 DOUBLE PRECISION AL,AR,BL,BR
50752 DOUBLE PRECISION CH1,CH2,CH3,CH4
50753 DOUBLE PRECISION XMBOT,XMTOP
50754 DOUBLE PRECISION XLAM(0:400)
50755 INTEGER IDLAM(400,3)
50756 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
50757 DOUBLE PRECISION SR2
50758 DOUBLE PRECISION CBETA,SBETA
50759 DOUBLE PRECISION CW
50760 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
50761 DOUBLE PRECISION COSA,SINA,TANB
50762 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
50763 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
50765 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
50766 DATA IGG/23,25,35,36/
50767 DATA PI/3.141592654D0/
50768 DATA SR2/1.4142136D0/
50769 DATA KFNCHI/1000022,1000023,1000025,1000035/
50770 DATA KFCCHI/1000024,1000037/
50772 C...COUNT THE NUMBER OF DECAY MODES
50776 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
50777 &KFIN.EQ.KSUSY2+16) RETURN
50783 TANW = SQRT(XW/(1D0-XW))
50788 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50793 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50794 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50800 C...ILR is 1 for left and 2 for right.
50802 C...IFL is matching non-SUSY flavour.
50803 IFL=MOD(KFIN,KSUSY1)
50804 C...IDU is weak isospin, 1 for down and 2 for up.
50815 XMBOT=PYMRUN(5,XMI2)
50816 XMTOP=PYMRUN(6,XMI2)
50830 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50832 IF(IMSS(11).EQ.1) THEN
50835 XMGR=PMAS(PYCOMP(IDG),1)
50836 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50839 ELSEIF(IFL.EQ.6) THEN
50844 IF(XMI.GT.XMGR+XMF) THEN
50849 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50853 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50855 C...CHARGED DECAYS:
50857 C...DI -> U CHI1-,CHI2-
50861 C...UI -> D CHI1+,CHI2+
50868 IF(XMI.GE.AXMJ+XMFP) THEN
50875 ELSEIF(IFL.LT.6) THEN
50880 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50881 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50887 ELSEIF(IFL.LT.5) THEN
50892 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50893 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50897 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50898 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50899 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50900 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50916 XL=PYLAMF(XMI2,XMA2,XMB2)
50917 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50918 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50919 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50922 IDLAM(LKNT,1)=-KFCCHI(IX)
50923 IDLAM(LKNT,2)=IFL+1
50925 IDLAM(LKNT,1)=KFCCHI(IX)
50926 IDLAM(LKNT,2)=IFL-1
50937 IF(XMI.GE.AXMJ+XMF) THEN
50943 ELSEIF(IFL.LT.5) THEN
50946 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50947 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50948 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50953 ELSEIF(IFL.LT.5) THEN
50956 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50957 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50958 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50962 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50963 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50964 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50965 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50981 XL=PYLAMF(XMI2,XMA2,XMB2)
50982 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50983 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50984 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50985 IDLAM(LKNT,1)=KFNCHI(IX)
50991 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50995 IF(ILR.EQ.1) GOTO 160
50997 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50998 IF(XMI.LT.XMSF1+XMB) GOTO 160
51000 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
51003 ELSEIF(IG.EQ.25) THEN
51006 ELSEIF(IFL.EQ.6) THEN
51008 ELSEIF(IFL.LT.5) THEN
51014 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
51015 & XMF**2/XMW*COSA/SBETA
51016 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
51017 & XMF**2/XMW*COSA/SBETA
51019 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
51020 & XMF**2/XMW*(-SINA)/CBETA
51021 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
51022 & XMF**2/XMW*(-SINA)/CBETA
51026 ELSEIF(IFL.EQ.6) THEN
51028 ELSEIF(IFL.EQ.15) THEN
51033 C.........need to complexify
51035 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
51038 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
51044 ELSEIF(IG.EQ.35) THEN
51047 ELSEIF(IFL.EQ.6) THEN
51049 ELSEIF(IFL.LT.5) THEN
51055 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
51056 & XMF**2/XMW*SINA/SBETA
51057 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
51058 & XMF**2/XMW*SINA/SBETA
51060 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
51061 & XMF**2/XMW*COSA/CBETA
51062 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
51063 & XMF**2/XMW*COSA/CBETA
51067 ELSEIF(IFL.EQ.6) THEN
51069 ELSEIF(IFL.EQ.15) THEN
51074 C.........Need to complexify
51076 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
51079 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
51085 ELSEIF(IG.EQ.36) THEN
51090 ELSEIF(IFL.EQ.6) THEN
51092 ELSEIF(IFL.LT.5) THEN
51099 ELSEIF(IFL.EQ.6) THEN
51101 ELSEIF(IFL.EQ.15) THEN
51106 C.........Need to complexify
51108 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
51110 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
51116 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
51117 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
51118 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
51119 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51122 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51124 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
51127 IDLAM(LKNT,1)=KFIN-KSUSY1
51133 IF(MOD(IFL,2).EQ.0) THEN
51139 XMSF1=PMAS(PYCOMP(KF1),1)
51140 XMSF2=PMAS(PYCOMP(KF2),1)
51141 IF(XMI.GT.XMB+XMSF1) THEN
51142 IF(MOD(IFL,2).EQ.0) THEN
51144 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
51146 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
51150 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
51152 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
51155 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51157 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51160 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
51162 IF(XMI.GT.XMB+XMSF2) THEN
51163 IF(MOD(IFL,2).EQ.0) THEN
51165 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
51167 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
51171 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
51173 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
51176 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
51178 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51181 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
51186 IF(MOD(IFL,2).EQ.0) THEN
51192 XMSF1=PMAS(PYCOMP(KF1),1)
51193 XMSF2=PMAS(PYCOMP(KF2),1)
51194 IF(XMI.GT.XMB+XMSF1) THEN
51199 IF(MOD(IFL,2).EQ.0) THEN
51202 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
51203 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
51204 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
51205 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
51208 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
51209 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
51210 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
51211 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
51222 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
51223 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
51224 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
51225 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
51228 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
51229 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
51230 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
51231 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
51240 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51242 C.......Need to complexify
51243 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
51244 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
51245 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
51246 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
51249 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
51251 IF(XMI.GT.XMB+XMSF2) THEN
51256 IF(MOD(IFL,2).EQ.0) THEN
51259 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
51260 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
51261 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
51262 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
51265 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
51266 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
51267 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
51268 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
51279 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
51280 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
51281 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
51282 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
51285 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
51286 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
51287 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
51288 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
51297 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51299 C.......Need to complexify
51300 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
51301 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
51302 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
51303 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
51306 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
51309 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
51314 IF(IFL.EQ.6) XMF=PMAS(6,1)
51315 IF(IFL.EQ.5) XMF=PMAS(5,1)
51316 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51318 IF(XMI.GE.AXMJ+XMF) THEN
51335 XL=PYLAMF(XMI2,XMA2,XMB2)
51336 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
51337 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
51338 IDLAM(LKNT,1)=KSUSY1+21
51344 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
51345 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
51346 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
51347 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
51348 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
51349 C...M*M = C1**2 * G**2/(16PI**2)
51350 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
51352 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
51353 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
51354 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
51355 IDLAM(LKNT,1)=KSUSY1+22
51360 C...R-violating sfermion decays (SKANDS).
51361 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
51366 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51367 XLAM(0)=XLAM(0)+XLAM(I)
51369 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
51374 C*********************************************************************
51377 C...Calculates gluino decay modes.
51379 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
51381 C...Double precision and integer declarations.
51382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51383 IMPLICIT INTEGER(I-N)
51384 INTEGER PYK,PYCHGE,PYCOMP
51385 C...Parameter statement to help give large particle numbers.
51386 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51387 &KEXCIT=4000000,KDIMEN=5000000)
51389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51391 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51392 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51393 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51395 C COMMON/PYINTS/XXM(20)
51397 COMMON/PYINTC/XXC(10),CXC(8)
51398 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51400 C...Local variables
51401 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51402 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
51403 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
51404 DOUBLE PRECISION PYLAMF,XL
51405 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
51406 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
51407 DOUBLE PRECISION XLAM(0:400)
51408 INTEGER IDLAM(400,3)
51409 INTEGER LKNT,IX,ILR,I,IKNT,IFL
51410 DOUBLE PRECISION SR2
51411 DOUBLE PRECISION GAM
51412 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
51413 EXTERNAL PYGAUS,PYXXZ6
51414 DOUBLE PRECISION PYGAUS,PYXXZ6
51415 DOUBLE PRECISION PREC
51416 INTEGER KFNCHI(4),KFCCHI(2)
51417 DATA PI/3.141592654D0/
51418 DATA SR2/1.4142136D0/
51420 DATA KFNCHI/1000022,1000023,1000025,1000035/
51421 DATA KFCCHI/1000024,1000037/
51423 C...COUNT THE NUMBER OF DECAY MODES
51425 IF(KFIN.NE.KSUSY1+21) RETURN
51429 TANW = SQRT(XW/(1D0-XW))
51439 XMI=SIGN(XMI,RMSS(3))
51441 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
51443 IF(IMSS(11).EQ.1) THEN
51446 XMGR=PMAS(PYCOMP(IDG),1)
51447 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51448 IF(AXMI.GT.XMGR) THEN
51457 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
51461 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
51464 IF(AXMI.GE.AXMJ+XMF) THEN
51465 C...Minus sign difference from gluino-quark-squark feynman rules
51482 XL=PYLAMF(XMI2,XMA2,XMB2)
51483 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
51484 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
51485 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
51489 XLAM(LKNT)=XLAM(LKNT-1)
51490 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51491 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51497 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
51498 C...GLUINO -> NI Q QBAR
51502 IF(AXMI.GE.AXMJ) THEN
51504 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
51506 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
51513 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51514 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
51520 T3I=SIGN(1D0,EI+1D-6)/2D0
51521 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51522 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51526 CXC(4)=DCONJG(GLIJ)
51530 CXC(8)=-DCONJG(GRIJ)
51532 S12MAX=(AXMI-AXMJ)**2
51533 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
51534 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51536 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
51537 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
51538 IDLAM(LKNT,1)=KFNCHI(IX)
51542 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51544 XLAM(LKNT)=XLAM(LKNT-1)
51545 IDLAM(LKNT,1)=KFNCHI(IX)
51550 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51551 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
51552 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
51554 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
51555 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
51557 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
51560 IDLAM(LKNT,1)=KFNCHI(IX)
51563 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
51568 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51569 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
51570 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
51574 T3I=SIGN(1D0,EI+1D-6)/2D0
51575 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51576 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51578 CXC(4)=DCONJG(GLIJ)
51580 CXC(8)=-DCONJG(GRIJ)
51581 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
51582 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51584 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
51585 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
51586 IDLAM(LKNT,1)=KFNCHI(IX)
51590 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51592 XLAM(LKNT)=XLAM(LKNT-1)
51593 IDLAM(LKNT,1)=KFNCHI(IX)
51598 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
51599 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
51601 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
51602 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
51603 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
51605 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
51606 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
51608 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
51611 IDLAM(LKNT,1)=KFNCHI(IX)
51614 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
51620 C...GLUINO -> CI Q QBAR'
51624 IF(AXMI.GE.AXMJ) THEN
51626 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
51627 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
51630 S12MAX=(AXMI-AXMJ)**2
51635 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51636 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51639 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51641 CXC(1)=DCMPLX(0D0,0D0)
51642 CXC(3)=DCMPLX(0D0,0D0)
51643 CXC(5)=DCMPLX(0D0,0D0)
51644 CXC(7)=DCMPLX(0D0,0D0)
51645 CXC(2)=UMIXC(IX,1)*OLPP/SR2
51646 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51647 CXC(6)=DCMPLX(0D0,0D0)
51648 CXC(8)=DCMPLX(0D0,0D0)
51649 IF(XXC(5).LT.AXMI) THEN
51651 ELSEIF(XXC(6).LT.AXMI) THEN
51656 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
51657 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51659 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51660 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51661 IDLAM(LKNT,1)=KFCCHI(IX)
51665 XLAM(LKNT)=XLAM(LKNT-1)
51666 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51667 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51668 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51670 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51672 XLAM(LKNT)=XLAM(LKNT-1)
51673 IDLAM(LKNT,1)=KFCCHI(IX)
51677 XLAM(LKNT)=XLAM(LKNT-1)
51678 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51679 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51680 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51686 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
51687 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
51688 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
51689 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
51690 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
51691 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
51692 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
51693 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
51694 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
51695 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
51696 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
51697 CALL PYTBBC(IX,100,XMI,GAM)
51700 IDLAM(LKNT,1)=KFCCHI(IX)
51704 XLAM(LKNT)=XLAM(LKNT-1)
51705 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51706 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51707 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51708 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
51709 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
51710 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
51711 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
51717 C...R-parity violating (3-body) decays.
51718 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
51723 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51724 XLAM(0)=XLAM(0)+XLAM(I)
51726 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51732 C*********************************************************************
51735 C...Calculates the three-body decay of gluinos into
51736 C...neutralinos and third generation fermions.
51738 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
51740 C...Double precision and integer declarations.
51741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51742 IMPLICIT INTEGER(I-N)
51743 INTEGER PYK,PYCHGE,PYCOMP
51744 C...Parameter statement to help give large particle numbers.
51745 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51746 &KEXCIT=4000000,KDIMEN=5000000)
51748 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51749 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51750 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51751 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51752 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51753 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51755 C...Local variables.
51756 EXTERNAL PYSIMP,PYLAMF
51757 DOUBLE PRECISION PYSIMP,PYLAMF
51759 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
51760 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
51761 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
51762 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
51763 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
51764 DOUBLE PRECISION XLN1,XLN2,B1,B2
51765 DOUBLE PRECISION E,XMGLU,GAM
51766 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
51767 SAVE HRB,HLB,FLB,FRB
51768 DOUBLE PRECISION ALPHAW,ALPHAS
51769 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
51770 SAVE HLT,HRT,FLT,FRT
51771 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
51773 DOUBLE PRECISION AMBOT,SINC,COSC
51774 DOUBLE PRECISION AMTOP,SINA,COSA
51775 DOUBLE PRECISION SINW,COSW,TANW
51776 DOUBLE PRECISION ROT1(4,4)
51779 DATA IFIRST/.TRUE./
51782 SINB=TANB/SQRT(1D0+TANB**2)
51793 AMBOT=PYMRUN(5,XMGLU**2)
51794 AMTOP=PYMRUN(6,XMGLU**2)
51796 FAKT1=AMBOT/W2/AMW/COSB
51797 FAKT2=AMTOP/W2/AMW/SINB
51808 ROT1(2,1)=-ROT1(1,2)
51809 ROT1(2,2)=ROT1(1,1)
51812 ROT1(4,3)=-ROT1(3,4)
51813 ROT1(4,4)=ROT1(3,3)
51817 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51822 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51823 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51824 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51826 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51827 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51828 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51829 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51832 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51833 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51834 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51835 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51836 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51837 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51838 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51842 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51843 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51844 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51845 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51849 IF(NINT(3D0*E).EQ.2) THEN
51856 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51857 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51866 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51867 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51873 SIN2D=SIND*COSD*2D0
51887 ALPHAW=PYALEM(XMG2)
51888 ALPHAS=PYALPS(XMG2)
51892 XM24=(XMG2+XM2)*(XM2+XMR2)
51894 SMAX=(XMG-ABS(XMR))**2
51895 XMQA=XMG2+2D0*XM2+XMR2
51897 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51899 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51901 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51902 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51903 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51904 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51905 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51906 & +2D0*(FF*SIND2-HH*COSD2))*W
51907 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51908 & +4D0*HFL*XM*XMR)*XLN1
51909 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51910 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51911 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51912 & +8D0*HFL*XMQ4*SIN2D)*B1
51913 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51914 & +4D0*HFR*XMR*XM)*XLN2
51915 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51916 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51917 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51918 & -8D0*HFR*XMQ4*SIN2D)*B2
51919 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51920 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51921 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51922 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51923 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51924 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51925 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51926 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51927 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51928 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51929 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51930 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51931 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51932 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51933 & +COS2D*XM*(SBAR+XMG2-XMR2))
51934 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51935 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51936 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51937 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51938 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51939 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51940 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51943 SUMME(LIN)=SUMME(LIN)+G(J)
51948 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51949 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51954 C*********************************************************************
51957 C...Calculates the three-body decay of gluinos into
51958 C...charginos and third generation fermions.
51960 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51962 C...Double precision and integer declarations.
51963 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51964 IMPLICIT INTEGER(I-N)
51965 INTEGER PYK,PYCHGE,PYCOMP
51966 C...Parameter statement to help give large particle numbers.
51967 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51968 &KEXCIT=4000000,KDIMEN=5000000)
51970 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51971 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51972 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51973 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51974 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51975 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51977 C...Local variables.
51978 EXTERNAL PYSIMP,PYLAMF
51979 DOUBLE PRECISION PYSIMP,PYLAMF
51981 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51982 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51983 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51984 DOUBLE PRECISION SUMME(0:100),A(4,8)
51985 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51986 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51987 DOUBLE PRECISION XMGLU,GAM
51988 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51989 &DDD(2),EEE(2),FFF(2)
51990 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51991 DOUBLE PRECISION ALPHAW,ALPHAS
51992 DOUBLE PRECISION AMC(2)
51994 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51995 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51999 DATA IFIRST/.TRUE./
52002 SINB=TANB/SQRT(1D0+TANB**2)
52010 AMBOT=PYMRUN(5,XMGLU**2)
52011 AMTOP=PYMRUN(6,XMGLU**2)
52014 FAKT1=AMBOT/W2/AMW/COSB
52015 FAKT2=AMTOP/W2/AMW/SINB
52020 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
52021 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
52022 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
52023 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
52024 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
52025 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
52026 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
52027 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
52029 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
52030 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
52031 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
52032 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
52036 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
52037 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
52038 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
52039 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
52041 COS2A=COSA**2-SINA**2
52042 SIN2A=SINA*COSA*2D0
52043 COS2C=COSC**2-SINC**2
52044 SIN2C=SINC*COSC*2D0
52051 ALPHAW=PYALEM(XMG2)
52052 ALPHAS=PYALPS(XMG2)
52056 XMQ2=XMG2+XMT2+XMB2+XMR2
52057 XMQ4=XMG*XMT*XMB*XMR
52058 XMQ3=XMG2*XMR2+XMT2*XMB2
52059 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
52060 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
52062 XMST(1)=AMST(1)*AMST(1)
52063 XMST(2)=AMST(1)*AMST(1)
52064 XMST(3)=AMST(2)*AMST(2)
52065 XMST(4)=AMST(2)*AMST(2)
52066 XMSB(1)=AMSB(1)*AMSB(1)
52067 XMSB(2)=AMSB(2)*AMSB(2)
52068 XMSB(3)=AMSB(1)*AMSB(1)
52069 XMSB(4)=AMSB(2)*AMSB(2)
52071 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
52072 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
52073 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
52074 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
52075 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
52076 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
52077 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
52078 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
52080 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
52081 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
52082 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
52083 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
52084 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
52085 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
52086 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
52087 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
52089 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
52090 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
52091 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
52092 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
52093 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
52094 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
52095 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
52096 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
52098 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
52099 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
52100 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
52101 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
52102 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
52103 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
52104 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
52105 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
52107 SMAX=(XMG-ABS(XMR))**2
52108 SMIN=(XMB+XMT)**2+0.1D0
52111 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
52112 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
52114 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
52115 W=DSQRT(W)/2D0/SBAR
52116 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
52117 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
52118 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
52119 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
52120 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
52121 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
52122 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
52123 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
52124 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
52125 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
52126 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
52127 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
52128 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
52129 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
52130 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
52131 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
52132 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
52133 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
52134 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
52135 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
52136 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
52137 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
52138 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
52139 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
52140 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
52141 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
52142 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
52143 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
52144 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
52145 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
52146 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
52147 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
52148 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
52149 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
52150 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
52151 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
52152 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
52153 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
52154 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
52155 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
52156 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
52157 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
52158 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
52160 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
52161 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
52162 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
52163 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
52164 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
52165 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
52166 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
52167 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
52168 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
52169 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
52170 & -A(J,6)*(XMG2+XMR2-SBAR)
52171 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
52172 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
52173 & /(GRS+XMSB(J)+XMST(J))
52177 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
52178 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
52183 C*********************************************************************
52186 C...Calculates decay widths for the neutralinos (admixtures of
52187 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
52189 C...Input: KCIN = KF code for particle
52190 C...Output: XLAM = widths
52191 C... IDLAM = KF codes for decay particles
52192 C... IKNT = number of decay channels defined
52193 C...AUTHOR: STEPHEN MRENNA
52195 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
52196 C...when CHIGAMMA .NE. 0
52197 C...10 FEB 96: Calculate this decay for small tan(beta)
52199 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
52201 C...Double precision and integer declarations.
52202 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52203 IMPLICIT INTEGER(I-N)
52204 INTEGER PYK,PYCHGE,PYCOMP
52205 C...Parameter statement to help give large particle numbers.
52206 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52207 &KEXCIT=4000000,KDIMEN=5000000)
52209 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52210 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52211 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52212 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52214 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52215 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52216 C COMMON/PYINTS/XXM(20)
52218 COMMON/PYINTC/XXC(10),CXC(8)
52219 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52221 C...Local variables.
52222 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
52223 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
52225 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52226 &XMZ,XMZ2,AXMJ,AXMI
52227 DOUBLE PRECISION S12MIN,S12MAX
52228 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
52229 DOUBLE PRECISION PYLAMF,XL
52230 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
52231 DOUBLE PRECISION PYX2XH,PYX2XG
52232 DOUBLE PRECISION XLAM(0:400)
52233 INTEGER IDLAM(400,3)
52234 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
52235 INTEGER ITH(3),KF1,KF2
52237 DOUBLE PRECISION DH(3),EH(3)
52238 DOUBLE PRECISION SR2
52239 DOUBLE PRECISION CBETA,SBETA
52240 DOUBLE PRECISION GAMCON,XMT1,XMT2
52241 DOUBLE PRECISION PYALEM,PI,PYALPS
52242 DOUBLE PRECISION RAT1,RAT2
52243 DOUBLE PRECISION T3T,FCOL
52244 DOUBLE PRECISION ALFA,BETA,TANB
52245 DOUBLE PRECISION PYXXGA
52246 EXTERNAL PYGAUS,PYXXZ6
52247 DOUBLE PRECISION PYGAUS,PYXXZ6
52248 DOUBLE PRECISION PREC
52249 INTEGER KFNCHI(4),KFCCHI(2)
52253 DATA PI/3.141592654D0/
52254 DATA SR2/1.4142136D0/
52255 DATA KFNCHI/1000022,1000023,1000025,1000035/
52256 DATA KFCCHI/1000024,1000037/
52258 C...COUNT THE NUMBER OF DECAY MODES
52267 TANW = SQRT(XW/XW1)
52269 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
52271 IF(KFIN.EQ.KFNCHI(2)) IX=2
52272 IF(KFIN.EQ.KFNCHI(3)) IX=3
52273 IF(KFIN.EQ.KFNCHI(4)) IX=4
52293 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52298 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52299 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52303 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52304 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
52306 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
52307 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
52311 GAMCON=AEM**3/8D0/PI/XMW2/XW
52312 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
52313 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
52314 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
52315 IDLAM(LKNT,1)=KSUSY1+22
52318 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
52322 C...GRAVITINO DECAY MODES
52324 IF(IMSS(11).EQ.1) THEN
52327 XMGR=PMAS(PYCOMP(IDG),1)
52330 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52331 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
52336 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
52338 IF(AXMI.GT.XMGR+XMZ) THEN
52343 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
52344 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
52345 & (1D0-XMZ2/XMI2)**4
52347 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
52352 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
52353 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
52355 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
52360 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
52361 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
52363 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
52368 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
52369 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
52371 IF(IX.EQ.1) GOTO 300
52379 C...CHI0_I -> CHI0_J + GAMMA
52380 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
52381 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
52382 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
52383 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
52384 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
52385 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
52386 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
52388 IDLAM(LKNT,1)=KFNCHI(IJ)
52391 GAMCON=AEM**3/8D0/PI/XMW2/XW
52392 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
52393 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
52394 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
52398 C...CHI0_I -> CHI0_J + Z0
52399 IF(AXMI.GE.AXMJ+XMZ) THEN
52401 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
52402 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
52404 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52405 GLR=DBLE(OLPP*DCONJG(ORPP))
52406 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52407 IDLAM(LKNT,1)=KFNCHI(IJ)
52410 ELSEIF(AXMI.GE.AXMJ) THEN
52417 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
52418 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
52420 C...CHARGED LEPTONS
52422 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52423 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52425 T3I=SIGN(1D0,EI+1D-6)/2D0
52426 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52427 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52428 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52429 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52431 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52432 CXC(4)=DCONJG(GLIJ)
52433 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52435 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52436 CXC(8)=-DCONJG(GRIJ)
52438 S12MAX=(AXMI-AXMJ)**2
52439 IF( XXC(5).LT.AXMI ) THEN
52442 IF(XXC(6).LT.AXMI ) THEN
52448 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52450 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52451 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52452 IDLAM(LKNT,1)=KFNCHI(IJ)
52455 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52457 XLAM(LKNT)=XLAM(LKNT-1)
52458 IDLAM(LKNT,1)=KFNCHI(IJ)
52464 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52465 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52466 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52468 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52469 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52471 IF( XXC(5).LT.AXMI ) THEN
52474 IF(XXC(6).LT.AXMI ) THEN
52480 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52482 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52483 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52484 IDLAM(LKNT,1)=KFNCHI(IJ)
52492 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52493 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52495 T3I=SIGN(1D0,EI+1D-6)/2D0
52496 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52497 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52498 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52499 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52501 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52502 CXC(4)=DCONJG(GLIJ)
52503 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52505 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52506 CXC(8)=-DCONJG(GRIJ)
52508 S12MAX=(AXMI-AXMJ)**2
52509 IF( XXC(5).LT.AXMI ) THEN
52512 IF( XXC(6).LT.AXMI ) THEN
52519 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52520 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52521 IDLAM(LKNT,1)=KFNCHI(IJ)
52525 XLAM(LKNT)=XLAM(LKNT-1)
52526 IDLAM(LKNT,1)=KFNCHI(IJ)
52531 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
52533 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52534 IF( XXC(5).LT.AXMI ) THEN
52539 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52540 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52543 XLAM(LKNT)=XLAM(LKNT-1)
52545 IDLAM(LKNT,1)=KFNCHI(IJ)
52551 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52552 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52554 T3I=SIGN(1D0,EI+1D-6)/2D0
52555 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52556 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52557 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52558 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52560 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52561 CXC(4)=DCONJG(GLIJ)
52562 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52564 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52565 CXC(8)=-DCONJG(GRIJ)
52567 S12MAX=(AXMI-AXMJ)**2
52568 IF( XXC(5).LT.AXMI ) THEN
52571 IF( XXC(6).LT.AXMI ) THEN
52577 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52579 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52580 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52581 IDLAM(LKNT,1)=KFNCHI(IJ)
52584 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52586 XLAM(LKNT)=XLAM(LKNT-1)
52587 IDLAM(LKNT,1)=KFNCHI(IJ)
52593 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52594 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52595 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52597 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52598 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52600 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52601 IF(XXC(5).LT.AXMI) THEN
52603 ELSEIF(XXC(6).LT.AXMI) THEN
52608 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52610 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52611 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52612 IDLAM(LKNT,1)=KFNCHI(IJ)
52620 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52621 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52623 T3I=SIGN(1D0,EI+1D-6)/2D0
52624 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52625 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52626 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52627 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52629 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52630 CXC(4)=DCONJG(GLIJ)
52631 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52633 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52634 CXC(8)=-DCONJG(GRIJ)
52636 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
52637 IF(XXC(5).LT.AXMI) THEN
52639 ELSEIF(XXC(6).LT.AXMI) THEN
52645 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52647 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52648 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52649 IDLAM(LKNT,1)=KFNCHI(IJ)
52652 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52654 XLAM(LKNT)=XLAM(LKNT-1)
52655 IDLAM(LKNT,1)=KFNCHI(IJ)
52663 C...CHI0_I -> CHI0_J + H0_K
52670 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
52671 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
52672 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
52673 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
52674 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
52675 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
52676 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
52677 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
52679 XMH=PMAS(ITH(IH),1)
52681 IF(AXMI.GE.AXMJ+XMH) THEN
52683 XL=PYLAMF(XMI2,XMJ2,XMH2)
52684 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
52686 C...SIGN OF MASSES I,J
52688 IF(IH.EQ.3) XMK=-XMK
52689 GX2=ABS(F21K)**2+ABS(F12K)**2
52690 GLR=DBLE(F21K*DCONJG(F12K))
52691 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52692 IDLAM(LKNT,1)=KFNCHI(IJ)
52693 IDLAM(LKNT,2)=ITH(IH)
52699 C...CHI0_I -> CHI+_J + W-
52704 IF(AXMI.GE.AXMJ+XMW) THEN
52706 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
52707 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
52708 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
52709 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
52710 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52711 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52712 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52713 IDLAM(LKNT,1)=KFCCHI(IJ)
52717 XLAM(LKNT)=XLAM(LKNT-1)
52718 IDLAM(LKNT,1)=-KFCCHI(IJ)
52721 ELSEIF(AXMI.GE.AXMJ) THEN
52723 S12MAX=(AXMI-AXMJ)**2
52724 RT2I = 1D0/SQRT(2D0)
52725 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
52726 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
52727 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
52728 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
52729 CXC(5)=DCMPLX(0D0,0D0)
52730 CXC(7)=DCMPLX(0D0,0D0)
52734 T3I=SIGN(1D0,EI+1D-6)/2D0
52736 T3J=SIGN(1D0,EJ+1D-6)/2D0
52737 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52738 & TANW+ZMIXC(IX,2)*T3J)*RT2I
52739 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52740 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
52741 CXC(6)=DCMPLX(0D0,0D0)
52742 CXC(8)=DCMPLX(0D0,0D0)
52747 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52748 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52751 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
52752 IF(XXC(5).LT.AXMI) THEN
52754 ELSEIF(XXC(6).LT.AXMI) THEN
52759 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52761 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52762 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52763 IDLAM(LKNT,1)=KFCCHI(IJ)
52767 XLAM(LKNT)=XLAM(LKNT-1)
52768 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52769 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52770 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52771 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52773 XLAM(LKNT)=XLAM(LKNT-1)
52774 IDLAM(LKNT,1)=KFCCHI(IJ)
52778 XLAM(LKNT)=XLAM(LKNT-1)
52779 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52780 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52781 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52785 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52786 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52787 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
52789 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52790 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
52792 IF(XXC(5).LT.AXMI) THEN
52795 IF(XXC(6).LT.AXMI) THEN
52800 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52802 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52803 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52804 XLAM(LKNT)=XLAM(LKNT-1)
52805 IDLAM(LKNT,1)=KFCCHI(IJ)
52809 XLAM(LKNT)=XLAM(LKNT-1)
52810 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52811 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52812 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52815 C...NOW, DO THE QUARKS
52820 T3I=SIGN(1D0,EI+1D-6)/2D0
52822 T3J=SIGN(1D0,EJ+1D-6)/2D0
52823 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52824 & TANW+ZMIXC(IX,2)*T3J)
52825 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52826 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52827 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52828 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52829 IF(XXC(5).LT.AXMI) THEN
52832 IF(XXC(6).LT.AXMI) THEN
52837 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52839 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52840 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52841 IDLAM(LKNT,1)=KFCCHI(IJ)
52845 XLAM(LKNT)=XLAM(LKNT-1)
52846 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52847 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52848 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52849 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52851 XLAM(LKNT)=XLAM(LKNT-1)
52852 IDLAM(LKNT,1)=KFCCHI(IJ)
52856 XLAM(LKNT)=XLAM(LKNT-1)
52857 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52858 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52859 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52867 C...CHI0_I -> CHI+_I + H-
52873 IF(AXMI.GE.AXMJ+XMHP) THEN
52875 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52876 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52877 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52878 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52880 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52881 GLR=DBLE(OLPP*DCONJG(ORPP))
52882 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52883 IDLAM(LKNT,1)=KFCCHI(IJ)
52884 IDLAM(LKNT,2)=-ITHC
52887 XLAM(LKNT)=XLAM(LKNT-1)
52888 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52889 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52890 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52896 C...2-BODY DECAYS TO FERMION SFERMION
52898 IF(J.GE.7.AND.J.LE.10) GOTO 290
52901 XMSF1=PMAS(PYCOMP(KF1),1)
52902 XMSF2=PMAS(PYCOMP(KF2),1)
52912 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52913 IF(MOD(J,2).EQ.0) THEN
52914 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52915 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52916 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52919 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52920 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52921 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52926 IF(AXMI.GE.XMF+XMSF1) THEN
52930 XL=PYLAMF(XMI2,XMA2,XMB2)
52931 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52932 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52933 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52934 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52939 XLAM(LKNT)=XLAM(LKNT-1)
52940 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52941 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52946 IF(AXMI.GE.XMF+XMSF2) THEN
52950 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52951 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52952 XL=PYLAMF(XMI2,XMA2,XMB2)
52953 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52954 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52959 XLAM(LKNT)=XLAM(LKNT-1)
52960 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52961 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52966 C...3-BODY DECAY TO Q Q~ GLUINO
52967 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52968 IF(AXMI.GE.XMJ) THEN
52969 RT2I = 1D0/SQRT(2D0)
52970 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52978 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52979 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52985 T3I=SIGN(1D0,EI+1D-6)/2D0
52986 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52987 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52991 CXC(4)=DCONJG(GLIJ)
52995 CXC(8)=-DCONJG(GRIJ)
52997 S12MAX=(AXMI-AXMJ)**2
52998 CMRENNA.This statement must be here to define S12MAX
52999 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
53000 C...ALL QUARKS BUT T
53001 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
53003 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
53004 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53005 IDLAM(LKNT,1)=KSUSY1+21
53008 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
53010 XLAM(LKNT)=XLAM(LKNT-1)
53011 IDLAM(LKNT,1)=KSUSY1+21
53017 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
53018 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
53019 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
53021 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
53022 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
53024 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
53027 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
53029 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
53030 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53031 IDLAM(LKNT,1)=KSUSY1+21
53038 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
53039 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
53040 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
53044 T3I=SIGN(1D0,EI+1D-6)/2D0
53045 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
53046 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
53048 CXC(4)=DCONJG(GLIJ)
53050 CXC(8)=-DCONJG(GRIJ)
53051 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
53053 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
53054 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53055 IDLAM(LKNT,1)=KSUSY1+21
53058 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
53060 XLAM(LKNT)=XLAM(LKNT-1)
53061 IDLAM(LKNT,1)=KSUSY1+21
53069 C...R-violating decay modes (SKANDS).
53070 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
53075 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
53076 XLAM(0)=XLAM(0)+XLAM(I)
53078 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53083 C*********************************************************************
53086 C...Calculate decay widths for the charginos (admixtures of
53087 C...charged Wino and charged Higgsino.
53089 C...Input: KCIN = KF code for particle
53090 C...Output: XLAM = widths
53091 C... IDLAM = KF codes for decay particles
53092 C... IKNT = number of decay channels defined
53093 C...AUTHOR: STEPHEN MRENNA
53095 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
53096 C...when CHIENU .NE. 0
53098 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
53100 C...Double precision and integer declarations.
53101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53102 IMPLICIT INTEGER(I-N)
53103 INTEGER PYK,PYCHGE,PYCOMP
53104 C...Parameter statement to help give large particle numbers.
53105 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53106 &KEXCIT=4000000,KDIMEN=5000000)
53108 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53109 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53110 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53111 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53112 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53114 C COMMON/PYINTS/XXM(20)
53116 COMMON/PYINTC/XXC(10),CXC(8)
53117 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
53119 C...Local variables
53120 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53121 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
53123 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
53124 &XMZ,XMZ2,AXMJ,AXMI
53125 DOUBLE PRECISION S12MIN,S12MAX
53126 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
53127 DOUBLE PRECISION PYLAMF,XL
53128 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
53129 DOUBLE PRECISION PYX2XH,PYX2XG
53130 DOUBLE PRECISION XLAM(0:400)
53131 INTEGER IDLAM(400,3)
53132 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
53135 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
53136 DOUBLE PRECISION SR2
53137 DOUBLE PRECISION CBETA,SBETA,TANB
53139 DOUBLE PRECISION PYALEM,PI,PYALPS
53140 DOUBLE PRECISION FCOL
53141 INTEGER KF1,KF2,ISF
53142 INTEGER KFNCHI(4),KFCCHI(2)
53144 DOUBLE PRECISION TEMP
53145 EXTERNAL PYGAUS,PYXXZ6
53146 DOUBLE PRECISION PYGAUS,PYXXZ6
53147 DOUBLE PRECISION PREC
53150 DATA ETAH/1D0,1D0,-1D0/
53151 DATA SR2/1.4142136D0/
53152 DATA PI/3.141592654D0/
53154 DATA KFNCHI/1000022,1000023,1000025,1000035/
53155 DATA KFCCHI/1000024,1000037/
53157 C...COUNT THE NUMBER OF DECAY MODES
53165 TANW = SQRT(XW/XW1)
53167 C...1 OR 2 DEPENDING ON CHARGINO TYPE
53169 IF(KFIN.EQ.KFCCHI(2)) IX=2
53187 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53188 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53192 C...GRAVITINO DECAY MODES
53194 IF(IMSS(11).EQ.1) THEN
53197 XMGR=PMAS(PYCOMP(IDG),1)
53199 C COSW=SQRT(1D0-XW)
53200 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
53201 IF(AXMI.GT.XMGR+XMW) THEN
53207 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
53208 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
53209 & (1D0-XMW2/XMI2)**4
53211 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
53216 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
53217 & (ABS(UMIXC(IX,2))*SBETA)**2))
53218 & *(1D0-PMAS(37,1)**2/XMI2)**4
53222 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53223 IF(IX.EQ.1) GOTO 170
53228 C...CHI_2+ -> CHI_1+ + Z0
53229 IF(AXMI.GE.AXMJ+XMZ) THEN
53232 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
53233 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
53234 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
53235 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
53236 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53237 GLR=DBLE(OLPP*DCONJG(ORPP))
53238 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
53239 IDLAM(LKNT,1)=KFCCHI(1)
53243 C...CHARGED LEPTONS
53244 ELSEIF(AXMI.GE.AXMJ) THEN
53246 S12MAX=(AXMI-AXMJ)**2
53249 EI=KCHG(IABS(IA),1)/3D0
53250 T3I=SIGN(1D0,EI+1D-6)/2D0
53255 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53260 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
53261 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
53262 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
53263 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
53264 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53265 CXC(2)=DCMPLX(0D0,0D0)
53266 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53267 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
53268 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53269 CXC(6)=DCMPLX(0D0,0D0)
53270 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53271 CXC(8)=DCMPLX(0D0,0D0)
53272 IF( XXC(5).LT.AXMI ) THEN
53277 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
53279 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53280 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53281 IDLAM(LKNT,1)=KFCCHI(1)
53284 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
53286 XLAM(LKNT)=XLAM(LKNT-1)
53287 IDLAM(LKNT,1)=KFCCHI(1)
53291 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
53293 XLAM(LKNT)=XLAM(LKNT-1)
53294 IDLAM(LKNT,1)=KFCCHI(1)
53304 EI=KCHG(IABS(IA),1)/3D0
53305 T3I=SIGN(1D0,EI+1D-6)/2D0
53306 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53308 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53309 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53310 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
53311 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53312 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53313 IF( XXC(5).LT.AXMI ) THEN
53318 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
53320 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53321 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53322 IDLAM(LKNT,1)=KFCCHI(1)
53326 XLAM(LKNT)=XLAM(LKNT-1)
53327 IDLAM(LKNT,1)=KFCCHI(1)
53331 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
53332 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
53333 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
53335 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
53337 IF( XXC(5).LT.AXMI ) THEN
53342 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53343 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53344 IDLAM(LKNT,1)=KFCCHI(1)
53353 EI=KCHG(IABS(IA),1)/3D0
53354 T3I=SIGN(1D0,EI+1D-6)/2D0
53355 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53357 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53358 CXC(2)=DCMPLX(0D0,0D0)
53359 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53360 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
53361 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53362 CXC(6)=DCMPLX(0D0,0D0)
53363 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53364 CXC(8)=DCMPLX(0D0,0D0)
53365 IF( XXC(5).LT.AXMI ) THEN
53370 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
53372 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53373 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53374 IDLAM(LKNT,1)=KFCCHI(1)
53377 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
53379 XLAM(LKNT)=XLAM(LKNT-1)
53380 IDLAM(LKNT,1)=KFCCHI(1)
53385 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
53386 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
53387 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
53389 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
53391 IF( XXC(5).LT.AXMI ) THEN
53396 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53397 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53398 IDLAM(LKNT,1)=KFCCHI(1)
53407 EI=KCHG(IABS(IA),1)/3D0
53408 T3I=SIGN(1D0,EI+1D-6)/2D0
53409 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53411 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53412 CXC(2)=DCMPLX(0D0,0D0)
53413 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53414 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
53415 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53416 CXC(6)=DCMPLX(0D0,0D0)
53417 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53418 CXC(8)=DCMPLX(0D0,0D0)
53419 IF( XXC(5).LT.AXMI ) THEN
53424 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
53426 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53427 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53428 IDLAM(LKNT,1)=KFCCHI(1)
53431 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
53433 XLAM(LKNT)=XLAM(LKNT-1)
53434 IDLAM(LKNT,1)=KFCCHI(1)
53442 C...CHI_2+ -> CHI_1+ + H0_K
53450 XMH=PMAS(ITH(IH),1)
53452 C...NO 3-BODY OPTION
53453 IF(AXMI.GE.AXMJ+XMH) THEN
53455 XL=PYLAMF(XMI2,XMJ2,XMH2)
53456 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
53457 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
53458 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
53459 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
53461 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53462 GLR=DBLE(OLPP*DCONJG(ORPP))
53463 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
53464 IDLAM(LKNT,1)=KFCCHI(1)
53465 IDLAM(LKNT,2)=ITH(IH)
53470 C...CHI1 JUMPS TO HERE
53473 C...CHI+_I -> CHI0_J + W+
53478 IF(AXMI.GE.AXMJ+XMW) THEN
53481 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
53483 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
53484 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
53485 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
53486 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
53487 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
53488 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
53489 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
53490 IDLAM(LKNT,1)=KFNCHI(IJ)
53494 ELSEIF(AXMI.GE.AXMJ) THEN
53496 S12MAX=(AXMI-AXMJ)**2
53498 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
53500 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
53501 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
53502 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
53503 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
53504 CXC(5)=DCMPLX(0D0,0D0)
53505 CXC(7)=DCMPLX(0D0,0D0)
53509 T3I=SIGN(1D0,EI+1D-6)/2D0
53511 T3J=SIGN(1D0,EJ+1D-6)/2D0
53512 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
53513 & TANW+ZMIXC(IJ,2)*T3J)/SR2
53514 CXC(4)=-DCONJG(UMIXC(IX,1))*(
53515 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
53516 CXC(6)=DCMPLX(0D0,0D0)
53517 CXC(8)=DCMPLX(0D0,0D0)
53522 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53523 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
53526 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
53527 IF(XXC(5).LT.AXMI) THEN
53529 ELSEIF(XXC(6).LT.AXMI) THEN
53534 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
53535 C...--> 1/(16PI)/M**3*(AEM/XW)**2
53536 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
53538 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53539 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
53540 IDLAM(LKNT,1)=KFNCHI(IJ)
53543 C...ONLY DECAY CHI+1 -> E+ NU_E
53544 IF( IMSS(12).NE. 0 ) GOTO 260
53545 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
53547 XLAM(LKNT)=XLAM(LKNT-1)
53548 IDLAM(LKNT,1)=KFNCHI(IJ)
53553 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
53555 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
53556 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
53558 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
53560 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
53561 IF(XXC(5).LT.AXMI) THEN
53563 ELSEIF(XXC(6).LT.AXMI) THEN
53568 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53569 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
53570 IDLAM(LKNT,1)=KFNCHI(IJ)
53575 C...NOW, DO THE QUARKS
53580 T3I=SIGN(1D0,EI+1D-6)/2D0
53582 T3J=SIGN(1D0,EJ+1D-6)/2D0
53583 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
53584 & TANW+ZMIXC(IJ,2)*T3J)
53585 CXC(4)=-DCONJG(UMIXC(IX,1))*(
53586 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
53587 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53588 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
53589 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
53590 IF(XXC(5).LT.AXMI) THEN
53593 IF(XXC(6).LT.AXMI) THEN
53598 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
53600 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53601 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53602 IDLAM(LKNT,1)=KFNCHI(IJ)
53605 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
53607 XLAM(LKNT)=XLAM(LKNT-1)
53608 IDLAM(LKNT,1)=KFNCHI(IJ)
53617 C...CHI+_I -> CHI0_J + H+
53623 IF(AXMI.GE.AXMJ+XMHP) THEN
53625 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
53626 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
53627 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
53628 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
53630 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53631 GLR=DBLE(OLPP*DCONJG(ORPP))
53632 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
53633 IDLAM(LKNT,1)=KFNCHI(IJ)
53641 C...2-BODY DECAYS TO FERMION SFERMION
53643 IF(J.GE.7.AND.J.LE.10) GOTO 240
53644 IF(MOD(J,2).EQ.0) THEN
53650 XMSF1=PMAS(PYCOMP(KF1),1)
53651 XMSF2=PMAS(PYCOMP(KF2),1)
53660 IF(MOD(J,2).EQ.0) THEN
53663 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
53664 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
53670 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
53672 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
53677 IF(AXMI.GE.XMF+XMSF1) THEN
53681 XL=PYLAMF(XMI2,XMA2,XMB2)
53682 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
53683 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
53684 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
53685 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
53687 IF(MOD(J,2).EQ.0) THEN
53697 IF(AXMI.GE.XMF+XMSF2) THEN
53701 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
53702 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
53703 XL=PYLAMF(XMI2,XMA2,XMB2)
53704 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
53705 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
53707 IF(MOD(J,2).EQ.0) THEN
53717 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
53718 C...A 2-BODY -- 2-BODY CHAIN
53719 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
53720 IF(AXMI.GE.XMJ) THEN
53723 S12MAX=(AXMI-AXMJ)**2
53728 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
53729 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
53732 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
53734 CXC(1)=DCMPLX(0D0,0D0)
53735 CXC(3)=DCMPLX(0D0,0D0)
53736 CXC(5)=DCMPLX(0D0,0D0)
53737 CXC(7)=DCMPLX(0D0,0D0)
53738 CXC(2)=UMIXC(IX,1)*OLPP/SR2
53739 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
53740 CXC(6)=DCMPLX(0D0,0D0)
53741 CXC(8)=DCMPLX(0D0,0D0)
53742 IF(XXC(5).LT.AXMI) THEN
53744 ELSEIF(XXC(6).LT.AXMI) THEN
53749 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
53750 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
53752 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
53753 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53754 IDLAM(LKNT,1)=KSUSY1+21
53757 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
53759 XLAM(LKNT)=XLAM(LKNT-1)
53760 IDLAM(LKNT,1)=KSUSY1+21
53768 C...R-violating decay modes (SKANDS).
53769 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
53774 XLAM(0)=XLAM(0)+XLAM(I)
53775 IF(XLAM(I).LT.0D0) THEN
53776 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
53777 & (IDLAM(I,J),J=1,3)
53781 IF(XLAM(0).EQ.0D0) THEN
53783 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
53784 WRITE(MSTU(11),*) LKNT
53785 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
53791 C*********************************************************************
53794 C...Used in the calculation of inoi -> inoj + f + ~f.
53798 C...Double precision and integer declarations.
53799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53800 IMPLICIT INTEGER(I-N)
53801 INTEGER PYK,PYCHGE,PYCOMP
53802 C...Parameter statement to help give large particle numbers.
53803 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53804 &KEXCIT=4000000,KDIMEN=5000000)
53806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53807 C COMMON/PYINTS/XXM(20)
53809 COMMON/PYINTC/XXC(10),CXC(8)
53810 SAVE /PYDAT1/,/PYINTC/
53812 C...Local variables.
53813 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53814 DOUBLE PRECISION PYXXZ6,X
53815 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53816 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53817 DOUBLE PRECISION SIJ
53818 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53819 DOUBLE PRECISION OL2
53820 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53823 C...Statement functions.
53824 C...Integral from x to y of (t-a)(b-t) dt.
53825 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53826 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53827 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53828 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53829 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53830 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53831 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53832 C...Integral from x to y of (t-a)/(b-t) dt.
53833 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53834 C...Integral from x to y of 1/(t-a) dt.
53835 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53843 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53844 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53845 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53847 S23MIN=(S23AVE-S23DEL)
53848 S23MAX=(S23AVE+S23DEL)
53865 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53866 SIJ=2D0*XXC(2)*XXC(4)*S13
53867 IF(XMV.LE.1000D0) THEN
53868 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53869 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53870 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53871 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53872 IF(XXC(5).LE.10000D0) THEN
53873 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53874 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53875 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53876 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53877 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53878 & *(S13-XMV**2)/WPROP2
53883 IF(XXC(6).LE.10000D0) THEN
53884 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53885 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53886 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53887 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53888 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53889 & *(S13-XMV**2)/WPROP2
53898 IF(XXC(5).LE.10000D0) THEN
53899 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53900 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53901 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53902 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53906 IF(XXC(6).LE.10000D0) THEN
53907 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53908 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53909 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53910 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53915 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53917 IF(PYXXZ6.LT.0D0) THEN
53918 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53919 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53920 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53921 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53922 WRITE(MSTU(11),*) S23MIN,S23MAX
53930 C*********************************************************************
53933 C...Calculates chi0_i -> chi0_j + gamma.
53935 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53937 C...Double precision and integer declarations.
53938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53939 IMPLICIT INTEGER(I-N)
53940 INTEGER PYK,PYCHGE,PYCOMP
53942 C...Local variables.
53943 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53944 DOUBLE PRECISION F1,F2
53946 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53947 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53948 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53949 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53954 C*********************************************************************
53957 C...Calculates the decay rate for ino -> ino + gauge boson.
53959 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53961 C...Double precision and integer declarations.
53962 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53963 IMPLICIT INTEGER(I-N)
53964 INTEGER PYK,PYCHGE,PYCOMP
53966 C...Local variables.
53967 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53968 DOUBLE PRECISION XL,PYLAMF,C1
53969 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53975 XL=PYLAMF(XMI2,XMJ2,XMV2)
53976 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53977 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53978 &12D0*GLR*XM1*XM2*XMV2)
53983 C*********************************************************************
53986 C...Calculates the decay rate for ino -> ino + H.
53988 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53990 C...Double precision and integer declarations.
53991 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53992 IMPLICIT INTEGER(I-N)
53993 INTEGER PYK,PYCHGE,PYCOMP
53995 C...Local variables.
53996 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53997 DOUBLE PRECISION XL,PYLAMF,C1
53998 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
54004 XL=PYLAMF(XMI2,XMJ2,XMV2)
54005 PYX2XH=C1/8D0/XMI3*SQRT(XL)
54006 &*(GX2*(XMI2+XMJ2-XMV2)+
54012 C*********************************************************************
54015 C...Calculates the non-standard decay modes of the Higgs boson.
54017 C...Author: Stephen Mrenna
54018 C...Last Update: April 2001
54019 C......Allow complex values for Z,U, and V
54021 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
54023 C...Double precision and integer declarations.
54024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54025 IMPLICIT INTEGER(I-N)
54026 INTEGER PYK,PYCHGE,PYCOMP
54027 C...Parameter statement to help give large particle numbers.
54028 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54029 &KEXCIT=4000000,KDIMEN=5000000)
54031 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54032 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54033 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54034 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54035 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54036 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54037 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
54039 C...Local variables.
54040 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
54041 COMPLEX*16 QIJ,RIJ,F21K,F12K
54043 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
54044 DOUBLE PRECISION XMI2,XMI3,XMJ2
54045 DOUBLE PRECISION PYLAMF,XL,CF,EI
54047 DOUBLE PRECISION TANW,XW,AEM,C1,AS
54048 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
54049 DOUBLE PRECISION XLAM(0:400)
54050 INTEGER IDLAM(400,3)
54051 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
54053 INTEGER KFNCHI(4),KFCCHI(2)
54054 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
54055 DOUBLE PRECISION SR2
54056 DOUBLE PRECISION BETA,ALFA
54057 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
54058 DOUBLE PRECISION PYALEM
54059 DOUBLE PRECISION AL,AR,ALR
54060 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
54061 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
54062 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
54063 DATA ITH/25,35,36,37/
54064 DATA ETAH/1D0,1D0,-1D0/
54065 DATA SR2/1.4142136D0/
54066 DATA KFNCHI/1000022,1000023,1000025,1000035/
54067 DATA KFCCHI/1000024,1000037/
54069 C...COUNT THE NUMBER OF DECAY MODES
54076 TANW = SQRT(XW/(1D0-XW))
54079 C...1 - 4 DEPENDING ON Higgs species.
54081 IF(KFIN.EQ.ITH(2)) IH=2
54082 IF(KFIN.EQ.ITH(3)) IH=3
54083 IF(KFIN.EQ.ITH(4)) IH=4
54106 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
54111 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
54112 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
54117 IF(IH.EQ.4) GOTO 220
54119 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
54120 C...H0_K -> CHI0_I + CHI0_J
54133 IF(AXMI.GE.AXMJ+AXMK) THEN
54135 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
54136 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
54137 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
54138 & ZMIXC(IJ,3)*ZMIXC(IK,1))
54139 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
54140 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
54141 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
54142 & ZMIXC(IJ,4)*ZMIXC(IK,1))
54143 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
54144 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
54145 C...SIGN OF MASSES I,J
54147 GX2=ABS(F12K)**2+ABS(F21K)**2
54148 GLR=DBLE(F12K*DCONJG(F21K))
54149 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
54150 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
54151 IDLAM(LKNT,1)=KFNCHI(IJ)
54152 IDLAM(LKNT,2)=KFNCHI(IK)
54158 C...H0_K -> CHI+_I CHI-_J
54165 IF(AXMI.GE.AXMJ+AXMK) THEN
54167 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
54168 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
54169 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
54170 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
54171 GX2=ABS(OLPP)**2+ABS(ORPP)**2
54172 GLR=DBLE(OLPP*DCONJG(ORPP))
54174 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
54175 IDLAM(LKNT,1)=KFCCHI(IJ)
54176 IDLAM(LKNT,2)=-KFCCHI(IK)
54182 C...HIGGS TO SFERMION SFERMION
54184 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
54186 XMJL=PMAS(PYCOMP(IJ),1)
54187 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
54188 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
54191 XL=PYLAMF(XMI2,XMJ2,XMJ2)
54198 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
54199 & XMF**2/XMW*SINA/CBETA
54200 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
54201 & XMF**2/XMW*SINA/CBETA
54203 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
54205 ELSEIF(IFL.EQ.15) THEN
54206 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
54212 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
54213 & XMF**2/XMW*COSA/SBETA
54214 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
54215 & XMF**2/XMW*COSA/SBETA
54217 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
54224 ELSEIF(IH.EQ.2) THEN
54226 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
54227 & XMF**2/XMW*COSA/CBETA
54228 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
54229 & XMF**2/XMW*COSA/CBETA
54231 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
54233 ELSEIF(IFL.EQ.15) THEN
54234 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
54240 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
54241 & XMF**2/XMW*SINA/SBETA
54242 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
54243 & XMF**2/XMW*SINA/SBETA
54245 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
54252 ELSEIF(IH.EQ.3) THEN
54258 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
54259 ELSEIF(IFL.EQ.15) THEN
54260 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
54264 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
54268 IF(IH.EQ.3) GOTO 180
54272 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
54279 IF(AXMI.GE.2D0*XMJ) THEN
54281 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54283 & +2D0*GHLR*ALR)**2
54289 IF(AXMI.GE.2D0*XMJR) THEN
54293 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
54296 XL=PYLAMF(XMI2,XMJ2,XMJ2)
54297 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54299 & +2D0*GHLR*ALR)**2
54300 IDLAM(LKNT,1)=IJ+KSUSY1
54301 IDLAM(LKNT,2)=-(IJ+KSUSY1)
54306 IF(AXMI.GE.XMJL+XMJR) THEN
54308 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
54309 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
54310 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
54313 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
54314 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54315 & (GHLL*AL+GHRR*AR)**2
54317 IDLAM(LKNT,2)=-(IJ+KSUSY1)
54321 IDLAM(LKNT,2)=IJ+KSUSY1
54323 XLAM(LKNT)=XLAM(LKNT-1)
54333 C...H+ -> CHI+_I + CHI0_J
54341 IF(AXMI.GE.AXMJ+AXMK) THEN
54343 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
54344 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
54345 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
54346 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
54347 GX2=ABS(OLPP)**2+ABS(ORPP)**2
54348 GLR=DBLE(OLPP*DCONJG(ORPP))
54349 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
54350 IDLAM(LKNT,1)=KFNCHI(IJ)
54351 IDLAM(LKNT,2)=KFCCHI(IK)
54357 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
54358 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
54364 XM1=PMAS(PYCOMP(KSUSY1+6),1)
54365 XM2=PMAS(PYCOMP(KSUSY1+5),1)
54366 IF(XMI.GE.XM1+XM2) THEN
54367 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54369 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54370 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
54371 IDLAM(LKNT,1)=KSUSY1+6
54372 IDLAM(LKNT,2)=-(KSUSY1+5)
54377 XM1=PMAS(PYCOMP(KSUSY2+6),1)
54378 XM2=PMAS(PYCOMP(KSUSY1+5),1)
54379 IF(XMI.GE.XM1+XM2) THEN
54380 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54382 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54383 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
54384 IDLAM(LKNT,1)=KSUSY2+6
54385 IDLAM(LKNT,2)=-(KSUSY1+5)
54390 XM1=PMAS(PYCOMP(KSUSY1+6),1)
54391 XM2=PMAS(PYCOMP(KSUSY2+5),1)
54392 IF(XMI.GE.XM1+XM2) THEN
54393 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54395 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54396 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
54397 IDLAM(LKNT,1)=KSUSY1+6
54398 IDLAM(LKNT,2)=-(KSUSY2+5)
54403 XM1=PMAS(PYCOMP(KSUSY2+6),1)
54404 XM2=PMAS(PYCOMP(KSUSY2+5),1)
54405 IF(XMI.GE.XM1+XM2) THEN
54406 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54408 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54409 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
54410 IDLAM(LKNT,1)=KSUSY2+6
54411 IDLAM(LKNT,2)=-(KSUSY2+5)
54416 GL=-XMW/SR2*SIN(2D0*BETA)
54418 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
54419 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
54420 IF(XMI.GE.XM1+XM2) THEN
54421 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54423 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
54424 IDLAM(LKNT,1)=-(KSUSY1+IJ)
54425 IDLAM(LKNT,2)=KSUSY1+IJ+1
54433 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
54434 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
54435 IF(XMI.GE.XM1+XM2) THEN
54436 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54438 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
54439 IDLAM(LKNT,1)=-(KSUSY1+IJ)
54440 IDLAM(LKNT,2)=KSUSY1+IJ+1
54445 C...H+ -> TAU1 NUTAUL
54446 XM1=PMAS(PYCOMP(KSUSY1+15),1)
54447 XM2=PMAS(PYCOMP(KSUSY1+16),1)
54448 IF(XMI.GE.XM1+XM2) THEN
54449 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54451 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
54452 IDLAM(LKNT,1)=-(KSUSY1+15)
54453 IDLAM(LKNT,2)= KSUSY1+16
54457 C...H+ -> TAU2 NUTAUL
54458 XM1=PMAS(PYCOMP(KSUSY2+15),1)
54459 XM2=PMAS(PYCOMP(KSUSY1+16),1)
54460 IF(XMI.GE.XM1+XM2) THEN
54461 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54463 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
54464 IDLAM(LKNT,1)=-(KSUSY2+15)
54465 IDLAM(LKNT,2)= KSUSY1+16
54473 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
54474 XLAM(0)=XLAM(0)+XLAM(I)
54476 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
54481 C*********************************************************************
54484 C...Calculates the decay rate for a Higgs to an ino pair.
54486 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
54488 C...Double precision and integer declarations.
54489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54490 IMPLICIT INTEGER(I-N)
54491 INTEGER PYK,PYCHGE,PYCOMP
54493 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54496 C...Local variables.
54497 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
54498 DOUBLE PRECISION XL,PYLAMF,C1
54499 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
54505 XL=PYLAMF(XMI2,XMJ2,XMK2)
54506 PYH2XX=C1/4D0/XMI3*SQRT(XL)
54507 &*(GX2*(XMI2-XMJ2-XMK2)-
54509 IF(PYH2XX.LT.0D0) PYH2XX=0D0
54514 C*********************************************************************
54517 C...Integration by adaptive Gaussian quadrature.
54518 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54520 FUNCTION PYGAUS(F, A, B, EPS)
54522 C...Double precision and integer declarations.
54523 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54524 IMPLICIT INTEGER(I-N)
54525 INTEGER PYK,PYCHGE,PYCOMP
54527 C...Local declarations.
54529 DOUBLE PRECISION F,W(12), X(12)
54530 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
54531 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
54532 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
54533 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
54534 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
54535 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
54536 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
54537 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
54538 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
54539 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
54540 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
54541 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
54543 C...The Gaussian quadrature algorithm.
54545 IF(B .EQ. A) GOTO 140
54546 CONST = 5D-3 / ABS(B-A)
54557 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
54562 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
54565 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
54567 IF(BB .NE. B) GOTO 100
54570 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
54572 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
54581 C*********************************************************************
54584 C...Integration by adaptive Gaussian quadrature.
54585 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54586 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
54588 FUNCTION PYGAU2(F, A, B, EPS)
54590 C...Double precision and integer declarations.
54591 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54592 IMPLICIT INTEGER(I-N)
54593 INTEGER PYK,PYCHGE,PYCOMP
54595 C...Local declarations.
54597 DOUBLE PRECISION F,W(12), X(12)
54598 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
54599 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
54600 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
54601 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
54602 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
54603 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
54604 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
54605 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
54606 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
54607 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
54608 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
54609 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
54611 C...The Gaussian quadrature algorithm.
54613 IF(B .EQ. A) GOTO 140
54614 CONST = 5D-3 / ABS(B-A)
54625 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
54630 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
54633 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
54635 IF(BB .NE. B) GOTO 100
54638 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
54640 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
54649 C*********************************************************************
54652 C...Simpson formula for an integral.
54654 FUNCTION PYSIMP(Y,X0,X1,N)
54656 C...Double precision and integer declarations.
54657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54658 IMPLICIT INTEGER(I-N)
54659 INTEGER PYK,PYCHGE,PYCOMP
54661 C...Local variables.
54662 DOUBLE PRECISION Y,X0,X1,H,S
54668 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
54675 C*********************************************************************
54678 C...The standard lambda function.
54680 FUNCTION PYLAMF(X,Y,Z)
54682 C...Double precision and integer declarations.
54683 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54684 IMPLICIT INTEGER(I-N)
54685 INTEGER PYK,PYCHGE,PYCOMP
54687 C...Local variables.
54688 DOUBLE PRECISION PYLAMF,X,Y,Z
54690 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
54691 IF(PYLAMF.LT.0D0) PYLAMF=0D0
54696 C*********************************************************************
54699 C...Generates 3-body decays of gauginos.
54701 SUBROUTINE PYTBDY(IDIN)
54703 C...Double precision and integer declarations.
54704 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54705 IMPLICIT INTEGER(I-N)
54706 INTEGER PYK,PYCHGE,PYCOMP
54707 C...Parameter statement to help give large particle numbers.
54708 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54709 &KEXCIT=4000000,KDIMEN=5000000)
54711 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54712 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54713 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54714 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54715 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54716 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54717 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54718 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
54719 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYSSMT/
54721 C...Local variables.
54722 DOUBLE PRECISION XM(5)
54723 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
54724 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
54725 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
54726 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
54727 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
54728 DOUBLE PRECISION CPHI1,SPHI1
54729 DOUBLE PRECISION S23DEL,EPS
54730 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
54731 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
54732 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
54734 DATA INOID/22,23,25,35/
54745 S12MIN=(XM(1)+XM(2))**2
54746 S12MAX=(XM(5)-XM(3))**2
54747 YJACO1=S12MAX-S12MIN
54749 C...Initialize some parameters
54761 C...Mrenna: check that we are indeed decaying a SUSY particle
54762 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
54766 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
54767 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
54769 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
54770 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
54771 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
54772 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
54775 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
54776 T3I=SIGN(1D0,EI+1D-6)/2D0
54779 IF(MSTP(47).EQ.0) THEN
54781 ELSEIF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
54783 ELSEIF(IZID1*IZID2.NE.0) THEN
54785 GMMZ=PMAS(23,1)*PMAS(23,2)
54787 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
54788 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54790 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
54791 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
54793 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54795 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
54797 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
54798 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
54799 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
54800 XM1M2=SMZ(IZID1)*SMZ(IZID2)
54801 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
54803 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
54805 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
54807 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
54809 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
54810 IF(IZID1.NE.0) THEN
54811 XM1M2=SMZ(IZID1)*SMW(IWID2)
54815 XM1M2=SMZ(IZID2)*SMW(IWID1)
54818 RT2I = 1D0/SQRT(2D0)
54820 GMMZ=PMAS(24,1)*PMAS(24,2)
54822 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54823 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54826 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54828 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54829 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54830 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54831 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54832 EJ=KCHG(IABS(JA),1)/3D0
54833 T3J=SIGN(1D0,EJ+1D-6)/2D0
54834 QRLS=DCMPLX(0D0,0D0)
54840 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54841 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54842 IF(MOD(IA,2).EQ.0) THEN
54843 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54844 & TANW+ZMIXC(IZID2,2)*T3I)
54845 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54846 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54848 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54849 & TANW+ZMIXC(IZID2,2)*T3J)
54850 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54851 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54853 ELSEIF(IWID1*IWID2.NE.0) THEN
54856 XM1M2=SMW(IWID1)*SMW(IWID2)
54858 GMMZ=PMAS(23,1)*PMAS(23,2)
54860 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54861 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54862 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54863 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54865 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54866 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54867 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54868 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54869 QRLS=-DCMPLX(EI/XW1)*ORPP
54870 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54871 QRRS=-DCMPLX(EI/XW1)*OLPP
54872 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54873 IF(MOD(IA,2).EQ.0) THEN
54874 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54875 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54877 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54878 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54880 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54887 IF(ISKIP.NE.0) THEN
54890 S12=S12MIN+YJACO1*(KT-1)/99
54891 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54892 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54893 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54894 & -(2D0*XM(1)*XM(2))**2
54895 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54896 & -(2D0*XM(3)*XM(5))**2
54899 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54901 S23MIN=S23AVE-S23DEL
54902 S23MAX=S23AVE+S23DEL
54903 YJACO2=S23MAX-S23MIN
54906 S23=S23MIN+YJACO2*(KS-1)/99
54909 WU2 = (UH-ZM12)*(UH-ZM22)
54910 WT2 = (TH-ZM12)*(TH-ZM22)
54912 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54913 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54914 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54915 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54916 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54917 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54918 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54919 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54920 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54921 IF(WT0.GT.WTMAX) WTMAX=WT0
54931 BX=S12MIN+0.5D0*YJACO1
54934 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54942 C...SOLVE FOR F1 AND F2
54943 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54944 &-(2D0*XM(1)*XM(2))**2
54945 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54946 &-(2D0*XM(3)*XM(5))**2
54949 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54951 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54952 &-(2D0*XM(1)*XM(2))**2
54953 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54954 &-(2D0*XM(3)*XM(5))**2
54957 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54960 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54961 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54967 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54968 & -(2D0*XM(1)*XM(2))**2
54969 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54970 & -(2D0*XM(3)*XM(5))**2
54973 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54980 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54981 & -(2D0*XM(1)*XM(2))**2
54982 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54983 & -(2D0*XM(3)*XM(5))**2
54986 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54991 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
55001 180 S12=S12MIN+PYR(0)*YJACO1
55004 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
55005 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
55006 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
55007 &-(2D0*XM(1)*XM(2))**2
55008 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
55009 &-(2D0*XM(3)*XM(5))**2
55012 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
55014 S23MIN=S23AVE-S23DEL
55015 S23MAX=S23AVE+S23DEL
55016 YJACO2=S23MAX-S23MIN
55017 S23=S23MIN+PYR(0)*YJACO2
55019 C...CHECK THE SAMPLING
55020 IF(IKNT.GT.100) THEN
55021 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
55024 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
55026 IF(ISKIP.EQ.0) GOTO 190
55032 WU2 = (UH-ZM12)*(UH-ZM22)
55033 WT2 = (TH-ZM12)*(TH-ZM22)
55035 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
55036 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
55038 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
55039 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
55040 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
55041 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
55042 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
55043 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
55044 c &/DCMPLX(TH-XML2)
55045 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
55046 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
55047 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
55048 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
55049 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
55050 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
55052 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
55053 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
55055 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
55056 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
55058 P1=SQRT(D1*D1-XM(1)**2)
55059 P2=SQRT(D2*D2-XM(2)**2)
55060 P3=SQRT(D3*D3-XM(3)**2)
55061 CTHE1=2D0*PYR(0)-1D0
55062 ANG1=2D0*PYR(0)*PARU(1)
55066 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
55068 P(N+1,1)=P1*STHE1*CPHI1
55069 P(N+1,2)=P1*STHE1*SPHI1
55074 ANG3=2D0*PYR(0)*PARU(1)
55077 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
55079 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
55081 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
55082 &+P3*STHE3*SPHI3*SPHI1
55083 &+P3*CTHE3*STHE1*CPHI1
55084 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
55085 &-P3*STHE3*SPHI3*CPHI1
55086 &+P3*CTHE3*STHE1*SPHI1
55087 P(N+3,3)=P3*STHE3*CPHI3*STHE1
55092 P(N+2,I)=-P(N+1,I)-P(N+3,I)
55100 C*********************************************************************
55103 C...Finds the s-hat dependent eigenvalues of the inverse propagator
55104 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
55105 C...phase space generation. Extended to include techni-a meson, and
55106 C...to return the width.
55108 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
55110 C...Double precision and integer declarations.
55111 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55112 IMPLICIT INTEGER(I-N)
55113 INTEGER PYK,PYCHGE,PYCOMP
55114 C...Parameter statement to help give large particle numbers.
55115 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55116 &KEXCIT=4000000,KDIMEN=5000000)
55118 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55119 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55120 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55121 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
55122 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
55124 C...Local variables.
55125 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
55126 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
55127 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
55134 SINW=MIN(SQRT(PARU(102)),1D0)
55135 COSW=SQRT(1D0-SINW**2)
55137 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
55138 QUPD=2D0*RTCM(2)-1D0
55140 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
55141 FAR=SQRT(AEM/ALPRHT)
55145 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
55158 AR(2,2) = SH-PMAS(23,1)**2
55159 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
55160 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
55161 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
55182 CALL PYWIDT(23,SH,WDTP,WDTE)
55183 AT(2,2) = WDTP(0)*SHR
55184 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
55185 AT(3,3) = WDTP(0)*SHR
55186 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
55187 AT(4,4) = WDTP(0)*SHR
55188 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
55189 AT(5,5) = WDTP(0)*SHR
55193 AR(1,1) = SH-PMAS(24,1)**2
55194 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
55195 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
55202 CALL PYWIDT(24,SH,WDTP,WDTE)
55203 AT(1,1) = WDTP(0)*SHR
55204 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
55205 AT(2,2) = WDTP(0)*SHR
55206 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
55207 AT(3,3) = WDTP(0)*SHR
55210 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
55215 WX(I)=SQRT(ABS(SH-WR(I)))
55217 IF(WR(I).LT.SXMN) THEN
55227 C*********************************************************************
55230 C...Universal Extra Dimensions Model (UED)
55231 C...Initialize the xd masses and widths
55232 C...M. ELKACIMI 4/03/2006
55233 C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
55237 C...Double precision and integer declarations.
55238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55239 IMPLICIT INTEGER(I-N)
55240 INTEGER PYK,PYCHGE,PYCOMP
55242 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55243 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
55244 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
55245 C...UED Pythia common
55246 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55248 C...SAVE statements
55249 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
55251 C...Print out some info about the UED model
55252 WRITE(MSTU(11),7000)
55254 & '********** PYXDIN: initialization of UED ******************',
55256 & 'Universal Extra Dimensions (UED) switched on ',
55258 & 'This implementation is courtesy of',
55259 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
55260 & ' see [hep-ph/0602198] (Les Houches 2005) ',
55262 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
55263 & 'Dobrescu), with gravity-mediated decay widths calculated in',
55264 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
55265 & 'radiative corrections to the KK masses from [hep/ph0204342]',
55266 & '(Cheng, Matchev, Schmaltz).'
55267 WRITE(MSTU(11),7000)
55269 & 'SM particles can propagate into one small extra dimension ',
55270 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
55271 & 'graviton is further allowed to propagate into N = IUED(4)',
55272 & 'large (eV^-1) extra dimensions.'
55273 WRITE(MSTU(11),7000)
55275 & 'The switches and parameters for UED are:',
55276 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
55277 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
55278 & ' IUED(3): (D=5) number of quark flavours',
55279 & ' IUED(4): (D=6) number of large extra dimensions into',
55280 & ' which the graviton propagates',
55281 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
55282 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
55284 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
55285 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
55286 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
55287 & ' when IUED(5)=0',
55288 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
55289 WRITE(MSTU(11),7000)
55291 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
55292 & 'model, but is set through pmas(25,1).',
55295 C...Hardcoded switch, required by current implementation
55296 CALL PYGIVE('MSTP(42)=0')
55298 C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
55299 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
55301 C...Calculated the radiative corrections to the KK particle masses
55304 C...Initialize the graviton mass
55305 C...only if the KK particles decays gravitationally
55306 IF(IUED(2).EQ.1) CALL PYGRAM(0)
55308 WRITE(MSTU(11),7000)
55309 & '********** PYXDIN: UED initialization completed ***********'
55311 C...Format to use for comments
55312 7000 FORMAT(' * ',A)
55316 C*********************************************************************
55319 C...Auxiliary to PYXDIN
55320 C...Mass kk states radiative corrections
55321 C...Radiative corrections are included (hep/ph0204342)
55325 C...Double precision and integer declarations.
55326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55327 IMPLICIT INTEGER(I-N)
55328 INTEGER PYK,PYCHGE,PYCOMP
55330 PARAMETER(KKPART=25,KKFLA=450)
55332 C...UED Pythia common
55333 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55334 C...Pythia common: particles properties
55335 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55338 C...Decay information.
55339 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
55340 C...Resonance width and secondary decay treatment.
55341 COMMON/PYINT4/MWID(500),WIDS(500,5)
55342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55344 C...Local variables
55345 DOUBLE PRECISION PI,QUP,QDW
55346 DOUBLE PRECISION WDTP,WDTE
55347 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
55348 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
55349 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
55350 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
55351 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
55352 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
55353 DOUBLE PRECISION SWW1,CWW1
55354 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
55355 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
55356 DOUBLE PRECISION SW21,CW21,SW021,CW021
55357 COMMON/SW1/SW021,CW021
55358 C...UED related declarations:
55359 C...equivalences between ordered particles (451->475)
55360 C...and UED particle code (5 000 000 + id)
55361 DIMENSION IUEDEQ(475)
55362 DATA (IUEDEQ(I),I=451,475)/
55364 & 6100001,6100002,6100003,6100004,6100005,6100006,
55366 & 5100001,5100002,5100003,5100004,5100005,5100006,
55367 C...Singlet leptons
55368 & 6100011,6100013,6100015,
55369 C...Doublet leptons
55370 & 5100012,5100011,5100014,5100013,5100016,5100015,
55371 C...Gauge boson KK excitations
55372 & 5100021,5100022,5100023,5100024/
55374 C...N.B. rinv=rued(1)
55375 IF(RUED(1).LE.0.)THEN
55376 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
55377 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
55390 c...qt is q-tilde, qs is q-star
55391 c...strong coupling value
55395 c...weak mixing angle
55399 c...for the mass corrections
55404 C... Either fix the cutoff scale LAMUED
55405 IF(IUED(5).EQ.0)THEN
55406 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
55407 C... or the ratio LAMUED/RINV (=product Lambda*R)
55408 ELSEIF(IUED(5).EQ.1)THEN
55409 LOGLAM = DLOG(RUED(4)**2)
55411 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
55415 C...Calculate the radiative corrections for the UED KK masses
55416 IF(IUED(6).EQ.1)THEN
55418 C...or induce a minute mass difference
55419 C...keeping the UED KK mass values nearly equal to 1/R
55420 ELSEIF(IUED(6).EQ.0)THEN
55423 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
55427 c...Take into account only the strong interactions:
55429 c...The space bulk corrections :
55430 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
55431 c...The boundary terms:
55432 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
55434 c...Mass corrections for fermions are extracted from
55435 c...Phys. Rev. D66 036005(2002)9
55436 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
55437 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
55438 DBMQU=RMKK*(3.*(ALPHS/4./PI)
55439 . +(ALPHEM/4./PI/CW2))*LOGLAM
55440 DBMQD=RMKK*(3.*(ALPHS/4./PI)
55441 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
55443 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
55444 . (ALPHEM/4./PI/CW2))*LOGLAM
55445 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
55447 c...Vector boson masss matrix diagonalization
55448 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
55449 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
55450 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
55451 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
55453 c...Elements of the mass matrix
55454 A = RMZ2*SW2 + DBMB2 + DSMB2
55455 B = RMZ2*CW2 + DBMA2 + DSMA2
55456 C = RMZ2*DSQRT(SW2*CW2)
55457 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
55459 c...Eigenvalues: corrections to X1 and Z1 masses
55460 DMB2 = (A+B-SQRDEL)/2.
55461 DMA2 = (A+B+SQRDEL)/2.
55463 c...Rotation angles
55467 SW21= SWW1**2/(SWW1**2 + CWW1**2)
55474 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
55476 RMDQST=RMKK+RFACT*DBMQDO
55477 RMSQUS=RMKK+RFACT*DBMQU
55478 RMSQDS=RMKK+RFACT*DBMQD
55480 C...Note: MZ mass is included in ma2
55481 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
55482 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
55483 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
55485 RMLSLD=RMKK+RFACT*DBMLDO
55486 RMLSLE=RMKK+RFACT*DBMLE
55489 PMAS(KKFLA+IPART,1)=RMSQDS
55492 PMAS(KKFLA+IPART,1)=RMSQUS
55495 PMAS(KKFLA+IPART,1)=RMDQST
55498 PMAS(KKFLA+IPART,1)=RMLSLE
55501 PMAS(KKFLA+IPART,1)=RMLSLD
55503 PMAS(KKFLA+22,1)=RMGST
55504 PMAS(KKFLA+23,1)=RMPHST
55505 PMAS(KKFLA+24,1)=RMZST
55506 PMAS(KKFLA+25,1)=RMWST
55508 WRITE(MSTU(11),7000) ' PYUEDC: ',
55509 & 'UED Mass Spectrum (GeV) :'
55510 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
55511 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
55512 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
55513 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
55514 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
55515 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
55516 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
55517 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
55518 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
55519 WRITE(MSTU(11),7000) ' '
55521 C...Initialize widths, branching ratios and life time
55524 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
55525 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
55526 IF(WDTP(0).LE.0)THEN
55528 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
55529 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
55532 DO 180 IDC=1,MDCY(KC,3)
55533 IC=IDC+MDCY(KC,2)-1
55534 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
55535 C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
55536 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
55537 BRAT(IC)=WDTP(IDC)/WDTP(0)
55544 C...Format to use for comments
55545 7000 FORMAT(' * ',A)
55546 7100 FORMAT(' * ',A,F12.3)
55549 C********************************************************************
55552 C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
55553 C... Original version:
55556 C Universal Extra Dimensions Subprocess cross sections
55557 C The expressions used are from atl-com-phys-2005-003
55558 C What is coded here is shat**2/pi * dsigma/dt = |M|**2
55559 C For each UED subprocess, the color flow used is the same
55560 C as the equivalent QCD subprocess. Different configuration
55561 C color flows are considered to have the same probability.
55563 C The Xsection is calculated following ATL-PHYS-PUB-2005-003
55564 C by G.Azuelos and P.H.Beauchemin.
55566 C This routine is called from pysigh.
55568 SUBROUTINE PYXUED(NCHN,SIGS)
55570 C...Double precision and integer declarations
55571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55572 IMPLICIT INTEGER(I-N)
55575 COMMON/DECMOD/NGRDEC
55577 PARAMETER(KKPART=25,KKFLA=450)
55579 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55580 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55581 COMMON/PYINT1/MINT(400),VINT(400)
55582 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
55583 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
55584 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
55585 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
55586 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
55587 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
55588 C...UED Pythia common
55589 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55590 C...Local arrays and complex variables
55591 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
55592 + ,FAC1,XMNKK,XMUED,SIGS
55595 C...Return if UED not switched on
55596 IF (IUED(1).LE.0) THEN
55600 C...Energy scale of the parton processus
55601 C...taken equal to the mass of the final state kk
55604 C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
55605 XMNKK=PMAS(KKFLA+23,1)
55607 C...To compare the cross section with phys-pub-2005-03
55608 C...(no radiative corrections),
55609 C...take xmnkk=rinv and q2=rinv**2
55611 C...n.b. (rinv=rued(1))
55612 c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
55613 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
55622 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
55625 c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
55626 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
55628 c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
55629 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
55632 C...Strong coupling value
55635 IF(ISUB.EQ.311)THEN
55637 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
55638 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
55639 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
55640 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
55641 & 12.*TP**2*UP**3+6*TP*UP**4)
55642 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
55643 & 15.*TP**3*UP**3+13*TP**2*UP**4+
55644 & 6.*TP*UP**5+2.*UP**6)
55648 C...Three color flow configurations (qcd g+g->g+g)
55650 IF(XCOL.LE.1./3.)THEN
55652 ELSEIF(XCOL.LE.2./3.)THEN
55657 SIGH(NCHN)=COMFAC*XMUED
55658 ELSEIF(ISUB.EQ.312)THEN
55659 C...q + g -> q*_D + g*, q*_S + g*
55660 C...(the two channels have the same cross section)
55661 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
55662 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
55663 & 5.*SP**4*UP**2+12.*SP**5*UP)
55664 XMUED=COMFAC*2.*XMUED
55666 DO 190 I=MMINA,MMAXA
55667 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
55670 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
55671 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
55674 ISIG(NCHN,3-ISDE)=21
55677 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
55681 ELSEIF(ISUB.EQ.313)THEN
55682 C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
55683 C...(the two channels have the same cross section)
55684 C...qi and qj have the same charge sign
55685 DO 100 I=MMIN1,MMAX1
55687 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
55688 DO 101 J=MMIN2,MMAX2
55690 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
55692 IF(J*I.LE.0)GOTO 101
55697 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
55699 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
55700 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
55701 & 20.*TP**2*UP**2+56./3.*
55702 & TP*UP**3+8.*UP**4)
55703 SIGH(NCHN)=COMFAC*2.*XMUED
55705 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
55707 FAC1=2./9.*ALPHAS**2/TP**2
55708 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
55709 SIGH(NCHN)=COMFAC*2.*XMUED
55714 ELSEIF(ISUB.EQ.314)THEN
55715 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
55716 C...(the two channels have the same cross section)
55720 ISIG(NCHN,3)=INT(1.5+PYR(0))
55722 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
55723 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
55724 + +4.*UP**4+4*TP**4)
55725 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
55726 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
55727 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
55729 SIGH(NCHN)=COMFAC*XMUED
55730 C...has been multiplied by 5: all possible quark flavors in final state
55732 ELSEIF(ISUB.EQ.315)THEN
55733 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
55734 C...(the two channels have the same cross section)
55735 DO 141 I=MMIN1,MMAX1
55736 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55737 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
55738 DO 142 J=MMIN2,MMAX2
55739 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
55740 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
55741 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
55742 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
55743 & 2./3.*SP**3*TP+SP**4)
55748 SIGH(NCHN)=COMFAC*2.*XMUED
55751 ELSEIF(ISUB.EQ.316)THEN
55752 C...q + qbar' -> q*_D + q*_Sbar'
55753 FAC1=2./9.*ALPHAS**2
55754 DO 300 I=MMIN1,MMAX1
55756 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
55757 DO 301 J=MMIN2,MMAX2
55759 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
55760 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
55765 FAC1=2./9.*ALPHAS**2/TP**2
55766 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
55767 SIGH(NCHN)=COMFAC*XMUED
55771 ELSEIF(ISUB.EQ.317)THEN
55772 C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
55773 C...(the two channels have the same cross section)
55774 DO 400 I=MMIN1,MMAX1
55776 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
55777 DO 401 J=MMIN1,MMAX1
55779 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
55780 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
55785 FAC1=1./18.*ALPHAS**2/TP**2
55786 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55787 SIGH(NCHN)=COMFAC*2.*XMUED
55790 ELSEIF(ISUB.EQ.318)THEN
55791 C...q + q' -> q*_D + q*_S'
55792 DO 500 I=MMIN1,MMAX1
55794 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
55795 DO 501 J=MMIN2,MMAX2
55797 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
55798 IF(J*I.LE.0)GOTO 501
55803 ISIG(NCHN,3)=INT(1.5+PYR(0))
55804 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
55805 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
55806 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
55807 SIGH(NCHN)=COMFAC*XMUED
55813 FAC1=1./18.*ALPHAS**2/TP**2
55814 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55815 SIGH(NCHN)=COMFAC*2.*XMUED
55819 ELSEIF(ISUB.EQ.319)THEN
55820 C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55821 C...(the two channels have the same cross section)
55822 DO 741 I=MMIN1,MMAX1
55823 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55824 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55825 DO 742 J=MMIN2,MMAX2
55826 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55827 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55828 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55833 SIGH(NCHN)=COMFAC*2.*XMUED
55841 C*********************************************************************
55844 C...Universal Extra Dimensions Model (UED)
55845 C...Computation of the Graviton mass.
55847 SUBROUTINE PYGRAM(IN)
55849 C...Double precision and integer declarations
55850 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55851 IMPLICIT INTEGER(I-N)
55853 C...Pythia commonblocks
55854 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55855 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55856 C...UED Pythia common
55857 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55859 C...Local variables
55861 PARAMETER(KCFLA=450,NMAX=5000)
55862 DIMENSION YVEC(5000),RESVEC(5000)
55863 COMMON/INTSAV/YSAV,YMAX,RESMAX
55864 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55865 COMMON/KAPPA/XKAPPA
55867 C...External function (used in call to PYGAUS)
55870 C...SAVE statements
55871 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55879 C...Initialize for numerical integration
55881 XKAPPA=DSQRT(2.D0)/XMPLNK
55883 C...For NDIM=2, compute graviton mass distribution numerically
55886 C... For first event: tabulate distribution of stepwise integrals:
55887 C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55892 YSAV = (I-0.5)/DBLE(NMAX)
55894 C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55895 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55898 C... Save max of distribution (for accept/reject below)
55899 IF(RESINT.GT.RESMAX)THEN
55906 C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55909 XMGAMK=PMAS(KCGAKK,1)
55911 C... Pick random graviton mass, accept according to stored integrals
55912 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55913 110 RMG=AMMAX*PYR(0)
55916 C... Bin enumeration starts at 1, but make sure always in range
55918 IBIN=MIN(IBIN,NMAX)
55919 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55921 C... For NDIM=4 and 6, the analytical expression for the
55922 C... graviton mass distribution integral is used.
55923 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55925 C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55928 C... KK photon (?) compressed code and mass
55930 XMGAMK=PMAS(KCGAKK,1)
55932 C... Find maximum of (dGamma/dMg)
55938 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55939 IF(RESINT.GE.RESMAX)THEN
55946 C... Pick random graviton mass, accept/reject
55947 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55948 130 RMG=AMMAX*PYR(0)
55950 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55951 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55953 C... If the user has not chosen N=2,4 or 6, STOP
55955 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55956 & ' (MUST BE 2, 4, OR 6) '
55960 C... Now store the sampled Mg
55966 C*********************************************************************
55969 C...Universal Extra Dimensions Model (UED)
55971 C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55973 C...Integrand for the KK boson -> SM boson + graviton
55974 C...graviton mass distribution (and gravity mediated total width),
55975 C...which contains (see 0201300 and below for the full product)
55976 C...the gravity mediated partial decay width Gamma(xx, yy)
55977 C... i.e. GRADEN(YY)*PYWDKK(XXA)
55978 C... where xx is exclusive to gravity
55979 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55980 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55982 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55984 C...Double precision and integer declarations
55985 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55986 IMPLICIT INTEGER (I-N)
55988 C...Pythia commonblocks
55989 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55991 C...Local UED commonblocks and variables
55992 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55993 COMMON/INTSAV/YSAV,YMAX,RESMAX
55995 C...SAVE statements
55996 SAVE /PYDAT1/,/INTSAV/
55998 C...External: Pythia's Gamma function
56007 XX=DSQRT(1.-YY**2)*YIN
56008 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
56009 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
56013 XXA=DSQRT(XX**2+YY**2)
56014 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
56017 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
56021 C*********************************************************************
56024 C...Universal Extra Dimensions Model (UED)
56026 C...Multiplied by the square modulus of a form factor
56027 C...(see GRADEN in function PYGRAW)
56028 C...PYWDKK is the KK boson -> SM boson + graviton
56029 C...gravity mediated partial decay width Gamma(xx, yy)
56030 C... where xx is exclusive to gravity
56031 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
56032 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
56034 C...N.B. The Feynman rules for the couplings of the graviton fields
56035 C...to the UED fields are related to the corresponding couplings of
56036 C...the graviton fields to the SM fields by the form factor.
56038 DOUBLE PRECISION FUNCTION PYWDKK(X)
56040 C...Double precision and integer declarations
56041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56042 IMPLICIT INTEGER (I-N)
56044 C...Pythia commonblocks
56045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56046 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56048 C...Local UED commonblocks and variables
56049 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
56050 COMMON/KAPPA/XKAPPA
56052 C...SAVE statements
56053 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
56057 C...gamma* mass 473
56059 XMNKK=PMAS(KCQKK,1)
56061 C...Bosons partial width Macesanu hep-ph/0201300
56062 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
56063 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
56068 C*********************************************************************
56071 C...Finds eigenvalues of a general complex matrix
56073 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
56074 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
56075 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
56076 C OF A COMPLEX GENERAL MATRIX.
56080 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
56081 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56082 C DIMENSION STATEMENT.
56084 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
56086 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56087 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
56089 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
56090 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
56091 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
56095 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56096 C RESPECTIVELY, OF THE EIGENVALUES.
56098 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56099 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
56101 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
56102 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
56103 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
56105 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
56107 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56108 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56110 C THIS VERSION DATED AUGUST 1983.
56113 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
56115 INTEGER N,NM,IS1,IS2,IERR,MATZ
56116 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
56117 X FV1(5),FV2(5),FV3(5)
56118 IF (N .LE. NM) GOTO 100
56122 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
56123 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
56124 IF (MATZ .NE. 0) GOTO 110
56125 C .......... FIND EIGENVALUES ONLY ..........
56126 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
56128 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
56129 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
56130 IF (IERR .NE. 0) GOTO 120
56131 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
56135 C*********************************************************************
56138 C...Auxiliary to PYEICG.
56140 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56141 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
56143 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
56144 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56145 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56147 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
56148 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
56152 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56153 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56154 C DIMENSION STATEMENT.
56156 C N IS THE ORDER OF THE MATRIX.
56158 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56159 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56160 C SET LOW=1, IGH=N.
56162 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56163 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56164 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
56165 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
56166 C THE REDUCTION BY CORTH, IF PERFORMED.
56170 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
56171 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
56172 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
56173 C EIGENVECTORS IS TO BE PERFORMED.
56175 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56176 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
56177 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56178 C FOR INDICES IERR+1,...,N.
56181 C ZERO FOR NORMAL RETURN,
56182 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56183 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56185 C CALLS PYCDIV FOR COMPLEX DIVISION.
56186 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56187 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56189 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56190 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56192 C THIS VERSION DATED AUGUST 1983.
56195 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
56197 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
56198 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
56199 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
56203 IF (LOW .EQ. IGH) GOTO 130
56204 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56209 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
56210 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
56211 YR = HR(I,I-1) / NORM
56212 YI = HI(I,I-1) / NORM
56217 SI = YR * HI(I,J) - YI * HR(I,J)
56218 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
56223 SI = YR * HI(J,I) + YI * HR(J,I)
56224 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
56229 C .......... STORE ROOTS ISOLATED BY CBAL ..........
56230 130 DO 140 I = 1, N
56231 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56240 C .......... SEARCH FOR NEXT EIGENVALUE ..........
56241 150 IF (EN .LT. LOW) GOTO 320
56244 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56245 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
56246 160 DO 170 LL = LOW, EN
56248 IF (L .EQ. LOW) GOTO 180
56249 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
56250 X + DABS(HR(L,L)) + DABS(HI(L,L))
56251 TST2 = TST1 + DABS(HR(L,L-1))
56252 IF (TST2 .EQ. TST1) GOTO 180
56254 C .......... FORM SHIFT ..........
56255 180 IF (L .EQ. EN) GOTO 300
56256 IF (ITN .EQ. 0) GOTO 310
56257 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
56260 XR = HR(ENM1,EN) * HR(EN,ENM1)
56261 XI = HI(ENM1,EN) * HR(EN,ENM1)
56262 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
56263 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
56264 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
56265 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
56266 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
56269 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
56273 C .......... FORM EXCEPTIONAL SHIFT ..........
56274 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
56277 210 DO 220 I = LOW, EN
56278 HR(I,I) = HR(I,I) - SR
56279 HI(I,I) = HI(I,I) - SI
56286 C .......... REDUCE TO TRIANGLE (ROWS) ..........
56292 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
56293 XR = HR(I-1,I-1) / NORM
56295 XI = HI(I-1,I-1) / NORM
56298 HI(I-1,I-1) = 0.0D0
56299 HI(I,I-1) = SR / NORM
56306 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
56307 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
56308 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
56309 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
56315 IF (SI .EQ. 0.0D0) GOTO 250
56316 NORM = PYTHAG(HR(EN,EN),SI)
56317 SR = HR(EN,EN) / NORM
56321 C .......... INVERSE OPERATION (COLUMNS) ..........
56322 250 DO 280 J = LP1, EN
56331 IF (I .EQ. J) GOTO 260
56333 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56334 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56335 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56336 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56341 IF (SI .EQ. 0.0D0) GOTO 160
56346 HR(I,EN) = SR * YR - SI * YI
56347 HI(I,EN) = SR * YI + SI * YR
56351 C .......... A ROOT FOUND ..........
56352 300 WR(EN) = HR(EN,EN) + TR
56353 WI(EN) = HI(EN,EN) + TI
56356 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56357 C CONVERGED AFTER 30*N ITERATIONS ..........
56362 C*********************************************************************
56365 C...Auxiliary to PYEICG.
56367 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56368 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
56370 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
56371 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56372 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56374 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
56375 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
56376 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
56377 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
56378 C THIS GENERAL MATRIX TO HESSENBERG FORM.
56382 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56383 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56384 C DIMENSION STATEMENT.
56386 C N IS THE ORDER OF THE MATRIX.
56388 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56389 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56390 C SET LOW=1, IGH=N.
56392 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
56393 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
56394 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
56395 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
56396 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
56398 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56399 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56400 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
56401 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
56402 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
56403 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
56408 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
56409 C HAVE BEEN DESTROYED.
56411 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56412 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
56413 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56414 C FOR INDICES IERR+1,...,N.
56416 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56417 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
56418 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
56419 C THE EIGENVECTORS HAS BEEN FOUND.
56422 C ZERO FOR NORMAL RETURN,
56423 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56424 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56426 C CALLS PYCDIV FOR COMPLEX DIVISION.
56427 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56428 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56430 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56431 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56433 C THIS VERSION DATED OCTOBER 1989.
56435 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
56436 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
56439 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
56441 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
56442 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
56443 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
56445 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
56449 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
56458 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
56459 C FROM THE INFORMATION LEFT BY CORTH ..........
56460 IEND = IGH - LOW - 1
56461 IF (IEND.LT.0) GOTO 220
56462 IF (IEND.EQ.0) GOTO 170
56463 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
56464 DO 160 II = 1, IEND
56466 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
56467 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
56468 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
56469 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
56472 DO 120 K = IP1, IGH
56473 ORTR(K) = HR(K,I-1)
56474 ORTI(K) = HI(K,I-1)
56482 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
56483 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
56490 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
56491 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
56497 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56502 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
56503 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
56504 YR = HR(I,I-1) / NORM
56505 YI = HI(I,I-1) / NORM
56510 SI = YR * HI(I,J) - YI * HR(I,J)
56511 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
56516 SI = YR * HI(J,I) + YI * HR(J,I)
56517 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
56521 DO 200 J = LOW, IGH
56522 SI = YR * ZI(J,I) + YI * ZR(J,I)
56523 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
56528 C .......... STORE ROOTS ISOLATED BY CBAL ..........
56529 220 DO 230 I = 1, N
56530 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
56539 C .......... SEARCH FOR NEXT EIGENVALUE ..........
56540 240 IF (EN .LT. LOW) GOTO 430
56543 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56544 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
56545 250 DO 260 LL = LOW, EN
56547 IF (L .EQ. LOW) GOTO 270
56548 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
56549 X + DABS(HR(L,L)) + DABS(HI(L,L))
56550 TST2 = TST1 + DABS(HR(L,L-1))
56551 IF (TST2 .EQ. TST1) GOTO 270
56553 C .......... FORM SHIFT ..........
56554 270 IF (L .EQ. EN) GOTO 420
56555 IF (ITN .EQ. 0) GOTO 550
56556 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
56559 XR = HR(ENM1,EN) * HR(EN,ENM1)
56560 XI = HI(ENM1,EN) * HR(EN,ENM1)
56561 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
56562 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
56563 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
56564 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
56565 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
56568 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
56572 C .......... FORM EXCEPTIONAL SHIFT ..........
56573 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
56576 300 DO 310 I = LOW, EN
56577 HR(I,I) = HR(I,I) - SR
56578 HI(I,I) = HI(I,I) - SI
56585 C .......... REDUCE TO TRIANGLE (ROWS) ..........
56591 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
56592 XR = HR(I-1,I-1) / NORM
56594 XI = HI(I-1,I-1) / NORM
56597 HI(I-1,I-1) = 0.0D0
56598 HI(I,I-1) = SR / NORM
56605 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
56606 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
56607 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
56608 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
56614 IF (SI .EQ. 0.0D0) GOTO 350
56615 NORM = PYTHAG(HR(EN,EN),SI)
56616 SR = HR(EN,EN) / NORM
56620 IF (EN .EQ. N) GOTO 350
56626 HR(EN,J) = SR * YR + SI * YI
56627 HI(EN,J) = SR * YI - SI * YR
56629 C .......... INVERSE OPERATION (COLUMNS) ..........
56630 350 DO 390 J = LP1, EN
56639 IF (I .EQ. J) GOTO 360
56641 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56642 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56643 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56644 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56647 DO 380 I = LOW, IGH
56652 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56653 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56654 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56655 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56660 IF (SI .EQ. 0.0D0) GOTO 250
56665 HR(I,EN) = SR * YR - SI * YI
56666 HI(I,EN) = SR * YI + SI * YR
56669 DO 410 I = LOW, IGH
56672 ZR(I,EN) = SR * YR - SI * YI
56673 ZI(I,EN) = SR * YI + SI * YR
56677 C .......... A ROOT FOUND ..........
56678 420 HR(EN,EN) = HR(EN,EN) + TR
56680 HI(EN,EN) = HI(EN,EN) + TI
56684 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
56685 C VECTORS OF UPPER TRIANGULAR FORM ..........
56691 TR = DABS(HR(I,J)) + DABS(HI(I,J))
56692 IF (TR .GT. NORM) NORM = TR
56695 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
56696 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
56704 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
56705 DO 490 II = 1, ENM1
56712 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
56713 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
56718 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
56721 460 YR = 0.01D0 * YR
56723 IF (TST2 .GT. TST1) GOTO 460
56725 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
56726 C .......... OVERFLOW CONTROL ..........
56727 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
56728 IF (TR .EQ. 0.0D0) GOTO 490
56730 TST2 = TST1 + 1.0D0/TST1
56731 IF (TST2 .GT. TST1) GOTO 490
56733 HR(J,EN) = HR(J,EN)/TR
56734 HI(J,EN) = HI(J,EN)/TR
56740 C .......... END BACKSUBSTITUTION ..........
56741 C .......... VECTORS OF ISOLATED ROOTS ..........
56743 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
56751 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
56752 C VECTORS OF ORIGINAL FULL MATRIX.
56753 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
56758 DO 540 I = LOW, IGH
56763 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
56764 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
56772 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56773 C CONVERGED AFTER 30*N ITERATIONS ..........
56778 C*********************************************************************
56781 C...Auxiliary to PYCMQR
56783 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
56786 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
56788 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
56789 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
56791 S = DABS(BR) + DABS(BI)
56796 S = BRS**2 + BIS**2
56797 CR = (ARS*BRS + AIS*BIS)/S
56798 CI = (AIS*BRS - ARS*BIS)/S
56802 C*********************************************************************
56805 C...Auxiliary to PYCMQR
56807 C (YR,YI) = COMPLEX DSQRT(XR,XI)
56808 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
56811 SUBROUTINE PYCSRT(XR,XI,YR,YI)
56813 DOUBLE PRECISION XR,XI,YR,YI
56814 DOUBLE PRECISION S,TR,TI,PYTHAG
56818 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56819 IF (TR .GE. 0.0D0) YR = S
56820 IF (TI .LT. 0.0D0) S = -S
56821 IF (TR .LE. 0.0D0) YI = S
56822 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56823 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56827 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56828 DOUBLE PRECISION A,B
56830 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56832 DOUBLE PRECISION P,R,S,T,U
56833 P = DMAX1(DABS(A),DABS(B))
56834 IF (P .EQ. 0.0D0) GOTO 110
56835 R = (DMIN1(DABS(A),DABS(B))/P)**2
56838 IF (T .EQ. 4.0D0) GOTO 110
56840 U = 1.0D0 + 2.0D0*S
56848 C*********************************************************************
56851 C...Auxiliary to PYEICG
56853 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56854 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56855 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56856 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56858 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56859 C EIGENVALUES WHENEVER POSSIBLE.
56863 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56864 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56865 C DIMENSION STATEMENT.
56867 C N IS THE ORDER OF THE MATRIX.
56869 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56870 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56874 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56875 C RESPECTIVELY, OF THE BALANCED MATRIX.
56877 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56878 C ARE EQUAL TO ZERO IF
56879 C (1) I IS GREATER THAN J AND
56880 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56882 C SCALE CONTAINS INFORMATION DETERMINING THE
56883 C PERMUTATIONS AND SCALING FACTORS USED.
56885 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56886 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56887 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56888 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56889 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56890 C = D(J,J) J = LOW,...,IGH
56891 C = P(J) J = IGH+1,...,N.
56892 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56895 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56897 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56898 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56899 C K,L HAVE BEEN REVERSED.)
56901 C ARITHMETIC IS REAL THROUGHOUT.
56903 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56904 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56906 C THIS VERSION DATED AUGUST 1983.
56909 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56911 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56912 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56913 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56922 C .......... IN-LINE PROCEDURE FOR ROW AND
56923 C COLUMN EXCHANGE ..........
56925 IF (J .EQ. M) GOTO 130
56945 130 IF(IEXC.EQ.1) GOTO 140
56946 IF(IEXC.EQ.2) GOTO 180
56947 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56948 C AND PUSH THEM DOWN ..........
56949 140 IF (L .EQ. 1) GOTO 320
56951 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56952 150 DO 170 JJ = 1, L
56956 IF (I .EQ. J) GOTO 160
56957 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56966 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56967 C AND PUSH THEM LEFT ..........
56970 190 DO 210 J = K, L
56973 IF (I .EQ. J) GOTO 200
56974 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56981 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56983 220 SCALE(I) = 1.0D0
56984 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56985 230 NOCONV = .FALSE.
56992 IF (J .EQ. I) GOTO 240
56993 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56994 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56996 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56997 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
57001 250 IF (C .GE. G) GOTO 260
57006 270 IF (C .LT. G) GOTO 280
57010 C .......... NOW BALANCE ..........
57011 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
57013 SCALE(I) = SCALE(I) * F
57017 AR(I,J) = AR(I,J) * G
57018 AI(I,J) = AI(I,J) * G
57022 AR(J,I) = AR(J,I) * F
57023 AI(J,I) = AI(J,I) * F
57028 IF (NOCONV) GOTO 230
57035 C*********************************************************************
57038 C...Auxiliary to PYEICG.
57040 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
57041 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
57042 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
57043 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
57045 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
57046 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
57047 C BALANCED MATRIX DETERMINED BY CBAL.
57051 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57052 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57053 C DIMENSION STATEMENT.
57055 C N IS THE ORDER OF THE MATRIX.
57057 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
57059 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
57060 C AND SCALING FACTORS USED BY CBAL.
57062 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
57064 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57065 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
57066 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
57070 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57071 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
57072 C IN THEIR FIRST M COLUMNS.
57074 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57075 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57077 C THIS VERSION DATED AUGUST 1983.
57080 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
57082 INTEGER I,J,K,M,N,II,NM,IGH,LOW
57083 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
57086 IF (M .EQ. 0) GOTO 150
57087 IF (IGH .EQ. LOW) GOTO 120
57089 DO 110 I = LOW, IGH
57091 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
57092 C IF THE FOREGOING STATEMENT IS REPLACED BY
57093 C S=1.0D0/SCALE(I). ..........
57095 ZR(I,J) = ZR(I,J) * S
57096 ZI(I,J) = ZI(I,J) * S
57100 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
57101 C IGH+1 STEP 1 UNTIL N DO -- ..........
57102 120 DO 140 II = 1, N
57104 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
57105 IF (I .LT. LOW) I = LOW - II
57107 IF (K .EQ. I) GOTO 140
57123 C*********************************************************************
57126 C...Auxiliary to PYEICG.
57128 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
57129 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
57130 C BY MARTIN AND WILKINSON.
57131 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
57133 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
57134 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
57135 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
57136 C UNITARY SIMILARITY TRANSFORMATIONS.
57140 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57141 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57142 C DIMENSION STATEMENT.
57144 C N IS THE ORDER OF THE MATRIX.
57146 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
57147 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
57148 C SET LOW=1, IGH=N.
57150 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57151 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
57155 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57156 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
57157 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
57158 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
57159 C HESSENBERG MATRIX.
57161 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
57162 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
57164 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
57166 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57167 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57169 C THIS VERSION DATED AUGUST 1983.
57172 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
57174 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
57175 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
57176 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
57180 IF (LA .LT. KP1) GOTO 210
57187 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
57189 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
57191 IF (SCALE .EQ. 0.0D0) GOTO 200
57193 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57196 ORTR(I) = AR(I,M-1) / SCALE
57197 ORTI(I) = AI(I,M-1) / SCALE
57198 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
57202 F = PYTHAG(ORTR(M),ORTI(M))
57203 IF (F .EQ. 0.0D0) GOTO 120
57206 ORTR(M) = (1.0D0 + G) * ORTR(M)
57207 ORTI(M) = (1.0D0 + G) * ORTI(M)
57212 C .......... FORM (I-(U*UT)/H) * A ..........
57213 130 DO 160 J = M, N
57216 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57219 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
57220 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
57227 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
57228 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
57232 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
57236 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
57239 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
57240 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
57247 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
57248 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
57253 ORTR(M) = SCALE * ORTR(M)
57254 ORTI(M) = SCALE * ORTI(M)
57255 AR(M,M-1) = -G * AR(M,M-1)
57256 AI(M,M-1) = -G * AI(M,M-1)
57262 C*********************************************************************
57265 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57268 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
57270 INTEGER N,NP,INDX(N)
57272 COMPLEX*16 A(NP,NP)
57273 PARAMETER (TINY=1.0D-20)
57275 REAL*8 AAMAX,VV(6),DUM
57276 COMPLEX*16 SUM,DUMC
57282 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
57284 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
57291 SUM=SUM-A(I,K)*A(K,J)
57299 SUM=SUM-A(I,K)*A(K,J)
57303 IF (DUM.GE.AAMAX) THEN
57318 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
57321 A(I,J)=A(I,J)/A(J,J)
57329 C*********************************************************************
57332 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57335 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
57337 INTEGER N,NP,INDX(N)
57338 COMPLEX*16 A(NP,NP),B(N)
57349 SUM=SUM-A(I,J)*B(J)
57351 ELSE IF (ABS(SUM).NE.0D0) THEN
57359 SUM=SUM-A(I,J)*B(J)
57366 C***********************************************************************
57369 C...Calculates full and partial widths of resonances.
57370 C....copy of PYWIDT, used for techniparticle widths
57372 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
57374 C...Double precision and integer declarations.
57375 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57376 IMPLICIT INTEGER(I-N)
57377 INTEGER PYK,PYCHGE,PYCOMP
57378 C...Parameter statement to help give large particle numbers.
57379 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57380 &KEXCIT=4000000,KDIMEN=5000000)
57382 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57383 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57384 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
57385 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
57386 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57387 COMMON/PYINT1/MINT(400),VINT(400)
57388 COMMON/PYINT4/MWID(500),WIDS(500,5)
57389 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57390 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
57391 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
57392 &/PYINT4/,/PYMSSM/,/PYTCSM/
57393 C...Local arrays and saved variables.
57394 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
57396 SAVE MOFSV,WIDWSV,WID2SV
57397 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
57399 C...Compressed code and sign; mass.
57406 C...Reset width information.
57411 C...Common electroweak and strong constants.
57414 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
57417 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
57419 RADC=1D0+AS/PARU(1)
57421 IF(KFLA.EQ.23) THEN
57423 XWC=1D0/(16D0*XW*XW1)
57424 FAC=(AEM*XWC/3D0)*SHR
57426 DO 130 I=1,MDCY(KC,3)
57428 IF(MDME(IDC,1).LT.0) GOTO 130
57429 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
57430 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
57431 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
57435 AF=SIGN(1D0,EF+0.1D0)
57438 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
57439 ELSEIF(I.LE.16) THEN
57440 C...Z0 -> l+ + l-, nu + nubar
57442 AF=SIGN(1D0,EF+0.1D0)
57446 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
57447 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
57449 WDTP(0)=WDTP(0)+WDTP(I)
57453 ELSEIF(KFLA.EQ.24) THEN
57455 FAC=(AEM/(24D0*XW))*SHR
57456 DO 140 I=1,MDCY(KC,3)
57458 IF(MDME(IDC,1).LT.0) GOTO 140
57459 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
57460 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
57461 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
57464 C...W+/- -> q + qbar'
57465 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
57466 ELSEIF(I.LE.20) THEN
57467 C...W+/- -> l+/- + nu
57470 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
57471 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
57472 WDTP(0)=WDTP(0)+WDTP(I)
57475 C.....V8 -> quark anti-quark
57476 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
57479 IF(ITCM(2).EQ.0) THEN
57481 ELSEIF(ITCM(2).EQ.1) THEN
57484 DO 150 I=1,MDCY(KC,3)
57486 IF(MDME(IDC,1).LT.0) GOTO 150
57487 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
57489 IF(RM1.GT.0.25D0) GOTO 150
57491 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
57496 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
57497 IF(I.EQ.6) WID2=WIDS(6,1)
57498 WDTP(0)=WDTP(0)+WDTP(I)
57505 C*********************************************************************
57508 C...Calculates R-violating decays of sfermions.
57511 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
57513 C...Double precision and integer declarations.
57514 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57515 IMPLICIT INTEGER(I-N)
57516 C...Parameter statement to help give large particle numbers.
57517 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57518 &KEXCIT=4000000,KDIMEN=5000000)
57520 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57521 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57522 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57523 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57524 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57525 C...Local variables.
57526 DOUBLE PRECISION XLAM(0:400)
57527 INTEGER IDLAM(400,3), PYCOMP
57528 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
57530 C...IS R-VIOLATION ON ?
57531 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57532 C...Mass eigenstate counter
57533 ICNT=INT(KFIN/KSUSY1)
57534 C...SM KF code of SUSY particle
57535 KFSM=KFIN-ICNT*KSUSY1
57536 C...Squared Sparticle Mass
57537 SM=PMAS(PYCOMP(KFIN),1)**2
57538 C... Squared mass of top quark
57539 SMT=PMAS(PYCOMP(6),1)**2
57540 C...IS L-VIOLATION ON ?
57541 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
57542 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
57543 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
57549 C...~e,~mu,~tau -> nu_I + lepton-_J
57551 IDLAM(LKNT,1)= 12 +2*(I-1)
57552 IDLAM(LKNT,2)= 11 +2*(J-1)
57555 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57556 IF (IMSS(51).NE.0) XLAM(LKNT) =
57557 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57558 C...KINEMATICS CHECK
57559 IF (XLAM(LKNT).EQ.0D0) THEN
57565 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
57571 IDLAM(LKNT,1)=-12 -2*(I-1)
57572 IDLAM(LKNT,2)= 11 +2*(K-1)
57575 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57576 IF (IMSS(51).NE.0) XLAM(LKNT) =
57577 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57578 C...KINEMATICS CHECK
57579 IF (XLAM(LKNT).EQ.0D0) THEN
57585 C...~e,~mu,~tau -> u_Jbar + d_K
57590 IDLAM(LKNT,1)=-2 -2*(J-1)
57591 IDLAM(LKNT,2)= 1 +2*(K-1)
57594 IF (IMSS(52).NE.0) THEN
57595 C...Use massive top quark
57596 IF (IDLAM(LKNT,1).EQ.-6) THEN
57597 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
57600 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
57601 C...If no top quark, all decay products massless
57603 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57605 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57607 C...KINEMATICS CHECK
57608 IF (XLAM(LKNT).EQ.0D0) THEN
57615 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
57616 C...No right-handed neutrinos
57618 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
57623 C...~nu_J -> lepton+_I + lepton-_K
57625 IDLAM(LKNT,1)=-11 -2*(I-1)
57626 IDLAM(LKNT,2)= 11 +2*(K-1)
57629 RM2=RVLAM(I,J,K)**2 * SM
57630 IF (IMSS(51).NE.0) XLAM(LKNT) =
57631 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57632 C...KINEMATICS CHECK
57633 IF (XLAM(LKNT).EQ.0D0) THEN
57639 C...~nu_I -> dbar_J + d_K
57644 IDLAM(LKNT,1)=-1 -2*(J-1)
57645 IDLAM(LKNT,2)= 1 +2*(K-1)
57648 RM2=3*RVLAMP(I,J,K)**2 * SM
57649 IF (IMSS(52).NE.0) XLAM(LKNT) =
57650 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57651 C...KINEMATICS CHECK
57652 IF (XLAM(LKNT).EQ.0D0) THEN
57659 C * SDOWN -> NU(BAR) + D and LEPTON- + U
57660 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
57664 C...~d_J -> nu_Ibar + d_K
57666 IDLAM(LKNT,1)=-12 -2*(I-1)
57667 IDLAM(LKNT,2)= 1 +2*(K-1)
57670 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57671 IF (IMSS(52).NE.0) XLAM(LKNT) =
57672 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57673 C...KINEMATICS CHECK
57674 IF (XLAM(LKNT).EQ.0D0) THEN
57682 C...~d_K -> nu_I + d_J
57684 IDLAM(LKNT,1)= 12 +2*(I-1)
57685 IDLAM(LKNT,2)= 1 +2*(J-1)
57688 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57689 IF (IMSS(52).NE.0) XLAM(LKNT) =
57690 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57691 C...KINEMATICS CHECK
57692 IF (XLAM(LKNT).EQ.0D0) THEN
57695 C...~d_K -> lepton_I- + u_J
57697 IDLAM(LKNT,1)= 11 +2*(I-1)
57698 IDLAM(LKNT,2)= 2 +2*(J-1)
57701 IF (IMSS(52).NE.0) THEN
57702 C...Use massive top quark
57703 IF (IDLAM(LKNT,2).EQ.6) THEN
57704 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
57706 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
57707 C...If no top quark, all decay products massless
57709 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57711 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57713 C...KINEMATICS CHECK
57714 IF (XLAM(LKNT).EQ.0D0) THEN
57721 C * SUP -> LEPTON+ + D
57722 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
57726 C...~u_J -> lepton_I+ + d_K
57728 IDLAM(LKNT,1)=-11 -2*(I-1)
57729 IDLAM(LKNT,2)= 1 +2*(K-1)
57732 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57733 IF (IMSS(52).NE.0) XLAM(LKNT) =
57734 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57735 C...KINEMATICS CHECK
57736 IF (XLAM(LKNT).EQ.0D0) THEN
57743 C...BARYON NUMBER VIOLATING DECAYS
57744 IF (IMSS(53).GE.1) THEN
57745 C * SUP -> DBAR + DBAR
57746 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
57750 C...~u_I -> dbar_J + dbar_K
57752 C...(anti-) symmetry J <-> K.
57754 IDLAM(LKNT,1) = -1 -2*(J-1)
57755 IDLAM(LKNT,2) = -1 -2*(K-1)
57758 RM2 = 2.*(RVLAMB(I,J,K)**2)
57759 & * SFMIX(KFSM,2*ICNT)**2 * SM
57761 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57762 C...KINEMATICS CHECK
57763 IF (XLAM(LKNT).EQ.0D0) THEN
57770 C * SDOWN -> UBAR + DBAR
57771 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
57775 C...LAMB coupling antisymmetric in J and K.
57777 C...~d_K -> ubar_I + dbar_K
57779 IDLAM(LKNT,1)= -2 -2*(I-1)
57780 IDLAM(LKNT,2)= -1 -2*(J-1)
57783 C...Use massive top quark
57784 IF (IDLAM(LKNT,1).EQ.-6) THEN
57785 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
57788 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
57789 C...If no top quark, all decay products massless
57791 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57793 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57795 C...KINEMATICS CHECK
57796 IF (XLAM(LKNT).EQ.0D0) THEN
57809 C*********************************************************************
57812 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57815 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57817 C...Double precision and integer declarations.
57818 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57819 IMPLICIT INTEGER(I-N)
57820 C...Parameter statement to help give large particle numbers.
57821 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57822 &KEXCIT=4000000,KDIMEN=5000000)
57824 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57825 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57826 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57827 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57828 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57829 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57830 C...Local variables.
57831 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57833 DOUBLE PRECISION XLAM(0:400)
57834 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57835 INTEGER IDLAM(400,3), PYCOMP
57837 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57839 C...R-VIOLATING DECAYS
57840 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57842 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57843 C...WHICH NEUTRALINO ?
57845 IF (KFSM.EQ.23) NCHI=2
57846 IF (KFSM.EQ.25) NCHI=3
57847 IF (KFSM.EQ.35) NCHI=4
57848 C...SIGN OF MASS (Opposite convention as HERWIG)
57850 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57852 C...Useful parameters for the calculation of the A and B constants.
57853 WMASS = PMAS(PYCOMP(24),1)
57854 ECHG = 2*SQRT(PARU(103)*PARU(1))
57855 COSB=1/(SQRT(1+RMSS(5)**2))
57856 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57857 COSW=SQRT(1-PARU(102))
57858 SINW=SQRT(PARU(102))
57859 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57860 C...Run quark masses to neutralino mass squared (for Higgs-type
57862 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57864 RMQ(I)=PYMRUN(I,SQMCHI)
57866 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57868 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57869 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57870 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57871 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57873 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57874 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57875 C2=ECHG*ZPMIX(NCHI,1)
57876 C3=GW*ZPMIX(NCHI,2)/COSW
57880 C x=1-2 : Select A or B constant (1:A ; 2:B)
57881 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57882 C 11-16:e,nu_e,mu,...)
57883 C z=1-2 : Mass eigenstate number
57884 C...CALCULATE COUPLINGS
57886 CMS=PMAS(PYCOMP(I),1)
57887 C...Intermediate sleptons
57888 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57889 & *(C2-C3*SINW**2))
57890 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57891 & *(C2-C3*SINW**2))
57892 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57894 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57896 C...Inermediate sneutrinos
57898 AB(2,I+1,1)=5D-1*C3
57901 C...Inermediate sdown
57904 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57905 & *ED*(C2-C3*SINW**2))
57906 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57907 & *ED*(C2-C3*SINW**2))
57908 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57909 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57910 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57911 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57912 C...Inermediate sup
57915 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57916 & *EU*(C2-C3*SINW**2))
57917 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57918 & *EU*(C2-C3*SINW**2))
57919 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57920 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57921 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57922 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57925 IF (IMSS(51).GE.1) THEN
57926 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57927 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57928 C...STEP IN I,J,K USING SINGLE COUNTER
57930 C...LAMBDA COUPLING ASYM IN I,J
57931 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57933 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57934 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57935 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57937 C...Set coupling, and decay product masses on/off
57938 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57939 & ,MOD(ISC,3)+1)**2
57941 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57943 C...Resonance KF codes (1=I,2=J,3=K)
57944 KFR(1)=-IDLAM(LKNT,1)
57945 KFR(2)=-IDLAM(LKNT,2)
57946 KFR(3)=-IDLAM(LKNT,3)
57947 C...Calculate width.
57948 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57949 & IDLAM(LKNT,3),XLAM(LKNT))
57950 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57951 C...Charge conjugate mode.
57953 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57954 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57955 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57956 XLAM(LKNT)=XLAM(LKNT-1)
57957 C...KINEMATICS CHECK
57958 IF (XLAM(LKNT).EQ.0D0) THEN
57965 IF (IMSS(52).GE.1) THEN
57966 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57967 C * CHI0 -> NUBAR_I + DBAR_J + D_K
57970 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57971 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57972 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57974 C...Set coupling, and decay product masses on/off
57975 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57976 & ,MOD(ISC,3)+1)**2
57978 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57980 C...Resonance KF codes (1=I,2=J,3=K)
57981 KFR(1)=-IDLAM(LKNT,1)
57982 KFR(2)=-IDLAM(LKNT,2)
57983 KFR(3)=-IDLAM(LKNT,3)
57984 C...Calculate width.
57985 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57987 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57988 C...Charge conjugate mode.
57990 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57991 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57992 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57993 XLAM(LKNT)=XLAM(LKNT-1)
57994 C...KINEMATICS CHECK
57995 IF (XLAM(LKNT).EQ.0D0) THEN
57999 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
58001 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58002 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58003 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58005 C...Set coupling, and decay product masses on/off
58006 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
58007 & ,MOD(ISC,3)+1)**2
58009 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
58010 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
58011 C...Resonance KF codes (1=I,2=J,3=K)
58012 KFR(1)=-IDLAM(LKNT,1)
58013 KFR(2)=-IDLAM(LKNT,2)
58014 KFR(3)=-IDLAM(LKNT,3)
58015 C...Calculate width.
58016 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58018 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58019 C...Charge conjugate mode.
58021 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58022 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58023 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58024 XLAM(LKNT)=XLAM(LKNT-1)
58025 C...KINEMATICS CHECK
58026 IF (XLAM(LKNT).EQ.0D0) THEN
58032 IF (IMSS(53).GE.1) THEN
58033 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
58034 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
58036 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
58037 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
58039 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
58040 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58041 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58043 C...Set coupling, and decay product masses on/off
58044 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
58045 & +1,MOD(ISC,3)+1)**2
58047 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
58048 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
58049 C...Resonance KF codes (1=I,2=J,3=K)
58050 KFR(1) = IDLAM(LKNT,1)
58051 KFR(2) = IDLAM(LKNT,2)
58052 KFR(3) = IDLAM(LKNT,3)
58053 C...Calculate width.
58054 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58055 & IDLAM(LKNT,3),XLAM(LKNT))
58056 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58057 C...Charge conjugate mode.
58059 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58060 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58061 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58062 XLAM(LKNT)=XLAM(LKNT-1)
58063 C...KINEMATICS CHECK
58064 IF (XLAM(LKNT).EQ.0D0) THEN
58076 C*********************************************************************
58079 C...Calculates R-violating chargino decay widths.
58082 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
58084 C...Double precision and integer declarations.
58085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58086 IMPLICIT INTEGER(I-N)
58087 C...Parameter statement to help give large particle numbers.
58088 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58089 &KEXCIT=4000000,KDIMEN=5000000)
58091 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58092 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58093 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58094 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58095 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58096 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58097 C...Local variables.
58098 DOUBLE PRECISION XLAM(0:400)
58099 INTEGER IDLAM(400,3), PYCOMP
58100 C...Information from main routine to PYRVGW
58101 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58103 C...Auxiliary variables needed for BV (RV Gauge STOre)
58104 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
58106 C...Running quark masses
58107 DOUBLE PRECISION RMQ(6)
58108 C...Decay product masses on/off
58110 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
58114 C...IF R-VIOLATION ON.
58115 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
58117 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
58118 C...WHICH CHARGINO ?
58120 IF (KFSM.EQ.37) NCHI = 2
58122 C...Useful parameters for calculating the A and B constants.
58123 C...SIGN OF MASS (Opposite convention as HERWIG)
58125 IF (SMW(NCHI).LT.0D0) ISM = -1
58126 WMASS = PMAS(PYCOMP(24),1)
58127 COSB = 1/(SQRT(1+RMSS(5)**2))
58128 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
58129 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
58130 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
58131 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
58134 C...Running masses at Q^2=MCHI^2.
58135 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
58137 RMQ(I)=PYMRUN(I,SQMCHI)
58140 C... AB(x,y,z) coefficients:
58141 C x=1-2 : A or B coefficient (1:A ; 2:B)
58142 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58143 C 11-16:e,nu_e,mu,...)
58144 C z=1-2 : Mass eigenstate number
58146 C...Intermediate sleptons
58149 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
58151 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
58153 C...Intermediate sneutrinos
58154 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
58156 AB(2,I+1,1) = ISM*C3
58158 C...Intermediate sdown
58160 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
58161 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
58162 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
58163 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
58164 C...Intermediate sup
58166 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
58167 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
58168 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
58169 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
58172 C...LLE TYPE R-VIOLATION
58173 IF (IMSS(51).GE.1) THEN
58174 C...LOOP OVER DECAY MODES
58177 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
58178 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
58180 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
58181 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
58182 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
58184 C...Set coupling, and decay product masses on/off
58185 RVLAMC = GW2 * 5D-1 *
58186 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58189 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
58190 C...Resonance KF codes (1=I,2=J,3=K).
58193 KFR(3) = -IDLAM(LKNT,3)+1
58194 C...Calculate width.
58195 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58196 & IDLAM(LKNT,3),XLAM(LKNT))
58197 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58198 C...KINEMATICS CHECK
58199 IF (XLAM(LKNT).EQ.0D0) THEN
58203 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
58204 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
58206 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
58207 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
58208 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
58210 C...Set coupling, and decay product masses on/off
58211 RVLAMC = GW2 * 5D-1 *
58212 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58213 C...I,J SYMMETRY => FACTOR 2
58216 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
58217 C...Resonance KF codes (1=I,2=J,3=K)
58218 KFR(1)=IDLAM(LKNT,1)-1
58219 KFR(2)=IDLAM(LKNT,2)-1
58221 C...Calculate width.
58222 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58223 & IDLAM(LKNT,3),XLAM(LKNT))
58224 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58225 C...KINEMATICS CHECK
58226 IF (XLAM(LKNT).EQ.0D0) THEN
58230 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J)
58231 C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement
58232 C * from above, thanks to N.-E. Bomark.
58234 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58235 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
58236 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
58238 C...Set coupling, and decay product masses on/off
58239 RVLAMC = GW2 * 5D-1 *
58240 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58241 C...I,J SYMMETRY => FACTOR 2
58244 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
58245 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
58246 C...Resonance KF codes (1=I,2=J,3=K)
58247 KFR(1) =-IDLAM(LKNT,1)+1
58248 KFR(2) =-IDLAM(LKNT,2)+1
58250 C...Calculate width.
58251 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58252 & IDLAM(LKNT,3),XLAM(LKNT))
58253 XLAM(LKNT)=XLAM(LKNT)*RVLAMC
58254 & /((2*PARU(1)*RMS(0))**3*32)
58255 C...KINEMATICS CHECK
58256 IF (XLAM(LKNT).EQ.0D0) THEN
58264 C...LQD TYPE R-VIOLATION
58265 IF (IMSS(52).GE.1) THEN
58266 C...LOOP OVER DECAY MODES
58269 C...CHI+ -> NUBAR_I + DBAR_J + U_K
58271 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58272 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58273 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
58275 C...Set coupling, and decay product masses on/off
58276 RVLAMC = 3. * GW2 * 5D-1 *
58277 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58279 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
58281 C...Resonance KF codes (1=I,2=J,3=K)
58284 KFR(3)=-IDLAM(LKNT,3)+1
58285 C...Calculate width.
58286 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58288 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58289 C...KINEMATICS CHECK
58290 IF (XLAM(LKNT).EQ.0D0) THEN
58294 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
58296 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58297 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58298 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
58300 C...Set coupling, and decay product masses on/off
58301 RVLAMC = 3. * GW2 * 5D-1 *
58302 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58304 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
58305 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
58306 C...Resonance KF codes (1=I,2=J,3=K)
58309 KFR(3)=-IDLAM(LKNT,3)+1
58310 C...Calculate width.
58311 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58313 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58314 C...KINEMATICS CHECK
58315 IF (XLAM(LKNT).EQ.0D0) THEN
58319 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
58321 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58322 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58323 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58325 C...Set coupling, and decay product masses on/off
58326 RVLAMC = 3. * GW2 * 5D-1 *
58327 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58329 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
58330 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
58331 C...Resonance KF codes (1=I,2=J,3=K)
58332 KFR(1)=-IDLAM(LKNT,1)+1
58333 KFR(2)=-IDLAM(LKNT,2)+1
58335 C...Calculate width.
58336 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58338 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58339 C...KINEMATICS CHECK
58340 IF (XLAM(LKNT).EQ.0D0) THEN
58344 C * CHI+ -> NU_I + U_J + DBAR_K.
58346 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
58347 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
58348 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58350 C...Set coupling, and decay product masses on/off
58352 RVLAMC = 3. * GW2 * 5D-1 *
58353 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58354 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
58356 C...Resonance KF codes (1=I,2=J,3=K)
58357 KFR(1)=IDLAM(LKNT,1)-1
58358 KFR(2)=IDLAM(LKNT,2)-1
58360 C...Calculate width.
58361 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58363 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58364 C...KINEMATICS CHECK
58365 IF (XLAM(LKNT).EQ.0D0) THEN
58372 C...UDD TYPE R-VIOLATION
58373 C...These decays need special treatment since more than one BV coupling
58374 C...contributes (with interference). Consider e.g. (symbolically)
58375 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
58376 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
58377 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
58378 C...The problem is that a single call to PYRVGW would evaluate all
58379 C...these terms and sum them, but without the different couplings. The
58380 C...way out is to call PYRVGW three times, once for the first line, once
58381 C...for the second line, and then once for all the lines (it is
58382 C...impossible to get just the last line out) without multiplying by
58383 C...couplings. The last line is then obtained as the result of the third
58384 C...call minus the results of the two first calls. Each term is then
58385 C...multiplied by its respective coupling before the whole thing is
58386 C...summed up in XLAM.
58387 C...Note that with three interfering resonances, this procedure becomes
58388 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
58390 IF (IMSS(53).GE.1) THEN
58391 C...LOOP OVER DECAY MODES
58394 C...CHI+ -> U_I + U_J + D_K
58395 C...Decay mode I<->J symmetric.
58396 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
58398 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
58399 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
58400 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58402 C...Set coupling, and decay product masses on/off
58403 RVLAMC= 6. * GW2 * 5D-1
58404 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
58406 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
58408 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
58411 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
58412 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
58413 C...Resonance KF codes (1=I,2=J,3=K)
58414 KFR(1) = -IDLAM(LKNT,1)+1
58417 C...Calculate width.
58418 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58419 & IDLAM(LKNT,3),XRESI)
58420 C...Resonance KF codes (1=I,2=J,3=K)
58422 KFR(2) = -IDLAM(LKNT,2)+1
58424 C...Calculate width.
58425 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58426 & IDLAM(LKNT,3),XRESJ)
58427 C...Resonance KF codes (1=I,2=J,3=K)
58428 KFR(1) = -IDLAM(LKNT,1)+1
58429 KFR(2) = -IDLAM(LKNT,2)+1
58431 C...Calculate width.
58432 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58433 & IDLAM(LKNT,3),XRESIJ)
58434 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
58435 XRESIJ = XRESIJ-XRESI-XRESJ
58439 C...CALCULATE TOTAL WIDTH
58440 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
58441 & + RVLJIK*RVLIJK * XRESIJ
58442 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58443 C...KINEMATICS CHECK
58444 IF (XLAM(LKNT).EQ.0D0) THEN
58448 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
58449 C...Symmetry I<->J<->K.
58450 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
58451 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
58453 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
58454 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58455 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58457 C...Set coupling, and decay product masses on/off
58458 RVLAMC = 6. * GW2 * 5D-1
58459 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
58461 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
58463 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
58466 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
58467 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
58468 C...Collect symmetry factors
58469 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
58470 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
58471 & RVLAMC = 5D-1 * RVLAMC
58472 C...Resonance KF codes (1=I,2=J,3=K)
58473 KFR(1) = IDLAM(LKNT,1)-1
58476 C...Calculate width.
58477 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58478 & IDLAM(LKNT,3),XRESI)
58479 C...Resonance KF codes (1=I,2=J,3=K)
58481 KFR(2) = IDLAM(LKNT,2)-1
58483 C...Calculate width.
58484 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58485 & IDLAM(LKNT,3),XRESJ)
58486 C...Resonance KF codes (1=I,2=J,3=K)
58489 KFR(3) = IDLAM(LKNT,3)-1
58490 C...Calculate width.
58491 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58492 & IDLAM(LKNT,3),XRESK)
58493 C...Resonance KF codes (1=I,2=J,3=K)
58494 KFR(1) = IDLAM(LKNT,1)-1
58495 KFR(2) = IDLAM(LKNT,2)-1
58497 C...Calculate width.
58498 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58499 & IDLAM(LKNT,3),XRESIJ)
58500 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
58501 XRESIJ = XRESI+XRESJ-XRESIJ
58505 C...Resonance KF codes (1=I,2=J,3=K)
58507 KFR(2) = IDLAM(LKNT,2)-1
58508 KFR(3) = IDLAM(LKNT,3)-1
58509 C...Calculate width.
58510 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58511 & IDLAM(LKNT,3),XRESJK)
58512 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
58513 XRESJK = XRESJ+XRESK-XRESJK
58517 C...Resonance KF codes (1=I,2=J,3=K)
58518 KFR(1) = IDLAM(LKNT,1)-1
58520 KFR(3) = IDLAM(LKNT,3)-1
58521 C...Calculate width.
58522 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58523 & IDLAM(LKNT,3),XRESIK)
58524 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
58525 XRESIK = XRESI+XRESK-XRESIK
58529 C...CALCULATE TOTAL WIDTH
58531 & RVLIJK**2 * XRESI
58532 & + RVLJKI**2 * XRESJ
58533 & + RVLKIJ**2 * XRESK
58534 & + RVLIJK*RVLJKI * XRESIJ
58535 & + RVLIJK*RVLKIJ * XRESIK
58536 & + RVLJKI*RVLKIJ * XRESJK
58537 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
58538 C...KINEMATICS CHECK
58539 IF (XLAM(LKNT).EQ.0D0) THEN
58551 C*********************************************************************
58554 C...Calculates R-violating gluino decay widths.
58555 C...See BV part of PYRVCH for comments about the way the BV decay width
58556 C...is calculated. Same comments apply here.
58559 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
58561 C...Double precision and integer declarations.
58562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58563 IMPLICIT INTEGER(I-N)
58564 C...Parameter statement to help give large particle numbers.
58565 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58566 &KEXCIT=4000000,KDIMEN=5000000)
58568 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58569 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58570 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58571 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58572 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58573 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58574 C...Local variables.
58575 DOUBLE PRECISION XLAM(0:400)
58576 INTEGER IDLAM(400,3), PYCOMP
58577 C...Information from main routine to PYRVGW
58578 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58580 C...Auxiliary variables needed for BV (RV Gauge STOre)
58581 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
58583 C...Running quark masses
58584 DOUBLE PRECISION RMQ(6)
58585 C...Decay product masses on/off
58587 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
58590 C...IF LQD OR UDD TYPE R-VIOLATION ON.
58591 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
58595 C x=1-2 : Select A or B coupling (1:A ; 2:B)
58596 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58597 C 11-16:e,nu_e,mu,... not used here)
58598 C z=1-2 : Mass eigenstate number
58601 AB(1,I,1) = SFMIX(I,2)
58602 AB(1,I,2) = SFMIX(I,4)
58604 AB(2,I,1) = -SFMIX(I,1)
58605 AB(2,I,2) = -SFMIX(I,3)
58607 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
58609 IF (IMSS(52).GE.1) THEN
58610 C...STEP IN I,J,K USING SINGLE COUNTER
58612 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
58614 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58615 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58616 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58618 C...Set coupling, and decay product masses on/off
58619 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58622 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
58623 C...Resonance KF codes (1=I,2=J,3=K)
58625 KFR(2) = -IDLAM(LKNT,2)
58626 KFR(3) = -IDLAM(LKNT,3)
58627 C...Calculate width.
58628 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58631 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58632 C...Charge conjugate mode.
58634 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
58635 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
58636 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
58637 XLAM(LKNT) = XLAM(LKNT-1)
58638 C...KINEMATICS CHECK
58639 IF (XLAM(LKNT).EQ.0D0) THEN
58643 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
58645 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58646 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58647 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58649 C...Set coupling, and decay product masses on/off
58650 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58651 & **2* 5D-1 * GSTR2
58653 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
58654 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
58655 C...Resonance KF codes (1=I,2=J,3=K)
58657 KFR(2) = -IDLAM(LKNT,2)
58658 KFR(3) = -IDLAM(LKNT,3)
58659 C...Calculate width.
58660 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58662 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58663 C...Charge conjugate mode.
58665 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
58666 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
58667 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
58668 XLAM(LKNT) = XLAM(LKNT-1)
58669 C...KINEMATICS CHECK
58670 IF (XLAM(LKNT).EQ.0D0) THEN
58678 IF (IMSS(53).GE.1) THEN
58679 C...STEP IN I,J,K USING SINGLE COUNTER
58681 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
58682 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
58684 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
58685 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58686 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58688 C...Set coupling, and decay product masses on/off. A factor of 2 for
58689 C...(N_C-1) has been used to cancel a factor 0.5.
58690 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58693 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
58694 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
58695 C...Resonance KF codes (1=I,2=J,3=K)
58696 KFR(1) = IDLAM(LKNT,1)
58699 C...Calculate width.
58700 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58702 C...Resonance KF codes (1=I,2=J,3=K)
58704 KFR(2) = IDLAM(LKNT,2)
58706 C...Calculate width.
58707 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58709 C...Resonance KF codes (1=I,2=J,3=K)
58712 KFR(3) = IDLAM(LKNT,3)
58713 C...Calculate width.
58714 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58716 C...Resonance KF codes (1=I,2=J,3=K)
58717 KFR(1) = IDLAM(LKNT,1)
58718 KFR(2) = IDLAM(LKNT,2)
58720 C...Calculate width.
58721 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58723 C...Calculate interference function. (Factor -1/2 to make up for factor
58725 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
58726 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
58730 C...Resonance KF codes (1=I,2=J,3=K)
58732 KFR(2) = IDLAM(LKNT,2)
58733 KFR(3) = IDLAM(LKNT,3)
58734 C...Calculate width.
58735 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58737 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
58738 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
58742 C...Resonance KF codes (1=I,2=J,3=K)
58743 KFR(1) = IDLAM(LKNT,1)
58745 KFR(3) = IDLAM(LKNT,3)
58746 C...Calculate width.
58747 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58749 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
58750 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
58754 C...Calculate total width (factor 1/2 from 1/(N_C-1))
58755 XLAM(LKNT) = XRESI + XRESJ + XRESK
58756 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
58758 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58759 C...Charge conjugate mode.
58761 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
58762 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
58763 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
58764 XLAM(LKNT) = XLAM(LKNT-1)
58765 C...KINEMATICS CHECK
58766 IF (XLAM(LKNT).EQ.0D0) THEN
58776 C*********************************************************************
58779 C...Auxiliary function to PYRVSF for calculating R-Violating
58780 C...sfermion widths. Though the decay products are most often treated
58781 C...as massless in the calculation, the kinematical boundary of phase
58782 C...space is tested using the true masses.
58783 C...MODE = 1: All decay products massive
58784 C...MODE = 2: Decay product 1 massless
58785 C...MODE = 3: Decay product 2 massless
58786 C...MODE = 4: All decay products massless
58788 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
58790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58791 IMPLICIT INTEGER (I-N)
58792 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58793 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58794 SAVE /PYDAT1/,/PYDAT2/
58795 DOUBLE PRECISION SM(3)
58796 INTEGER PYCOMP, KC(3)
58800 SM(1)=PMAS(KC(1),1)**2
58801 SM(2)=PMAS(KC(2),1)**2
58802 SM(3)=PMAS(KC(3),1)**2
58803 C...Kinematics check
58804 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
58808 C...CM momenta squared
58809 IF (MODE.EQ.1) THEN
58810 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
58811 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
58812 ELSE IF (MODE.EQ.2) THEN
58813 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
58814 ELSE IF (MODE.EQ.3) THEN
58815 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58819 C...Calculate Width
58820 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58824 C*********************************************************************
58827 C...Generalized Matrix Element for R-Violating 3-body widths.
58829 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58832 IMPLICIT INTEGER (I-N)
58833 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58834 &KEXCIT=4000000,KDIMEN=5000000)
58835 PARAMETER (EPS=1D-4)
58836 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58837 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58839 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58840 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58841 DOUBLE PRECISION XLIM(3,3)
58842 INTEGER KC(0:3), PYCOMP
58843 LOGICAL DCMASS, DCHECK(6)
58844 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58848 KC(0) = PYCOMP(KFIN)
58849 KC(1) = PYCOMP(ID1)
58850 KC(2) = PYCOMP(ID2)
58851 KC(3) = PYCOMP(ID3)
58852 RMS(0) = PMAS(KC(0),1)
58853 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58854 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58855 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58856 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58857 XLIM(1,1)=(RMS(1)+RMS(2))**2
58858 XLIM(1,2)=(RMS(0)-RMS(3))**2
58859 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58860 XLIM(2,1)=(RMS(2)+RMS(3))**2
58861 XLIM(2,2)=(RMS(0)-RMS(1))**2
58862 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58863 XLIM(3,1)=(RMS(1)+RMS(3))**2
58864 XLIM(3,2)=(RMS(0)-RMS(2))**2
58865 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58866 C...Check Phase Space
58867 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58871 C...INITIALIZE RESONANCE INFORMATION
58874 IRES = 2*(JRES-1)+IMASS
58876 DCHECK(IRES) =.FALSE.
58877 C...NO RIGHT-HANDED NEUTRINOS
58878 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58879 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58880 & .KFR(JRES).EQ.0) GOTO 100
58881 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58882 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58883 INTRES(IRES,1) = IABS(KFR(JRES))
58884 INTRES(IRES,2) = IMASS
58885 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58886 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58890 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58892 C...RESONANCE CONTRIBUTIONS
58893 C...(Only sum contributions where the resonance is off shell).
58894 C...Store whether diagram on/off in DCHECK.
58895 C...LOOP OVER MASS STATES
58898 IF(INTRES(IDR,1).NE.0) THEN
58900 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58901 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58902 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58903 DCHECK(IDR) =.TRUE.
58904 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58909 IF(INTRES(IDR,1).NE.0) THEN
58910 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58911 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58912 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58913 DCHECK(IDR) =.TRUE.
58914 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58919 IF(INTRES(IDR,1).NE.0) THEN
58920 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58921 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58922 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58923 DCHECK(IDR) =.TRUE.
58924 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58928 C... L-R INTERFERENCES
58929 C... (Only add contributions where both contributing diagrams
58930 C... are non-resonant).
58932 IF (DCHECK(1).AND.DCHECK(2)) THEN
58933 C...Bug corrected 11/12 2001. Skands.
58934 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58935 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58936 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58940 IF (DCHECK(3).AND.DCHECK(4)) THEN
58941 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58942 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58943 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58947 IF (DCHECK(5).AND.DCHECK(6)) THEN
58948 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58949 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58950 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58952 C... TRUE INTERFERENCES
58953 C... (Only add contributions where both contributing diagrams
58954 C... are non-resonant).
58956 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58961 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58962 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58963 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58964 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58969 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58970 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58971 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58972 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58977 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58978 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58979 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58980 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58988 C*********************************************************************
58991 C...Function to integrate resonance contributions
58993 FUNCTION PYRVI1(ID1,ID2,ID3)
58996 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58997 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58998 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58999 LOGICAL MFLAG,DCMASS
59000 EXTERNAL PYRVG1,PYGAUS
59001 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59003 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59004 SAVE/PYRVNV/,/PYRVPM/
59005 C...Initialize mass and width information
59011 RESM(1)= RES(IDR,1)
59012 RESW(1)= RES(IDR,2)
59013 C...A->B and B->A for antisparticles
59014 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59015 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59016 C...Integration boundaries and mass flag
59017 LO = (RM(1)+RM(2))**2
59018 HI = (RM(0)-RM(3))**2
59020 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
59024 C*********************************************************************
59027 C...Function to integrate L-R interference contributions
59029 FUNCTION PYRVI2(ID1,ID2,ID3)
59032 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
59033 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59034 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59035 LOGICAL MFLAG,DCMASS
59036 EXTERNAL PYRVG2,PYGAUS
59037 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59039 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59040 SAVE/PYRVNV/,/PYRVPM/
59041 C...Initialize mass and width information
59047 RESM(1)= RES(IDR,1)
59048 RESW(1)= RES(IDR,2)
59049 RESM(2)= RES(IDR+1,1)
59050 RESW(2)= RES(IDR+1,2)
59051 C...A->B and B->A for antisparticles
59052 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59053 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59054 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
59055 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
59056 C...Boundaries and mass flag
59057 LO = (RM(1)+RM(2))**2
59058 HI = (RM(0)-RM(3))**2
59060 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
59064 C*********************************************************************
59067 C...Function to integrate true interference contributions
59069 FUNCTION PYRVI3(ID1,ID2,ID3)
59072 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
59073 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59074 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59075 LOGICAL MFLAG,DCMASS
59076 EXTERNAL PYRVG3,PYGAUS
59077 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59079 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59080 SAVE/PYRVNV/,/PYRVPM/
59081 C...Initialize mass and width information
59087 RESM(1)= RES(IDR,1)
59088 RESW(1)= RES(IDR,2)
59089 RESM(2)= RES(IDR2,1)
59090 RESW(2)= RES(IDR2,2)
59091 C...A -> B and B -> A for antisparticles
59092 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59093 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59094 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
59095 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
59096 C...Boundaries and mass flag
59097 LO = (RM(1)+RM(2))**2
59098 HI = (RM(0)-RM(3))**2
59100 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
59104 C*********************************************************************
59107 C...Integrand for resonance contributions
59112 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59113 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
59114 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
59117 RVR = PYRVR(X,RESM(1),RESW(1))
59118 C1 = 2D0*SQRT(MAX(0D0,X))
59119 IF (.NOT.MFLAG) THEN
59121 E3 = (RM(0)**2-X)/C1
59123 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
59125 E2 = (X-RM(1)**2+RM(2)**2)/C1
59126 E3 = (RM(0)**2-X-RM(3)**2)/C1
59127 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59128 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59129 DELTAY = 4D0*SR1*SR2
59130 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
59131 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
59132 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
59137 C*********************************************************************
59140 C...Integrand for L-R interference contributions
59145 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59146 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
59147 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
59150 C1 = 2D0*SQRT(MAX(0D0,X))
59151 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
59152 IF (.NOT.MFLAG) THEN
59154 E3 = (RM(0)**2-X)/C1
59156 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
59158 E2 = (X-RM(1)**2+RM(2)**2)/C1
59159 E3 = (RM(0)**2-X-RM(3)**2)/C1
59160 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59161 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59162 DELTAY = 4D0*SR1*SR2
59163 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
59164 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
59165 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
59170 C*********************************************************************
59173 C...Function to do Y integration over true interference contributions
59178 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59179 C...Second Dalitz variable for PYRVG4
59181 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
59182 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
59183 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
59185 EXTERNAL PYGAU2,PYRVG4
59186 SAVE/PYRVPM/,/PYG2DX/
59188 C1=2D0*SQRT(MAX(1D-9,X))
59190 IF (.NOT.MFLAG) THEN
59192 E3 = (RM(0)**2-X)/C1
59196 E2 = (X-RM(1)**2+RM(2)**2)/C1
59197 E3 = (RM(0)**2-X-RM(3)**2)/C1
59199 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59200 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59201 YMIN = SQ1-(SR1+SR2)**2
59202 YMAX = SQ1-(SR1-SR2)**2
59204 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
59208 C*********************************************************************
59211 C...Integrand for true intereference contributions
59216 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59218 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
59220 SAVE /PYRVPM/,/PYG2DX/
59222 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
59223 IF (.NOT.MFLAG) THEN
59224 PYRVG4 = RVS*B(1)*B(2)*X*Y
59226 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
59227 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
59228 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
59229 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
59234 C*********************************************************************
59237 C...Breit-Wigner for resonance contributions
59239 FUNCTION PYRVR(Mab2,RM,RW)
59242 DOUBLE PRECISION Mab2,RM,RW,PYRVR
59243 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
59247 C*********************************************************************
59250 C...Interference function
59252 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
59255 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
59256 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
59261 C*********************************************************************
59264 C...Stores one parton/particle in commonblock PYJETS.
59266 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
59268 C...Double precision and integer declarations.
59269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59270 IMPLICIT INTEGER(I-N)
59271 INTEGER PYK,PYCHGE,PYCOMP
59273 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59275 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59276 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59278 C...Standard checks.
59280 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59281 IPA=MAX(1,IABS(IP))
59282 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
59283 &'(PY1ENT:) writing outside PYJETS memory')
59285 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
59287 C...Find mass. Reset K, P and V vectors.
59289 IF(MSTU(10).EQ.1) PM=P(IPA,5)
59290 IF(MSTU(10).GE.2) PM=PYMASS(KF)
59297 C...Store parton/particle in K and P vectors.
59299 IF(IP.LT.0) K(IPA,1)=2
59302 P(IPA,4)=MAX(PE,PM)
59303 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
59304 P(IPA,1)=PA*SIN(THE)*COS(PHI)
59305 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
59306 P(IPA,3)=PA*COS(THE)
59308 C...Set N. Optionally fragment/decay.
59310 IF(IP.EQ.0) CALL PYEXEC
59315 C*********************************************************************
59318 C...Stores two partons/particles in their CM frame,
59319 C...with the first along the +z axis.
59321 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
59323 C...Double precision and integer declarations.
59324 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59325 IMPLICIT INTEGER(I-N)
59326 INTEGER PYK,PYCHGE,PYCOMP
59328 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59329 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59330 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59331 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59333 C...Standard checks.
59335 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59336 IPA=MAX(1,IABS(IP))
59337 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
59338 &'(PY2ENT:) writing outside PYJETS memory')
59341 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
59342 &'(PY2ENT:) unknown flavour code')
59344 C...Find masses. Reset K, P and V vectors.
59346 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59347 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59349 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59350 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59359 C...Check flavours.
59360 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59361 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59362 IF(MSTU(19).EQ.1) THEN
59365 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
59366 & '(PY2ENT:) unphysical flavour combination')
59371 C...Store partons/particles in K vectors for normal case.
59374 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
59377 C...Store partons in K vectors for parton shower evolution.
59381 K(IPA,4)=MSTU(5)*(IPA+1)
59383 K(IPA+1,4)=MSTU(5)*IPA
59384 K(IPA+1,5)=K(IPA+1,4)
59387 C...Check kinematics and store partons/particles in P vectors.
59388 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
59389 &'(PY2ENT:) energy smaller than sum of masses')
59390 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
59393 P(IPA,4)=SQRT(PM1**2+PA**2)
59396 P(IPA+1,4)=SQRT(PM2**2+PA**2)
59399 C...Set N. Optionally fragment/decay.
59401 IF(IP.EQ.0) CALL PYEXEC
59406 C*********************************************************************
59409 C...Stores three partons or particles in their CM frame,
59410 C...with the first along the +z axis and the third in the (x,z)
59411 C...plane with x > 0.
59413 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
59415 C...Double precision and integer declarations.
59416 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59417 IMPLICIT INTEGER(I-N)
59418 INTEGER PYK,PYCHGE,PYCOMP
59420 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59421 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59422 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59423 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59425 C...Standard checks.
59427 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59428 IPA=MAX(1,IABS(IP))
59429 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
59430 &'(PY3ENT:) writing outside PYJETS memory')
59434 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
59435 &'(PY3ENT:) unknown flavour code')
59437 C...Find masses. Reset K, P and V vectors.
59439 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59440 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59442 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59443 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59445 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
59446 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
59455 C...Check flavours.
59456 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59457 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59458 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
59459 IF(MSTU(19).EQ.1) THEN
59461 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
59462 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
59463 & KQ1+KQ3.EQ.4)) THEN
59465 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
59471 C...Store partons/particles in K vectors for normal case.
59474 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
59476 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
59479 C...Store partons in K vectors for parton shower evolution.
59485 IF(KQ1.EQ.-1) KCS=5
59486 K(IPA,KCS)=MSTU(5)*(IPA+1)
59487 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
59488 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
59489 K(IPA+1,9-KCS)=MSTU(5)*IPA
59490 K(IPA+2,KCS)=MSTU(5)*IPA
59491 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
59494 C...Check kinematics.
59496 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
59497 &0.5D0*X3*PECM.LE.PM3) MKERR=1
59498 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
59499 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
59500 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
59501 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
59502 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
59503 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
59504 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
59505 IF(MKERR.NE.0) CALL PYERRM(13,
59506 &'(PY3ENT:) unphysical kinematical variable setup')
59508 C...Store partons/particles in P vectors.
59510 P(IPA,4)=SQRT(PA1**2+PM1**2)
59512 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
59513 P(IPA+2,3)=PA3*CTHE3
59514 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
59516 P(IPA+1,1)=-P(IPA+2,1)
59517 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
59518 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
59521 C...Set N. Optionally fragment/decay.
59523 IF(IP.EQ.0) CALL PYEXEC
59528 C*********************************************************************
59531 C...Stores four partons or particles in their CM frame, with
59532 C...the first along the +z axis, the last in the xz plane with x > 0
59533 C...and the second having y < 0 and y > 0 with equal probability.
59535 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
59537 C...Double precision and integer declarations.
59538 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59539 IMPLICIT INTEGER(I-N)
59540 INTEGER PYK,PYCHGE,PYCOMP
59542 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59543 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59544 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59545 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59547 C...Standard checks.
59549 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59550 IPA=MAX(1,IABS(IP))
59551 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
59552 &'(PY4ENT:) writing outside PYJETS momory')
59557 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
59558 &'(PY4ENT:) unknown flavour code')
59560 C...Find masses. Reset K, P and V vectors.
59562 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59563 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59565 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59566 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59568 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
59569 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
59571 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
59572 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
59581 C...Check flavours.
59582 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59583 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59584 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
59585 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
59586 IF(MSTU(19).EQ.1) THEN
59588 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
59589 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
59590 & KQ1+KQ4.EQ.4)) THEN
59591 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
59594 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
59601 C...Store partons/particles in K vectors for normal case.
59604 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
59606 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
59609 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
59612 C...Store partons for parton shower evolution from q-g-g-qbar or
59614 ELSEIF(KQ1+KQ2.NE.0) THEN
59620 IF(KQ1.EQ.-1) KCS=5
59621 K(IPA,KCS)=MSTU(5)*(IPA+1)
59622 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
59623 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
59624 K(IPA+1,9-KCS)=MSTU(5)*IPA
59625 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
59626 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
59627 K(IPA+3,KCS)=MSTU(5)*IPA
59628 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
59630 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
59636 K(IPA,4)=MSTU(5)*(IPA+1)
59638 K(IPA+1,4)=MSTU(5)*IPA
59639 K(IPA+1,5)=K(IPA+1,4)
59640 K(IPA+2,4)=MSTU(5)*(IPA+3)
59641 K(IPA+2,5)=K(IPA+2,4)
59642 K(IPA+3,4)=MSTU(5)*(IPA+2)
59643 K(IPA+3,5)=K(IPA+3,4)
59646 C...Check kinematics.
59648 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
59649 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
59651 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
59652 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
59653 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
59654 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
59655 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
59656 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
59657 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
59658 STHE4=SQRT(1D0-CTHE4**2)
59659 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
59660 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
59661 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
59662 STHE2=SQRT(1D0-CTHE2**2)
59663 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
59664 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
59665 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
59666 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
59667 IF(MKERR.EQ.1) CALL PYERRM(13,
59668 &'(PY4ENT:) unphysical kinematical variable setup')
59670 C...Store partons/particles in P vectors.
59672 P(IPA,4)=SQRT(PA1**2+PM1**2)
59674 P(IPA+3,1)=PA4*STHE4
59675 P(IPA+3,3)=PA4*CTHE4
59676 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
59678 P(IPA+1,1)=PA2*STHE2*CPHI2
59679 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
59680 P(IPA+1,3)=PA2*CTHE2
59681 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
59683 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
59684 P(IPA+2,2)=-P(IPA+1,2)
59685 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
59686 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
59689 C...Set N. Optionally fragment/decay.
59691 IF(IP.EQ.0) CALL PYEXEC
59696 C*********************************************************************
59699 C...An interface from a two-fermion generator to include
59700 C...parton showers and hadronization.
59702 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
59704 C...Double precision and integer declarations.
59705 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59706 IMPLICIT INTEGER(I-N)
59707 INTEGER PYK,PYCHGE,PYCOMP
59709 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59710 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59711 SAVE /PYJETS/,/PYDAT1/
59713 DIMENSION IJOIN(2),INTAU(2)
59715 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59721 C...Loop through entries and pick up all final fermions/antifermions.
59725 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59727 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59728 IF(K(I,2).GT.0) THEN
59732 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
59738 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
59744 C...Check that event is arranged according to conventions.
59745 IF(I1.EQ.0.OR.I2.EQ.0) THEN
59746 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
59749 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
59752 C...Check whether fermion pair is quarks or leptons.
59753 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59755 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59758 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
59761 C...Decide whether to allow or not photon radiation in showers.
59763 IF(IRAD.EQ.0) MSTJ(41)=1
59765 C...Do colour joining and parton showers.
59768 IF(IQL12.EQ.1) THEN
59771 CALL PYJOIN(2,IJOIN)
59773 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59774 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59775 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59776 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59779 C...Do fragmentation and decays. Possibly except tau decay.
59783 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59797 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59805 C*********************************************************************
59808 C...An interface from a four-fermion generator to include
59809 C...parton showers and hadronization.
59811 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
59813 C...Double precision and integer declarations.
59814 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59815 IMPLICIT INTEGER(I-N)
59816 INTEGER PYK,PYCHGE,PYCOMP
59818 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59819 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59820 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59821 COMMON/PYINT1/MINT(400),VINT(400)
59822 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59824 DIMENSION IJOIN(2),INTAU(4)
59826 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59832 C...Loop through entries and pick up all final fermions/antifermions.
59838 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59840 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59841 IF(K(I,2).GT.0) THEN
59844 ELSEIF(I3.EQ.0) THEN
59847 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59852 ELSEIF(I4.EQ.0) THEN
59855 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59861 C...Check that event is arranged according to conventions.
59862 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59863 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59865 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59866 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59869 C...Check which fermion pairs are quarks and which leptons.
59870 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59872 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59875 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59877 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59879 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59882 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59885 C...Decide whether to allow or not photon radiation in showers.
59887 IF(IRAD.EQ.0) MSTJ(41)=1
59889 C...Decide on dipole pairing.
59894 IF(IQL12.EQ.IQL34) THEN
59897 DELTA=ATOTSQ-A1SQ-A2SQ
59898 IF(ISTRAT.EQ.1) THEN
59899 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59900 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59901 ELSEIF(ISTRAT.EQ.2) THEN
59902 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59903 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59905 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59911 C...If colour reconnection then bookkeep W+W- or Z0Z0
59912 C...and copy q qbar q qbar consecutively.
59913 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59922 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59926 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59940 P(N+1,J)=P(IP1,J)+P(IP2,J)
59941 P(N+2,J)=P(IP3,J)+P(IP4,J)
59953 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59955 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59961 C...Remove original q qbar q qbar and update counters.
59962 K(IP1,1)=K(IP1,1)+10
59963 K(IP2,1)=K(IP2,1)+10
59964 K(IP3,1)=K(IP3,1)+10
59965 K(IP4,1)=K(IP4,1)+10
59976 C...Do colour joinings and parton showers.
59977 IF(IQL12.EQ.1) THEN
59980 CALL PYJOIN(2,IJOIN)
59982 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59983 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59984 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59985 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59988 IF(IQL34.EQ.1) THEN
59991 CALL PYJOIN(2,IJOIN)
59993 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59994 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59995 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59996 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59999 C...Optionally do colour reconnection.
60002 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
60003 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
60007 C...Do fragmentation and decays. Possibly except tau decay.
60011 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
60025 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60033 C*********************************************************************
60036 C...An interface from a six-fermion generator to include
60037 C...parton showers and hadronization.
60039 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
60041 C...Double precision and integer declarations.
60042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60043 IMPLICIT INTEGER(I-N)
60044 INTEGER PYK,PYCHGE,PYCOMP
60046 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60047 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60048 SAVE /PYJETS/,/PYDAT1/
60050 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
60052 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60058 C...Loop through entries and pick up all final fermions/antifermions.
60066 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
60068 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
60069 IF(K(I,2).GT.0) THEN
60072 ELSEIF(I3.EQ.0) THEN
60074 ELSEIF(I5.EQ.0) THEN
60077 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
60082 ELSEIF(I4.EQ.0) THEN
60084 ELSEIF(I6.EQ.0) THEN
60087 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
60093 C...Check that event is arranged according to conventions.
60094 IF(I5.EQ.0.OR.I6.EQ.0) THEN
60095 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
60097 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
60098 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
60101 C...Check which fermion pairs are quarks and which leptons.
60102 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
60104 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
60107 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
60109 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
60111 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
60114 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
60116 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
60118 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
60121 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
60124 C...Decide whether to allow or not photon radiation in showers.
60126 IF(IRAD.EQ.0) MSTJ(41)=1
60128 C...Allow dipole pairings only among leptons and quarks separately.
60131 IF(IQL34.EQ.IQL56) P13D=P13
60133 IF(IQL12.EQ.IQL34) P21D=P21
60135 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
60137 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
60139 IF(IQL12.EQ.IQL56) P32D=P32
60141 C...Decide whether t+tbar.
60143 IF(PYR(0).LT.PTOP) THEN
60146 C...If t+tbar: reconstruct t's.
60152 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
60153 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
60161 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
60163 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
60167 C...If t+tbar: colour join t's and let them shower.
60170 CALL PYJOIN(2,IJOIN)
60171 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
60172 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
60173 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
60175 C...If t+tbar: pick up the t's after shower.
60179 IF(K(I,2).EQ.6) ITNEW=I
60180 IF(K(I,2).EQ.-6) ITBNEW=I
60183 C...If t+tbar: loop over two top systems.
60198 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
60199 & '(PY6FRM:) not b in t decay')
60201 C...If t+tbar: find boost from original to new top frame.
60203 BETAO(J)=P(ITO,J)/P(ITO,4)
60204 BETAN(J)=P(ITN,J)/P(ITN,4)
60207 C...If t+tbar: boost copy of b by t shower and connect it in colour.
60217 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60218 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60219 K(IB,4)=MSTU(5)*ITN
60220 K(IB,5)=MSTU(5)*ITN
60221 K(ITN,4)=K(ITN,4)+IB
60222 K(ITN,5)=K(ITN,5)+IB
60223 K(ITN,1)=K(ITN,1)+10
60224 K(IBO,1)=K(IBO,1)+10
60226 C...If t+tbar: construct W recoiling against b.
60234 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
60235 IF(IABS(KCHW).EQ.3) THEN
60236 K(IW,2)=ISIGN(24,KCHW)
60238 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
60242 C...If t+tbar: construct W momentum, including boost by t shower.
60244 P(IW,J)=P(IW1,J)+P(IW2,J)
60246 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
60248 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60249 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60251 C...If t+tbar: boost b and W to top rest frame.
60253 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
60255 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60256 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60258 C...If t+tbar: let b shower and pick up modified W.
60259 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
60260 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
60261 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
60263 IF(IABS(K(I,2)).EQ.24) IWM=I
60266 C...If t+tbar: take copy of W decay products.
60275 K(IW1,1)=K(IW1,1)+10
60276 K(IW2,1)=K(IW2,1)+10
60277 K(IWM,1)=K(IWM,1)+10
60291 C...If t+tbar: boost W decay products, first by effects of t shower,
60292 C...then by those of b shower. b and its shower simple boost back.
60293 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60294 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60295 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60296 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
60297 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
60298 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
60299 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
60300 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
60301 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
60305 C...Decide on dipole pairing.
60309 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
60310 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
60314 ELSEIF(PRN.LT.P12D+P13D) THEN
60318 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
60322 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
60326 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
60336 C...Do colour joinings and parton showers
60337 C...(except ones already made for t+tbar).
60339 IF(IQL12.EQ.1) THEN
60342 CALL PYJOIN(2,IJOIN)
60344 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
60345 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
60346 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
60347 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
60350 IF(IQL34.EQ.1) THEN
60353 CALL PYJOIN(2,IJOIN)
60355 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
60356 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
60357 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
60358 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
60360 IF(IQL56.EQ.1) THEN
60363 CALL PYJOIN(2,IJOIN)
60365 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
60366 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
60367 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
60368 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
60371 C...Do fragmentation and decays. Possibly except tau decay.
60375 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
60389 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60397 C*********************************************************************
60400 C...An interface from a four-parton generator to include
60401 C...parton showers and hadronization.
60403 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
60405 C...Double precision and integer declarations.
60406 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60407 IMPLICIT INTEGER(I-N)
60408 INTEGER PYK,PYCHGE,PYCOMP
60410 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60411 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60412 SAVE /PYJETS/,/PYDAT1/
60414 DIMENSION IJOIN(2),PTOT(4),BETA(3)
60416 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60422 C...Loop through entries and pick up all final partons.
60428 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
60430 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
60431 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
60434 ELSEIF(I3.EQ.0) THEN
60437 CALL PYERRM(16,'(PY4JET:) more than two quarks')
60439 ELSEIF(K(I,2).LT.0) THEN
60442 ELSEIF(I4.EQ.0) THEN
60445 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
60450 ELSEIF(I4.EQ.0) THEN
60453 CALL PYERRM(16,'(PY4JET:) more than two gluons')
60459 C...Check that event is arranged according to conventions.
60460 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
60461 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
60463 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
60464 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
60467 C...Check whether second pair are quarks or gluons.
60468 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
60470 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
60473 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
60476 C...Boost partons to their cm frame.
60478 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
60480 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
60482 BETA(J)=PTOT(J)/PTOT(4)
60484 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60485 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60486 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60487 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60490 C...Decide and set up shower history for q qbar q' qbar' events.
60491 IF(IQG34.EQ.1) THEN
60492 W1=PY4JTW(0,I1,I3,I4)
60493 W2=PY4JTW(0,I2,I3,I4)
60494 IF(W1.GT.PYR(0)*(W1+W2)) THEN
60495 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
60497 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
60500 C...Decide and set up shower history for q qbar g g events.
60502 W1=PY4JTW(I1,I3,I2,I4)
60503 W2=PY4JTW(I1,I4,I2,I3)
60504 W3=PY4JTW(0,I3,I1,I4)
60505 W4=PY4JTW(0,I4,I1,I3)
60506 W5=PY4JTW(0,I3,I2,I4)
60507 W6=PY4JTW(0,I4,I2,I3)
60508 W7=PY4JTW(0,I1,I3,I4)
60509 W8=PY4JTW(0,I2,I3,I4)
60510 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
60512 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
60513 ELSEIF(W1+W2.GT.WR) THEN
60514 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
60515 ELSEIF(W1+W2+W3.GT.WR) THEN
60516 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
60517 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
60518 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
60519 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
60520 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
60521 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
60522 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
60523 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
60524 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
60526 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
60530 C...Boost back original partons and mark them as deleted.
60531 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
60532 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
60533 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
60534 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
60540 C...Rotate shower initiating partons to be along z axis.
60541 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
60542 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
60543 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
60544 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
60546 C...Set up copy of shower initiating partons as on mass shell.
60556 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
60567 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
60568 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
60570 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
60572 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
60575 C...Decide whether to allow or not photon radiation in showers.
60576 C...Connect up colours.
60578 IF(IRAD.EQ.0) MSTJ(41)=1
60581 CALL PYJOIN(2,IJOIN)
60583 C...Decide on maximum virtuality and do parton shower.
60584 IF(PMAX.LT.PARJ(82)) THEN
60589 CALL PYSHOW(NSAV+1,-100,PQMAX)
60591 C...Rotate and boost back system.
60592 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
60594 C...Do fragmentation and decays.
60597 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60606 C*********************************************************************
60609 C...Auxiliary to PY4JET, to evaluate weight of configuration.
60611 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
60613 C...Double precision and integer declarations.
60614 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60615 IMPLICIT INTEGER(I-N)
60616 INTEGER PYK,PYCHGE,PYCOMP
60618 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60621 C...First case: when both original partons radiate.
60622 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
60625 P(N+1,J)=P(IA1,J)+P(IA2,J)
60626 P(N+2,J)=P(IA3,J)+P(IA4,J)
60628 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60630 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60632 Z1=P(IA1,4)/P(N+1,4)
60633 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
60634 Z2=P(IA3,4)/P(N+2,4)
60635 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
60637 C...Second case: when one original parton radiates to three.
60638 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
60641 P(N+2,J)=P(IA3,J)+P(IA4,J)
60642 P(N+1,J)=P(N+2,J)+P(IA2,J)
60644 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60646 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60648 IF(K(IA2,2).EQ.21) THEN
60649 Z1=P(N+2,4)/P(N+1,4)
60650 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
60653 Z1=P(IA2,4)/P(N+1,4)
60654 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
60657 Z2=P(IA3,4)/P(N+2,4)
60658 IF(K(IA2,2).EQ.21) THEN
60659 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
60661 ELSEIF(K(IA3,2).EQ.21) THEN
60662 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
60664 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
60674 C*********************************************************************
60677 C...Auxiliary to PY4JET, to set up chosen configuration.
60679 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
60681 C...Double precision and integer declarations.
60682 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60683 IMPLICIT INTEGER(I-N)
60684 INTEGER PYK,PYCHGE,PYCOMP
60686 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60698 C...First case: when both original partons radiate.
60699 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
60702 C...Set up flavour and history pointers for new partons.
60720 C...Set up momenta for new partons.
60722 P(N+1,J)=P(IA1,J)+P(IA2,J)
60723 P(N+2,J)=P(IA3,J)+P(IA4,J)
60729 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60731 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60733 QMAX=MIN(P(N+1,5),P(N+2,5))
60735 C...Second case: q radiates twice.
60736 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
60737 C...IA5=N+2 does not radiate.
60738 ELSEIF(K(IA2,2).EQ.21) THEN
60740 C...Set up flavour and history pointers for new partons.
60758 C...Set up momenta for new partons.
60760 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
60762 P(N+3,J)=P(IA3,J)+P(IA4,J)
60767 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60769 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
60773 C...Third case: q radiates g, g branches.
60774 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
60775 C...IA5=N+2 does not radiate.
60778 C...Set up flavour and history pointers for new partons.
60796 C...Set up momenta for new partons.
60798 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
60801 P(N+4,J)=P(IA3,J)+P(IA4,J)
60805 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60807 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
60817 C*********************************************************************
60820 C...Connects a sequence of partons with colour flow indices,
60821 C...as required for subsequent shower evolution (or other operations).
60823 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60825 C...Double precision and integer declarations.
60826 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60827 IMPLICIT INTEGER(I-N)
60828 INTEGER PYK,PYCHGE,PYCOMP
60830 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60831 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60832 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60833 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60837 C...Check that partons are of right types to be connected.
60838 IF(NJOIN.LT.2) GOTO 120
60842 IF(I.LE.0.OR.I.GT.N) GOTO 120
60843 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60845 IF(KC.EQ.0) GOTO 120
60846 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60847 IF(KQ.EQ.0) GOTO 120
60848 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60849 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60850 IF(IJN.EQ.1) KQS=KQ
60852 IF(KQSUM.NE.0) GOTO 120
60854 C...Connect the partons sequentially (closing for gluon loop).
60856 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60860 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60861 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60862 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60863 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60864 K(I,KCS)=MSTU(5)*IN
60865 K(I,9-KCS)=MSTU(5)*IP
60866 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60867 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60870 C...Error exit: no action taken.
60872 120 CALL PYERRM(12,
60873 &'(PYJOIN:) given entries can not be joined by one string')
60878 C*********************************************************************
60881 C...Sets values of commonblock variables.
60883 SUBROUTINE PYGIVE(CHIN)
60885 C...Double precision and integer declarations.
60886 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60887 IMPLICIT INTEGER(I-N)
60888 INTEGER PYK,PYCHGE,PYCOMP
60890 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60891 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60892 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60893 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60894 COMMON/PYDAT4/CHAF(500,2)
60896 COMMON/PYDATR/MRPY(6),RRPY(100)
60897 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60898 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60899 COMMON/PYINT1/MINT(400),VINT(400)
60900 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60901 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60902 COMMON/PYINT4/MWID(500),WIDS(500,5)
60903 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60904 COMMON/PYINT6/PROC(0:500)
60906 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60907 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60909 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60910 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60911 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60912 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60913 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60914 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60915 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60916 C...Local arrays and character variables.
60917 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60918 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60920 DIMENSION MSVAR(56,8)
60922 C...For each variable to be translated give: name,
60923 C...integer/real/character, no. of indices, lower&upper index bounds.
60924 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60925 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60926 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60927 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60928 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60929 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60930 &'ITCM','RTCM','IUED','RUED'/
60931 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60932 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60933 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60934 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60935 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60936 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60937 &1,1,1,6,4*0, 2,1,1,100,4*0,
60938 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60939 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60940 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60941 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60942 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60943 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60944 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60945 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60946 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60947 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60948 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60949 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60950 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60952 C...Length of character variable. Subdivide it into instructions.
60953 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60954 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60958 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60961 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60963 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60968 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60970 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60972 C...Send off decay-mode on/off commands to PYONOF.
60975 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60977 IF(IONOF.EQ.1) THEN
60982 C...Peel off any text following exclamation mark.
60984 DO 140 LLOW2=LHIG2,1,-1
60985 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60987 IF(LBIT.EQ.0) RETURN
60989 C...Identify commonblock variable.
60992 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60993 &LNAM.LE.6) GOTO 150
60994 CHNAM=CHBIT(1:LNAM-1)//' '
60995 DO 170 LCOM=1,LNAM-1
60997 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60998 & CHALP(2)(LALP:LALP)
61003 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
61006 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
61008 IF(LLOW.LT.LTOT) GOTO 120
61012 C...Identify any indices.
61017 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
61020 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
61022 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
61023 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
61024 & IVAR.EQ.37)) THEN
61025 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
61026 READ(CHIND,'(I8)') KF
61028 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
61030 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
61033 IF(LLOW.LT.LTOT) GOTO 120
61036 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61037 READ(CHIND,'(I8)') I1
61040 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
61043 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
61046 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
61048 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61049 READ(CHIND,'(I8)') I2
61051 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
61054 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
61057 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
61059 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61060 READ(CHIND,'(I8)') I3
61065 C...Check that indices allowed.
61067 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
61068 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
61070 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
61072 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
61074 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
61076 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
61079 IF(LLOW.LT.LTOT) GOTO 120
61083 C...Save old value of variable.
61086 ELSEIF(IVAR.EQ.2) THEN
61088 ELSEIF(IVAR.EQ.3) THEN
61090 ELSEIF(IVAR.EQ.4) THEN
61092 ELSEIF(IVAR.EQ.5) THEN
61094 ELSEIF(IVAR.EQ.6) THEN
61096 ELSEIF(IVAR.EQ.7) THEN
61098 ELSEIF(IVAR.EQ.8) THEN
61100 ELSEIF(IVAR.EQ.9) THEN
61102 ELSEIF(IVAR.EQ.10) THEN
61104 ELSEIF(IVAR.EQ.11) THEN
61106 ELSEIF(IVAR.EQ.12) THEN
61108 ELSEIF(IVAR.EQ.13) THEN
61110 ELSEIF(IVAR.EQ.14) THEN
61112 ELSEIF(IVAR.EQ.15) THEN
61114 ELSEIF(IVAR.EQ.16) THEN
61116 ELSEIF(IVAR.EQ.17) THEN
61117 CHOLD=CHAF(I1,I2)(1:8)
61118 ELSEIF(IVAR.EQ.18) THEN
61120 ELSEIF(IVAR.EQ.19) THEN
61122 ELSEIF(IVAR.EQ.20) THEN
61124 ELSEIF(IVAR.EQ.21) THEN
61126 ELSEIF(IVAR.EQ.22) THEN
61128 ELSEIF(IVAR.EQ.23) THEN
61130 ELSEIF(IVAR.EQ.24) THEN
61132 ELSEIF(IVAR.EQ.25) THEN
61134 ELSEIF(IVAR.EQ.26) THEN
61136 ELSEIF(IVAR.EQ.27) THEN
61138 ELSEIF(IVAR.EQ.28) THEN
61140 ELSEIF(IVAR.EQ.29) THEN
61142 ELSEIF(IVAR.EQ.30) THEN
61144 ELSEIF(IVAR.EQ.31) THEN
61146 ELSEIF(IVAR.EQ.32) THEN
61148 ELSEIF(IVAR.EQ.33) THEN
61149 IOLD=ICOL(I1,I2,I3)
61150 ELSEIF(IVAR.EQ.34) THEN
61152 ELSEIF(IVAR.EQ.35) THEN
61154 ELSEIF(IVAR.EQ.36) THEN
61156 ELSEIF(IVAR.EQ.37) THEN
61158 ELSEIF(IVAR.EQ.38) THEN
61160 ELSEIF(IVAR.EQ.39) THEN
61162 ELSEIF(IVAR.EQ.40) THEN
61164 ELSEIF(IVAR.EQ.41) THEN
61166 ELSEIF(IVAR.EQ.42) THEN
61167 ROLD=SIGT(I1,I2,I3)
61168 ELSEIF(IVAR.EQ.43) THEN
61170 ELSEIF(IVAR.EQ.44) THEN
61172 ELSEIF(IVAR.EQ.45) THEN
61174 ELSEIF(IVAR.EQ.46) THEN
61176 ELSEIF(IVAR.EQ.47) THEN
61178 ELSEIF(IVAR.EQ.48) THEN
61180 ELSEIF(IVAR.EQ.49) THEN
61182 ELSEIF(IVAR.EQ.50) THEN
61183 ROLD=RVLAM(I1,I2,I3)
61184 ELSEIF(IVAR.EQ.51) THEN
61185 ROLD=RVLAMP(I1,I2,I3)
61186 ELSEIF(IVAR.EQ.52) THEN
61187 ROLD=RVLAMB(I1,I2,I3)
61188 ELSEIF(IVAR.EQ.53) THEN
61190 ELSEIF(IVAR.EQ.54) THEN
61192 ELSEIF(IVAR.EQ.55) THEN
61194 ELSEIF(IVAR.EQ.56) THEN
61198 C...Print current value of variable. Loop back.
61199 IF(LNAM.GE.LBIT) THEN
61201 CHBIT(15:60)=' has the value '
61202 IF(MSVAR(IVAR,1).EQ.1) THEN
61203 WRITE(CHBIT(51:60),'(I10)') IOLD
61204 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61205 WRITE(CHBIT(47:60),'(F14.5)') ROLD
61206 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61211 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61213 IF(LLOW.LT.LTOT) GOTO 120
61217 C...Read in new variable value.
61218 IF(MSVAR(IVAR,1).EQ.1) THEN
61220 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
61221 READ(CHINI,'(I10)') INEW
61222 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61224 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
61226 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61227 CHNEW=CHBIT(LNAM+1:LBIT)//' '
61229 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
61232 C...Store new variable value.
61235 ELSEIF(IVAR.EQ.2) THEN
61237 ELSEIF(IVAR.EQ.3) THEN
61239 ELSEIF(IVAR.EQ.4) THEN
61241 ELSEIF(IVAR.EQ.5) THEN
61243 ELSEIF(IVAR.EQ.6) THEN
61245 ELSEIF(IVAR.EQ.7) THEN
61247 ELSEIF(IVAR.EQ.8) THEN
61249 ELSEIF(IVAR.EQ.9) THEN
61251 ELSEIF(IVAR.EQ.10) THEN
61253 ELSEIF(IVAR.EQ.11) THEN
61255 ELSEIF(IVAR.EQ.12) THEN
61257 ELSEIF(IVAR.EQ.13) THEN
61259 ELSEIF(IVAR.EQ.14) THEN
61261 ELSEIF(IVAR.EQ.15) THEN
61263 ELSEIF(IVAR.EQ.16) THEN
61265 ELSEIF(IVAR.EQ.17) THEN
61267 ELSEIF(IVAR.EQ.18) THEN
61269 ELSEIF(IVAR.EQ.19) THEN
61271 ELSEIF(IVAR.EQ.20) THEN
61273 ELSEIF(IVAR.EQ.21) THEN
61275 ELSEIF(IVAR.EQ.22) THEN
61277 ELSEIF(IVAR.EQ.23) THEN
61279 ELSEIF(IVAR.EQ.24) THEN
61281 ELSEIF(IVAR.EQ.25) THEN
61283 ELSEIF(IVAR.EQ.26) THEN
61285 ELSEIF(IVAR.EQ.27) THEN
61287 ELSEIF(IVAR.EQ.28) THEN
61289 ELSEIF(IVAR.EQ.29) THEN
61291 ELSEIF(IVAR.EQ.30) THEN
61293 ELSEIF(IVAR.EQ.31) THEN
61295 ELSEIF(IVAR.EQ.32) THEN
61297 ELSEIF(IVAR.EQ.33) THEN
61298 ICOL(I1,I2,I3)=INEW
61299 ELSEIF(IVAR.EQ.34) THEN
61301 ELSEIF(IVAR.EQ.35) THEN
61303 ELSEIF(IVAR.EQ.36) THEN
61305 ELSEIF(IVAR.EQ.37) THEN
61307 ELSEIF(IVAR.EQ.38) THEN
61309 ELSEIF(IVAR.EQ.39) THEN
61311 ELSEIF(IVAR.EQ.40) THEN
61313 ELSEIF(IVAR.EQ.41) THEN
61315 ELSEIF(IVAR.EQ.42) THEN
61316 SIGT(I1,I2,I3)=RNEW
61317 ELSEIF(IVAR.EQ.43) THEN
61319 ELSEIF(IVAR.EQ.44) THEN
61321 ELSEIF(IVAR.EQ.45) THEN
61323 ELSEIF(IVAR.EQ.46) THEN
61325 ELSEIF(IVAR.EQ.47) THEN
61327 ELSEIF(IVAR.EQ.48) THEN
61329 ELSEIF(IVAR.EQ.49) THEN
61331 ELSEIF(IVAR.EQ.50) THEN
61332 RVLAM(I1,I2,I3)=RNEW
61333 ELSEIF(IVAR.EQ.51) THEN
61334 RVLAMP(I1,I2,I3)=RNEW
61335 ELSEIF(IVAR.EQ.52) THEN
61336 RVLAMB(I1,I2,I3)=RNEW
61337 ELSEIF(IVAR.EQ.53) THEN
61339 ELSEIF(IVAR.EQ.54) THEN
61341 ELSEIF(IVAR.EQ.55) THEN
61343 ELSEIF(IVAR.EQ.56) THEN
61347 C...Write old and new value. Loop back.
61349 CHBIT(15:60)=' changed from to '
61350 IF(MSVAR(IVAR,1).EQ.1) THEN
61351 WRITE(CHBIT(33:42),'(I10)') IOLD
61352 WRITE(CHBIT(51:60),'(I10)') INEW
61353 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61354 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61355 WRITE(CHBIT(29:42),'(F14.5)') ROLD
61356 WRITE(CHBIT(47:60),'(F14.5)') RNEW
61357 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61358 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61361 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61363 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
61364 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
61367 IF(LLOW.LT.LTOT) GOTO 120
61369 C...Format statement for output on unit MSTU(11) (by default 6).
61370 5000 FORMAT(5X,A60)
61371 5100 FORMAT(5X,A88)
61376 C*********************************************************************
61379 C...Switches on and off decay channel by search for match.
61381 SUBROUTINE PYONOF(CHIN)
61383 C...Double precision and integer declarations.
61384 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61385 IMPLICIT INTEGER(I-N)
61386 INTEGER PYK,PYCHGE,PYCOMP
61388 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61389 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
61390 SAVE /PYDAT1/,/PYDAT3/
61391 C...Local arrays and character variables.
61392 INTEGER KFCMP(10),KFTMP(10)
61393 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
61395 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
61396 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
61398 C...Determine length of character variable.
61402 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
61405 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
61407 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
61409 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
61411 C...Find colon separator and particle code.
61413 120 LCOLON=LCOLON+1
61414 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
61416 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
61417 READ(CHCODE,'(I8)',ERR=300) KF
61420 C...Done if unknown code or no decay channels.
61422 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
61427 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
61428 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
61432 C...Find command name up to blank or equal sign.
61435 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
61436 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
61438 LMODE=LSEP-LCOLON-1
61439 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
61441 C...Convert to uppercase.
61442 DO 150 LCOM=1,LMODE
61444 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
61445 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
61449 C...Identify command. Failed if not identified.
61451 IF(CHMODE.EQ.'ALLOFF') MODE=1
61452 IF(CHMODE.EQ.'ALLON') MODE=2
61453 IF(CHMODE.EQ.'OFFIFANY') MODE=3
61454 IF(CHMODE.EQ.'ONIFANY') MODE=4
61455 IF(CHMODE.EQ.'OFFIFALL') MODE=5
61456 IF(CHMODE.EQ.'ONIFALL') MODE=6
61457 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
61458 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
61460 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
61464 C...Simple cases when all on or all off.
61465 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
61466 WRITE(MSTU(11),1000) KF,CHMODE
61467 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
61468 IF(MDME(IDC,1).LT.0) GOTO 160
61474 C...Identify matching list.
61478 IF(LBEG.GT.LEN) GOTO 190
61479 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
61480 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
61483 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
61484 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
61485 IF(LEND.LT.LEN) LEND=LEND-1
61487 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
61488 READ(CHCODE,'(I8)',ERR=300) KFREAD
61490 KFCMP(NCMP)=IABS(KFREAD)
61492 IF(NCMP.LT.10) GOTO 170
61494 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
61496 C...Only one matching required.
61497 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
61498 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
61499 IF(MDME(IDC,1).LT.0) GOTO 220
61501 KFNOW=IABS(KFDP(IDC,IKF))
61502 IF(KFNOW.EQ.0) GOTO 210
61504 IF(KFCMP(ICMP).EQ.KFNOW) THEN
61514 C...Multiple matchings required.
61515 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
61516 IF(MDME(IDC,1).LT.0) GOTO 260
61519 KFTMP(ITMP)=KFCMP(ITMP)
61523 KFNOW=IABS(KFDP(IDC,IKF))
61524 IF(KFNOW.EQ.0) GOTO 250
61527 IF(KFTMP(ITMP).EQ.KFNOW) THEN
61528 KFTMP(ITMP)=KFTMP(NTMP)
61534 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
61535 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
61536 & MDME(IDC,1)=MODE-7
61540 C...Error exit for impossible read of particle code.
61541 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
61544 C...Formats for output.
61545 1000 FORMAT(' Decays for',I8,' set ',A10)
61546 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
61550 C*********************************************************************
61553 C...Presets for a few specific underlying-event and min-bias tunes
61554 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
61555 C...others require particular versions of pythia (e.g. the SCI and GAL
61556 C...models). See below for details.
61557 SUBROUTINE PYTUNE(ITUNE)
61559 C ITUNE NAME (detailed descriptions below)
61560 C 0 Default : No settings changed => defaults.
61562 C ====== Old UE, Q2-ordered showers ====================================
61563 C 100 A : Rick Field's CDF Tune A (Oct 2002)
61564 C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
61565 C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
61566 C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
61567 C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
61568 C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
61569 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
61570 C 107 ACR : Tune A modified with new CR model (Mar 2007)
61571 C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
61572 C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
61573 C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
61574 C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
61575 C 111 AW-Pro : Tune AW, -"- (Oct 2008)
61576 C 112 BW-Pro : Tune BW, -"- (Oct 2008)
61577 C 113 DW-Pro : Tune DW, -"- (Oct 2008)
61578 C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
61579 C 115 QW-Pro : Tune QW, -"- (Oct 2008)
61580 C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
61581 C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
61582 C 118 D6-Pro : Tune D6, -"- (Oct 2008)
61583 C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
61584 C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
61585 C 129 Pro-Q2O : Professor Q2-ordered tune (Feb 2009)
61587 C ====== Intermediate and Hybrid Models ================================
61588 C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
61589 C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
61590 C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
61591 C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
61592 C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
61594 C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
61595 C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
61596 C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
61597 C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
61598 C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
61599 C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
61600 C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
61601 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
61602 C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
61603 C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
61604 C 311 S1-Pro : S1 -"- (Oct 2008)
61605 C 312 S2-Pro : S2 -"- (Oct 2008)
61606 C 313 S0A-Pro : S0A -"- (Oct 2008)
61607 C 314 NOCR-Pro : NOCR -"- (Oct 2008)
61608 C 315 Old-Pro : Old -"- (Oct 2008)
61609 C 316 ATLAS MC08 : pT-ordered showers, CTEQ6L1 (2008)
61610 C ---- Peter's Perugia Tunes : 320+ ------------------------------------
61611 C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
61612 C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
61613 C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
61614 C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
61615 C balance & different scaling to LHC & RHIC (Feb 2009)
61616 C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
61617 C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
61618 C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
61619 C 327 Perugia 10: Alternative to Perugia 0, with more FSR (May 2010)
61620 C off ISR, more BR breakup, more strangeness
61621 C 328 Perugia K : Alternative to Perugia 2010, with a (May 2010)
61622 C K-factor applied to MPI cross sections
61623 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
61624 C 329 Pro-pTO : Professor pT-ordered tune w. S0 CR model (Feb 2009)
61625 C ---- Tunes introduced in 6.4.23:
61626 C 330 ATLAS MC09 : pT-ordered showers, LO* PDFs (2009)
61627 C 331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009)
61628 C 334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI (Oct 2010)
61629 C 335 Pro-pT* : Professor Tune with LO* (Mar 2009)
61630 C 336 Pro-pT6 : Professor Tune with CTEQ6LL (Mar 2009)
61631 C 339 Pro-pT** : Professor Tune with LO** (Mar 2009)
61632 C 340 AMBT1 : First ATLAS tune including 7 TeV data (May 2010)
61633 C 341 Z1 : First CMS tune including 7 TeV data (Aug 2010)
61634 C 342 Z1-LEP : CMS tune Z1, with improved LEP parameters (Oct 2010)
61635 C 343 Z2 : Retune of Z1 by Field w CTEQ6L1 PDFs (2010)
61636 C 344 Z2-LEP : Retune of Z1 by Skands w CTEQ6L1 PDFs (Feb 2011)
61637 C 350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011)
61638 C 351 P2011 radHi : Variation with alphaS(pT/2)
61639 C 352 P2011 radLo : Variation with alphaS(2pT)
61640 C 353 P2011 mpiHi : Variation with more semi-hard MPI
61641 C 354 P2011 noCR : Variation without color reconnections
61642 C 355 P2011 LO** : Perugia 2011 using MSTW LO** PDFs (Mar 2011)
61643 C 356 P2011 C6 : Perugia 2011 using CTEQ6L1 PDFs (Mar 2011)
61644 C 357 P2011 T16 : Variation with PARP(90)=0.32 away from 7 TeV
61645 C 358 P2011 T32 : Variation with PARP(90)=0.16 awat from 7 TeV
61646 C 359 P2011 TeV : Perugia 2011 optimized for Tevatron (Mar 2011)
61647 C 360 S Global : Schulz-Skands Global fit (Mar 2011)
61648 C 361 S 7000 : Schulz-Skands at 7000 GeV (Mar 2011)
61649 C 362 S 1960 : Schulz-Skands at 1960 GeV (Mar 2011)
61650 C 363 S 1800 : Schulz-Skands at 1800 GeV (Mar 2011)
61651 C 364 S 900 : Schulz-Skands at 900 GeV (Mar 2011)
61652 C 365 S 630 : Schulz-Skands at 630 GeV (Mar 2011)
61654 C ======= The Uppsala models ===========================================
61655 C ( NB! must be run with special modified Pythia 6.215 version )
61656 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
61657 C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
61658 C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
61659 C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
61660 C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
61664 C Quick Dictionary:
61665 C BE : Bose-Einstein
61666 C BR : Beam Remnants
61667 C CR : Colour Reconnections
61668 C HAD: Hadronization
61669 C ISR/FSR: Initial-State Radiation / Final-State Radiation
61670 C FSI: Final-State Interactions (=CR+BE)
61671 C MB : Minimum-bias
61672 C MI : Multiple Interactions
61673 C UE : Underlying Event
61675 C=======================================================================
61676 C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
61677 C=======================================================================
61679 C A (100) and AW (101). CTEQ5L parton distributions
61680 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61681 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61682 C...Key feature: extensively compared to CDF data (R.D. Field).
61683 C...* Large starting scale for ISR (PARP(67)=4)
61684 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
61685 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61687 C BW (102). CTEQ5L parton distributions
61688 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61689 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61690 C...Key feature: extensively compared to CDF data (R.D. Field).
61691 C...NB: Can also be run with Pythia 6.2 or 6.312+
61692 C...* Small starting scale for ISR (PARP(67)=1)
61693 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
61694 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61696 C DW (103) and DWT (104). CTEQ5L parton distributions
61697 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61698 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61699 C...Key feature: extensively compared to CDF data (R.D. Field).
61700 C...NB: Can also be run with Pythia 6.2 or 6.312+
61701 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
61702 C...* DWT has a different reference energy, the same as the "S" models
61703 C... below, leading to more UE activity at the LHC, but less at RHIC.
61704 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61706 C QW (105). CTEQ61 parton distributions
61707 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61708 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61709 C...Key feature: uses CTEQ61 (external pdf library must be linked)
61711 C ATLAS-DC2 (106). CTEQ5L parton distributions
61712 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61713 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61714 C...Key feature: tune used by the ATLAS collaboration.
61716 C ACR (107). CTEQ5L parton distributions
61717 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
61718 C...Key feature: Tune A modified to use annealing CR.
61719 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
61721 C D6 (108) and D6T (109). CTEQ6L parton distributions
61722 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
61724 C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
61725 C Old UE model, Q2-ordered showers.
61726 C...Key feature: Rick Field's family of tunes revamped with the
61727 C...Professor Q2-ordered final-state shower and fragmentation tunes
61728 C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
61729 C...Key feature: improved descriptions of LEP data.
61731 C Pro-Q2O (129). CTEQ5L parton distributions
61732 C Old UE model, Q2-ordered showers.
61733 C...Key feature: Complete retune of old model by Professor, including
61734 C...large amounts of both LEP and Tevatron data.
61735 C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
61736 C...extreme in this tune, corresponding to using mu_R = pT/3 .
61738 C=======================================================================
61739 C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
61740 C=======================================================================
61742 C IM1 (200). Intermediate model, Q2-ordered showers,
61743 C CTEQ5L parton distributions
61744 C...Key feature: new UE model w Q2-ordered showers and no interleaving.
61745 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
61746 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
61748 C APT (201). Old UE model, pT-ordered final-state showers,
61749 C CTEQ5L parton distributions
61750 C...Key feature: Rick Field's Tune A, but with new final-state showers
61752 C APT-Pro (211). Old UE model, pT-ordered final-state showers,
61753 C CTEQ5L parton distributions
61754 C...Key feature: APT revamped with the Professor pT-ordered final-state
61755 C...shower and fragmentation tunes presented by Hendrik Hoeth at the
61756 C...Perugia MPI workshop in October 2008.
61758 C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
61759 C CTEQ5L parton distributions
61760 C...Key feature: APT-Pro with final-state showers off the MPI,
61761 C...lower ISR renormalization scale to improve agreement with the
61762 C...Tevatron Drell-Yan pT measurements and with improved energy scaling
61763 C...to min-bias at 630 GeV.
61765 C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
61766 C CTEQ6L1 parton distributions.
61767 C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
61768 C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
61769 C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
61771 C=======================================================================
61772 C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
61773 C=======================================================================
61775 C S0 (300) and S0A (303). CTEQ5L parton distributions
61776 C...Key feature: large amount of multiple interactions
61777 C...* Somewhat faster than the other colour annealing scenarios.
61778 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
61779 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
61780 C...* Small amount of radiation.
61781 C...* Large amount of low-pT MI
61782 C...* Low degree of proton lumpiness (broad matter dist.)
61783 C...* CR Type S (driven by free triplets), of medium strength.
61784 C...* See: Pythia6402 update notes or later.
61786 C S1 (301). CTEQ5L parton distributions
61787 C...Key feature: large amount of radiation.
61788 C...* Large amount of low-pT perturbative ISR
61789 C...* Large amount of FSR off ISR partons
61790 C...* Small amount of low-pT multiple interactions
61791 C...* Moderate degree of proton lumpiness
61792 C...* Least aggressive CR type (S+S Type I), but with large strength
61793 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61795 C S2 (302). CTEQ5L parton distributions
61796 C...Key feature: very lumpy proton + gg string cluster formation allowed
61797 C...* Small amount of radiation
61798 C...* Moderate amount of low-pT MI
61799 C...* High degree of proton lumpiness (more spiky matter distribution)
61800 C...* Most aggressive CR type (S+S Type II), but with small strength
61801 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61803 C NOCR (304). CTEQ5L parton distributions
61804 C...Key feature: no colour reconnections (NB: "Best fit" only).
61805 C...* NB: <pT>(Nch) problematic in this tune.
61806 C...* Small amount of radiation
61807 C...* Small amount of low-pT MI
61808 C...* Low degree of proton lumpiness
61809 C...* Large BR composite x enhancement factor
61810 C...* Most clever colour flow without CR ("Lambda ordering")
61812 C ATLAS-CSC (306). CTEQ6L parton distributions
61813 C...Key feature: 11-parameter ATLAS tune of the new framework.
61814 C...* Old (pre-annealing) colour reconnections a la 305.
61815 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61817 C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
61818 C...Key feature: the S0 family of tunes revamped with the Professor
61819 C...pT-ordered final-state shower and fragmentation tunes presented by
61820 C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
61821 C...Key feature: improved descriptions of LEP data.
61823 C ATLAS MC08 (316). CTEQ6L1 parton distributions
61824 C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs
61825 C...* Warning: uses Peterson fragmentation function for heavy quarks
61826 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61828 C Perugia-0 (320). CTEQ5L parton distributions.
61829 C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
61830 C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
61831 C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
61832 C...beam-remnant breakup (more baryon number transport), and suppression
61833 C...of CR in high-pT string pieces.
61835 C Perugia-HARD (321). CTEQ5L parton distributions.
61836 C...Key feature: More ISR, More FSR, Less MPI, Less BR
61837 C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
61838 C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
61839 C...baryon number transport), and more fragmentation pT.
61840 C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
61841 C...DY pT spectrum is HARD.
61843 C Perugia-SOFT (322). CTEQ5L parton distributions.
61844 C...Key feature: Less ISR, Less FSR, More MPI, More BR
61845 C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
61846 C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
61847 C...number transport), and less fragmentation pT.
61848 C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
61849 C...DY pT spectrum is SOFT
61851 C Perugia-3 (323). CTEQ5L parton distributions.
61852 C...Key feature: variant of Perugia-0 with more extreme energy scaling
61853 C...properties while still agreeing with Tevatron data from 630 to 1960.
61854 C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61855 C...allows FSR off the active end of dipoles stretched to the remnant.
61857 C Perugia-NOCR (324). CTEQ5L parton distributions.
61858 C...Key feature: Retune of NOCR-Pro with better scaling properties to
61859 C...lower energies and somewhat better agreement with Tevatron data
61862 C Perugia-* (325). MRST LO* parton distributions for generators
61863 C...Key feature: first attempt at using the LO* distributions
61864 C...(external pdf library must be linked).
61866 C Perugia-6 (326). CTEQ6L1 parton distributions
61867 C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61869 C Perugia-2010 (327). CTEQ5L parton distributions
61870 C...Key feature: Retune of Perugia 0 to attempt to better describe
61871 C...strangeness yields at RHIC and at LEP. Also increased the amount
61872 C...of FSR off ISR following the conclusions in arXiv:1001.4082.
61873 C...Increased the amount of beam blowup, causing more baryon transport
61874 C...into the detector, to further explore this possibility. Using
61875 C...a new color-reconnection model that relies on determining a thrust
61876 C...axis for the events and then computing reconnection probabilities for
61877 C...the individual string pieces based on the actual string densities
61878 C...per rapidity interval along that thrust direction.
61880 C Perugia-K (328). CTEQ5L parton distributions
61881 C...Key feature: uses a ``K'' factor on the MPI cross sections
61882 C...This gives a larger rate of minijets and pushes the underlying-event
61883 C...activity towards higher pT. To compensate for the increased activity
61884 C...at higher pT, the infared regularization scale is larger for this tune.
61886 C Pro-pTO (329). CTEQ5L parton distributions
61887 C...Key feature: Complete retune of new model by Professor, including
61888 C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61890 C ATLAS MC09 (330). LO* parton distributions
61891 C...Key feature: Good overall agreement with Tevatron and early LHC data.
61892 C...Similar to Perugia *.
61894 C ATLAS MC09c (331). LO* parton distributions
61895 C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data.
61896 C...Similar to Perugia *. Retuned CR model with respect to MC09.
61898 C Pro-pT* (335) LO* parton distributions
61899 C...Key feature: Retune of Pro-PTO with MRST LO* PDFs.
61901 C Pro-pT6 (336). CTEQ6L1 parton distributions
61902 C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs.
61904 C Pro-pT** (339). LO** parton distributions
61905 C...Key feature: Retune of Pro-PTO with MRST LO** PDFs.
61907 C AMBT1 (340). LO* parton distributions
61908 C...Key feature: First ATLAS tune including 7-TeV LHC data.
61909 C...Mainly retuned CR and mass distribution with respect to MC09c.
61910 C...Note: cannot be run standalone since it uses external PDFs.
61912 C CMSZ1 (341). CTEQ5L parton distributions
61913 C...Key feature: First CMS tune including 7-TeV LHC data.
61914 C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs,
61915 C...has a lower pT0 at the Tevatron, which scales faster with energy.
61917 C Z1-LEP (342). CTEQ5L parton distributions
61918 C...Key feature: CMS tune Z1 with improved LEP parameters, mostly
61919 C...taken from the Professor/Perugia tunes, with a few minor updates.
61921 C=======================================================================
61923 C=======================================================================
61925 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61926 C...with an unmodified Pythia distribution.
61927 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61929 C ::: + Future improvements?
61930 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61931 C (problem: K-factor affects everything so only works as
61932 C intended for min-bias, not for UE ... probably need a
61933 C better long-term solution to handle UE as well. Anyway,
61934 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61936 C...Global statements
61937 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61938 INTEGER PYK,PYCHGE,PYCOMP
61941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61942 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61944 C...SCI and GAL Commonblocks
61945 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61947 C...SAVE statements
61948 SAVE /PYDAT1/,/PYPARS/
61951 C...Internal parameters
61952 PARAMETER(MXTUNS=500)
61954 PARAMETER (CHDOC='Mar 2011')
61955 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61956 CHARACTER*42 CHMSTJ(50), CHMSTP(100), CHPARP(100),
61957 & CHPARJ(100), CHMSTU(101:121), CHPARU(101:121), CH40
61960 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61961 DATA (CHNAMS(I),I=100,119)/
61962 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61963 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61964 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61965 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61966 1 'Tune D6-Pro','Tune D6T-Pro'/
61967 DATA (CHNAMS(I),I=120,129)/
61969 DATA (CHNAMS(I),I=300,309)/
61970 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61971 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61972 DATA (CHNAMS(I),I=310,316)/
61973 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61974 & 'NOCR-Pro','Old-Pro','ATLAS MC08'/
61975 DATA (CHNAMS(I),I=320,329)/
61976 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61977 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61978 & 'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/
61979 DATA (CHNAMS(I),I=330,349)/
61980 & 'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*',
61981 & 'Pro-PT6',' ',' ','Pro-PT**',
61982 4 'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP',
61984 DATA (CHNAMS(I),I=350,359)/
61985 & 'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi',
61986 & 'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1',
61987 & 'P2011 T16','P2011 T32','P2011 Tevatron'/
61988 DATA (CHNAMS(I),I=360,369)/
61989 & 'S Global','S 7000','S 1960','S 1800',
61990 & 'S 900','S 630', 4*' '/
61991 DATA (CHNAMS(I),I=200,229)/
61992 & 'IM Tune 1','Tune APT',8*' ',
61993 & ' ','Tune APT-Pro',8*' ',
61994 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61995 DATA (CHNAMS(I),I=400,409)/
61996 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61997 DATA (CHMSTJ(I),I=11,20)/
61998 & 'HAD choice of fragmentation function(s)',4*' ',
61999 & 'HAD treatment of small-mass systems',4*' '/
62000 DATA (CHMSTJ(I),I=41,50)/
62001 & 'FSR type (Q2 or pT) for old framework',9*' '/
62002 DATA (CHMSTP(I),I=1,10)/
62003 & 2*' ','INT switch for choice of LambdaQCD',7*' '/
62004 DATA (CHMSTP(I),I=31,40)/
62005 & 2*' ','"K" switch for K-factor on/off & type',7*' '/
62006 DATA (CHMSTP(I),I=51,100)/
62007 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
62008 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
62009 6 'ISR coherence option for 1st emission',
62010 6 'ISR phase space choice & ME corrections',' ',
62011 7 'ISR IR regularization scheme',' ',
62012 7 'IFSR scheme for non-decay FSR',8*' ',
62014 8 'UE hadron transverse mass distribution',5*' ',
62015 8 'BR composite scheme','BR color scheme',
62016 9 'BR primordial kT compensation',
62017 9 'BR primordial kT distribution',
62018 9 'BR energy partitioning scheme',2*' ',
62019 9 'FSI color (re-)connection model',5*' '/
62020 DATA (CHPARP(I),I=1,10)/
62021 & 'ME/UE LambdaQCD',9*' '/
62022 DATA (CHPARP(I),I=31,40)/
62023 & ' ','"K" K-factor',8*' '/
62024 DATA (CHPARP(I),I=61,100)/
62025 6 'ISR LambdaQCD','ISR IR cutoff',' ',
62026 6 'ISR renormalization scale prefactor',
62027 6 2*' ','ISR Q2max factor',3*' ',
62028 7 'IFSR Q2max factor in non-s-channel procs',
62029 7 'IFSR LambdaQCD (outside resonance decays)',4*' ',
62030 7 'FSI color reco high-pT damping strength',
62031 7 'FSI color reconnection strength',
62032 7 'BR composite x enhancement','BR breakup suppression',
62033 8 2*'UE IR cutoff at reference ecm',
62034 8 2*'UE mass distribution parameter',
62035 8 'UE gg color correlated fraction','UE total gg fraction',
62037 8 'UE IR cutoff reference ecm',
62038 8 'UE IR cutoff ecm scaling power',
62039 9 'BR primordial kT width <|kT|>',' ',
62040 9 'BR primordial kT UV cutoff',7*' '/
62041 DATA (CHPARJ(I),I=1,30)/
62042 & 'HAD diquark suppression','HAD strangeness suppression',
62043 & 'HAD strange diquark suppression',
62044 & 'HAD vector diquark suppression','HAD P(popcorn)',
62045 & 'HAD extra popcorn B(s)-M-B(s) supp',
62046 & 'HAD extra popcorn B-M(s)-B supp',
62048 1 'HAD P(vector meson), u and d only',
62049 1 'HAD P(vector meson), contains s',
62050 1 'HAD P(vector meson), heavy quarks',7*' ',
62051 2 'HAD fragmentation pT',' ',' ',' ',
62052 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
62053 DATA (CHPARJ(I),I=41,90)/
62054 4 'HAD string parameter a(Meson)','HAD string parameter b',
62055 4 2*' ','HAD string a(Baryon)-a(Meson)',
62056 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
62057 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
62058 5 3*' ', 'HAD charm parameter','HAD bottom parameter',5*' ',
62060 8 'FSR LambdaQCD (inside resonance decays)',
62061 & 'FSR IR cutoff',8*' '/
62062 DATA (CHMSTU(I),I=111,120)/
62063 1 ' ','INT n(flavors) for LambdaQCD',8*' '/
62064 DATA (CHPARU(I),I=111,120)/
62065 1 ' ','INT LambdaQCD',8*' '/
62067 C...1) Shorthand notation
62070 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
62071 CHNAME=CHNAMS(ITUNE)
62072 IF (ITUNE.EQ.0) GOTO 9999
62074 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
62079 IF (M13.GE.1) WRITE(M11,5000) CHDOC
62081 C...Hardcode some defaults
62082 C...Get Lambda from PDF
62090 C...3) Tune parameters
62092 C=======================================================================
62095 IF (ITUNE.EQ.316) THEN
62097 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62098 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62099 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62103 C...First set some explicit defaults from 6.4.20
62106 C...# Old default flavour parameters
62119 C...PDFs: CTEQ6L1 for 326
62123 C...UE and ISR switches
62146 C...FSR inside resonance decays
62149 C...Fragmentation (warning: uses Peterson)
62156 CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62157 WRITE(M11,5030) CH60
62158 CH60='Physics model: '//
62159 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
62160 WRITE(M11,5030) CH60
62161 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
62162 WRITE(M11,5030) CH60
62165 WRITE(M11,5030) ' '
62166 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62167 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62168 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
62169 IF (MSTP(70).EQ.0) THEN
62170 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62172 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
62173 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62174 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
62175 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62176 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62177 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62178 WRITE(M11,5030) CH60
62179 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
62180 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
62181 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62182 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62183 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62184 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
62185 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62186 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62187 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62188 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62189 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62190 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62191 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62192 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62193 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62194 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62195 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62196 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62197 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62198 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62199 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62200 IF (MSTP(95).GE.1) THEN
62201 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62202 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
62207 C=======================================================================
62208 C...ATLAS MC09, MC09c, AMBT1
62209 C...CMS Z1 (R. Field), Z1-LEP
62211 ELSEIF (ITUNE.EQ.330.OR.ITUNE.EQ.331.OR.ITUNE.EQ.340.OR.
62212 & ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62214 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62215 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62216 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62220 C...First set some explicit defaults from 6.4.20
62221 IF (ITUNE.LE.341.OR.ITUNE.EQ.343) THEN
62222 C... # Old defaults
62224 C...# Old default flavour parameters
62237 C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia
62247 C...# Switch on Bowler:
62249 C...# Fragmentation
62261 IF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
62265 ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
62271 C...UE and ISR switches
62282 IF (ITUNE.EQ.331) THEN
62284 ELSEIF (ITUNE.EQ.340) THEN
62288 ELSEIF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62289 C...Z1 and Z2 use the AMBT1 CR values
62300 IF (ITUNE.EQ.331) THEN
62303 ELSEIF (ITUNE.EQ.340) THEN
62308 ELSEIF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
62313 ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
62323 IF (ITUNE.GE.340) THEN
62328 IF (ITUNE.GE.340) THEN
62332 C...FSR inside resonance decays
62335 C...Fragmentation (org 6.4 defs hardcoded)
62340 C...AMBT1 mentions 46 explicitly, but Z1 doesn't ...
62342 IF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62343 C...Reset PARJ(46) to org def value for Z1 and Z2
62348 IF (ITUNE.LT.340) THEN
62349 CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62350 ELSEIF (ITUNE.EQ.340) THEN
62351 CH60='Tuned by ATLAS, ATLAS-CONF-2010-031'
62352 ELSEIF (ITUNE.EQ.341) THEN
62353 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62354 WRITE(M11,5030) CH60
62355 CH60='Z1 variation tuned by R. D. Field (CMS)'
62356 ELSEIF (ITUNE.EQ.342) THEN
62357 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62358 WRITE(M11,5030) CH60
62359 CH60='Z1 variation retuned by R. D. Field (CMS)'
62360 WRITE(M11,5030) CH60
62361 CH60='Z1-LEP variation retuned by Professor / P. Skands'
62362 ELSEIF (ITUNE.EQ.343) THEN
62363 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62364 WRITE(M11,5030) CH60
62365 CH60='Z2 variation retuned by R. D. Field (CMS)'
62366 ELSEIF (ITUNE.EQ.344) THEN
62367 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62368 WRITE(M11,5030) CH60
62369 CH60='Z2 variation retuned by R. D. Field (CMS)'
62370 WRITE(M11,5030) CH60
62371 CH60='Z2-LEP variation retuned by Professor / P. Skands'
62373 WRITE(M11,5030) CH60
62374 CH60='Physics Model: '//
62375 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
62376 WRITE(M11,5030) CH60
62377 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
62378 WRITE(M11,5030) CH60
62381 WRITE(M11,5030) ' '
62382 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62383 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62384 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
62385 IF (MSTP(70).EQ.0) THEN
62386 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62388 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
62389 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62390 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
62391 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62392 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62393 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62394 WRITE(M11,5030) CH60
62395 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
62396 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
62397 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62398 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62399 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62400 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
62401 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62402 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62403 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62404 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62405 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62406 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62407 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62408 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62409 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62410 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62411 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62412 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62413 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62414 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62415 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62416 IF (MSTP(95).GE.1) THEN
62417 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62418 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
62423 C=======================================================================
62424 C...S0, S1, S2, S0A, NOCR, Rap,
62425 C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
62426 C...Perugia 0, HARD, SOFT, 3, LO*, 6, 2010, K
62427 C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT**
62428 C...Perugia 2011 (incl variations)
62429 C...Schulz-Skands tunes
62430 ELSEIF ((ITUNE.GE.300.AND.ITUNE.LE.305)
62431 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
62432 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.329)
62433 & .OR.(ITUNE.GE.334.AND.ITUNE.LE.336).OR.ITUNE.EQ.339
62434 & .OR.(ITUNE.GE.350.AND.ITUNE.LE.365)) THEN
62435 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62436 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62437 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62439 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.339.AND.ITUNE.NE.324.AND.
62440 & ITUNE.NE.334.AND.
62441 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
62443 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62445 ELSEIF((ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.GE.350).AND.
62446 & (MSTP(181).LE.5.OR.
62447 & (MSTP(181).EQ.6.AND.MSTP(182).LE.422)))
62449 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62453 C...Use 327 as base tune for 350-359 (Perugia 2011)
62455 IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327
62456 C...Use 320 as base tune for 360+ (Schulz-Skands)
62457 IF (ITUNE.GE.360) ITUNE = 320
62459 C...HAD: Use Professor's LEP pars if ITUNE >= 310
62460 C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
62461 IF (ITUNE.LT.310) THEN
62464 C...# Old default flavour parameters
62477 ELSEIF (ITUNE.GE.310) THEN
62478 C...# Tuned flavour parameters:
62488 C...# Always use pT-ordered shower:
62490 C...# Switch on Bowler:
62492 C...# Fragmentation
62500 C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
62501 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
62502 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
62504 C...HAD: P-2010 and P-K use different strangeness parameters
62505 C... indicated by LEP and RHIC yields.
62506 C...(only 5% different from Professor values, so should be within acceptable
62507 C...theoretical uncertainty range)
62508 C...(No attempt made to retune other flavor parameters post facto)
62509 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62523 C...Remove middle digit now for Professor variants, since identical pars
62525 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
62526 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
62529 C...PDFs: all use CTEQ5L as starting point
62532 IF (ITUNE.EQ.325.OR.ITUNE.EQ.335) THEN
62533 C...MRST LO* for 325 and 335
62536 ELSEIF (ITUNE.EQ.326.OR.ITUNE.EQ.336) THEN
62537 C...CTEQ6L1 for 326 and 336
62540 ELSEIF (ITUNE.EQ.339) THEN
62541 C...MRST LO** for 339
62546 C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF
62548 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62550 C...Hardcode CTEQ5L values for ME and ISR
62552 PARU(112) = 0.192D0
62555 C...but use LEP value also for non-res FSR
62559 C...ISR: use Lambda_MSbar with default scale for S0(A)
62562 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.ITUNE.EQ.334
62563 & .OR.ITUNE.EQ.326.OR.ITUNE.EQ.327.OR.ITUNE.EQ.328) THEN
62564 C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
62567 ELSEIF (ITUNE.EQ.321) THEN
62568 C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
62571 ELSEIF (ITUNE.EQ.322) THEN
62572 C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
62575 ELSEIF (ITUNE.EQ.325) THEN
62576 C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
62579 ELSEIF (ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
62580 & ITUNE.EQ.339) THEN
62581 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
62584 IF (ITUNE.EQ.335) PARP(64)=0.92D0
62585 IF (ITUNE.EQ.336) PARP(64)=0.89D0
62586 IF (ITUNE.EQ.339) PARP(64)=0.97D0
62589 C...ISR : power-suppressed power showers above s_color (since 6.4.19)
62592 C...Perugia tunes have stronger suppression, except HARD
62593 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62595 IF (ITUNE.EQ.321) PARP(67)=4D0
62596 IF (ITUNE.EQ.322) PARP(67)=0.25D0
62599 C...ISR IR cutoff type and FSR off ISR setting:
62600 C...Smooth ISR, low FSR-off-ISR
62603 IF (ITUNEB.EQ.301) THEN
62604 C...S1, S1-Pro: sharp ISR, high FSR
62607 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
62608 & .OR.ITUNE.EQ.325) THEN
62609 C...Perugia default is smooth ISR, high FSR-off-ISR
62612 ELSEIF (ITUNE.EQ.321) THEN
62613 C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
62617 ELSEIF (ITUNE.EQ.322) THEN
62618 C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
62622 ELSEIF (ITUNE.EQ.323) THEN
62623 C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62627 ELSEIF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62628 C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62633 C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
62634 C...by Professor tunes (with HARD and SOFT variations)
62636 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62638 IF (ITUNE.EQ.321) PARP(71)=4D0
62639 IF (ITUNE.EQ.322) PARP(71)=1D0
62641 IF (ITUNE.EQ.329) PARP(71)=2D0
62642 IF (ITUNE.EQ.335) PARP(71)=1.29D0
62643 IF (ITUNE.EQ.336) PARP(71)=1.72D0
62644 IF (ITUNE.EQ.339) PARP(71)=1.20D0
62646 C...FSR: Lambda_FSR scale (only if not using professor)
62647 IF (ITUNE.LT.310) PARJ(81)=0.23D0
62648 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
62649 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
62651 C...K-factor : only 328 uses a K-factor on the UE cross sections
62653 IF (ITUNE.EQ.328) THEN
62657 C...UE on, new model
62660 C...UE: hadron-hadron overlap profile (expOfPow for all)
62662 C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
62664 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
62665 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
62666 C...NOCR variants have very smooth distributions
62667 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
62668 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
62669 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62670 C...Perugia variants have slightly smoother profiles by default
62671 C...(to compensate for more tail by added radiation)
62672 C...Perugia-SOFT has more peaked distribution, NOCR less peaked
62674 IF (ITUNE.EQ.322) PARP(83)=1.5D0
62675 IF (ITUNE.EQ.327) PARP(83)=1.5D0
62676 IF (ITUNE.EQ.328) PARP(83)=1.5D0
62677 C...NOCR variants have smoother mass profiles
62678 IF (ITUNE.EQ.324) PARP(83)=1.8D0
62679 IF (ITUNE.EQ.334) PARP(83)=1.8D0
62681 C...Professor-pT0 also has very smooth distribution
62682 IF (ITUNE.EQ.329) PARP(83)=1.8
62683 IF (ITUNE.EQ.335) PARP(83)=1.68
62684 IF (ITUNE.EQ.336) PARP(83)=1.72
62685 IF (ITUNE.EQ.339) PARP(83)=1.67
62687 C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
62689 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
62690 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
62691 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
62692 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
62693 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62694 C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
62695 C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
62696 C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
62697 C...slightly higher, due to increased activity.
62699 IF (ITUNE.EQ.321) PARP(82)=2.3D0
62700 IF (ITUNE.EQ.322) PARP(82)=1.9D0
62701 IF (ITUNE.EQ.323) PARP(82)=2.2D0
62702 IF (ITUNE.EQ.324) PARP(82)=1.95D0
62703 IF (ITUNE.EQ.325) PARP(82)=2.2D0
62704 IF (ITUNE.EQ.326) PARP(82)=1.95D0
62705 IF (ITUNE.EQ.327) PARP(82)=2.05D0
62706 IF (ITUNE.EQ.328) PARP(82)=2.45D0
62707 IF (ITUNE.EQ.334) PARP(82)=2.15D0
62709 C...Professor-pT0 maintains low pT0 vaue
62710 IF (ITUNE.EQ.329) PARP(82)=1.85D0
62711 IF (ITUNE.EQ.335) PARP(82)=2.10D0
62712 IF (ITUNE.EQ.336) PARP(82)=1.83D0
62713 IF (ITUNE.EQ.339) PARP(82)=2.28D0
62715 C...UE: IR cutoff reference energy and default energy scaling pace
62718 C...S0A, S0A-Pro have tune A energy scaling
62719 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
62720 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62721 C...Perugia tunes explicitly include MB at 630 to fix energy scaling
62723 IF (ITUNE.EQ.321) PARP(90)=0.30D0
62724 IF (ITUNE.EQ.322) PARP(90)=0.24D0
62725 IF (ITUNE.EQ.323) PARP(90)=0.32D0
62726 IF (ITUNE.EQ.324) PARP(90)=0.24D0
62727 C...LO* and CTEQ6L1 tunes have slower energy scaling
62728 IF (ITUNE.EQ.325) PARP(90)=0.23D0
62729 IF (ITUNE.EQ.326) PARP(90)=0.22D0
62731 C...Professor-pT0 has intermediate scaling
62732 IF (ITUNE.EQ.329) PARP(90)=0.22D0
62733 IF (ITUNE.EQ.335) PARP(90)=0.20D0
62734 IF (ITUNE.EQ.336) PARP(90)=0.20D0
62735 IF (ITUNE.EQ.339) PARP(90)=0.21D0
62737 C...BR: MPI initiator color connections rap-ordered by default
62738 C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered
62740 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
62741 IF (ITUNE.EQ.322) MSTP(89)=0
62742 IF (ITUNE.EQ.327) MSTP(89)=0
62743 IF (ITUNE.EQ.328) MSTP(89)=0
62745 C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
62747 IF (ITUNE.GE.320.AND.ITUNE.LE.328) THEN
62748 C...Perugia tunes have more beam blowup by default
62750 IF (ITUNE.EQ.321) PARP(80)=0.01
62751 IF (ITUNE.EQ.323) PARP(80)=0.03
62752 IF (ITUNE.EQ.324) PARP(80)=0.01
62753 IF (ITUNE.EQ.327) PARP(80)=0.1
62754 IF (ITUNE.EQ.328) PARP(80)=0.1
62757 C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
62760 IF (ITUNEB.EQ.304) PARP(79)=3D0
62761 IF (ITUNE.EQ.329) PARP(79)=1.18
62762 IF (ITUNE.EQ.335) PARP(79)=1.11
62763 IF (ITUNE.EQ.336) PARP(79)=1.10
62764 IF (ITUNE.EQ.339) PARP(79)=3.69
62766 C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
62770 C...Perugia-HARD only uses 1.0 GeV
62771 IF (ITUNE.EQ.321) PARP(91)=1.0D0
62772 C...Perugia-3 only uses 1.5 GeV
62773 IF (ITUNE.EQ.323) PARP(91)=1.5D0
62774 C...Professor-pT0 uses 7-GeV cutoff
62775 IF (ITUNE.EQ.329) PARP(93)=7.0
62776 IF (ITUNE.EQ.335) THEN
62779 ELSEIF (ITUNE.EQ.336) THEN
62782 ELSEIF (ITUNE.EQ.339) THEN
62787 C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
62789 C...S1, S1-Pro: use S1
62790 IF (ITUNEB.EQ.301) MSTP(95)=2
62791 C...S2, S2-Pro: use S2
62792 IF (ITUNEB.EQ.302) MSTP(95)=4
62793 C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
62794 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324.OR.
62795 & ITUNE.EQ.334) MSTP(95)=0
62796 C..."Old" and "Old"-Pro: use old CR
62797 IF (ITUNEB.EQ.305) MSTP(95)=1
62798 C...Perugia 2010 and K use Paquis model
62799 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328) MSTP(95)=8
62801 C...FSI: CR strength and high-pT dampening, default is S0
62803 IF (ITUNE.LT.320.OR.ITUNE.EQ.329.OR.ITUNE.GE.335) THEN
62805 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
62806 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
62807 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
62808 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
62809 IF (ITUNE.EQ.329) PARP(78)=0.17D0
62810 IF (ITUNE.EQ.335) PARP(78)=0.14D0
62811 IF (ITUNE.EQ.336) PARP(78)=0.17D0
62812 IF (ITUNE.EQ.339) PARP(78)=0.13D0
62814 C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
62817 IF (ITUNE.EQ.321) THEN
62818 C...HARD has HIGH amount of CR
62821 ELSEIF (ITUNE.EQ.322) THEN
62822 C...SOFT has LOW amount of CR
62825 ELSEIF (ITUNE.EQ.323) THEN
62826 C...Scaling variant appears to need slightly more than default
62829 ELSEIF (ITUNE.EQ.324.OR.ITUNE.EQ.334) THEN
62833 ELSEIF (ITUNE.EQ.327) THEN
62837 ELSEIF (ITUNE.EQ.328) THEN
62845 C...Perugia 2011 tunes
62846 C...(written as modifications on top of Perugia 2010)
62848 IF (ITUNSV.GE.350.AND.ITUNSV.LE.359) THEN
62850 C... Scale setting for matching applications.
62851 C... Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity
62852 C... (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16)
62855 C... This sets the Lambda scale for ISR, IFSR, and FSR
62859 C... This sets the Lambda scale for QCD hard interactions (important for the
62860 C... UE dijet cross sections. Here we still use an MSbar value, rather than
62861 C... a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L
62862 C... value corresponds to a Lambda5 of 0.146 for comparison, so quite close.)
62865 C... For matching applications, PARP(71) and PARP(67) = 1
62868 C... Primordial kT: only use 1 GeV
62871 C... ADDITIONAL LESSONS WRT PERUGIA 2010
62872 C... ALICE taught us: need less baryon transport than SOFT
62875 C... Small adjustments at LEP (slightly softer frag functions, esp for baryons)
62880 C... Increase Lambda/K ratio and other strange baryon yields
62886 C... Also reduce total strangeness yield a bit, with higher K*/K
62889 C... Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual
62893 C... Holger taught us a smoother proton is preferred at high energies
62894 C... Just use a simple Gaussian
62896 C... Scaling of pt0 cutoff
62898 C... Now retune pT0 to give right UE activity.
62899 C... Low CR strength indicated by LHC tunes
62900 C... (also keep low to get <pT>(Nch) a bit down for pT>100MeV samples)
62902 C... Choose 7 TeV as new reference scale
62906 C... P2011 Variations
62908 IF (ITUNE.EQ.351) THEN
62909 C... radHi: high Lambda scale for ISR, IFSR, and FSR
62910 C... ( ca 10% more particles at LEP after retune )
62914 C... Retune cutoff scales to compensate partially
62915 C... (though higher cutoff causes faster multiplicity drop at low energies)
62919 C... Needs faster cutoff scaling than nominal variant for same <Nch> scaling
62920 C... (since more radiation otherwise generates faster mult growth)
62922 ELSEIF (ITUNE.EQ.352) THEN
62923 C... radLo: low Lambda scale for ISR, IFSR, and FSR
62924 C... ( ca 10% less particles at LEP after retune )
62928 C... Retune cutoff scales to compensate partially
62932 C... Needs slower cutoff scaling than nominal variant for same <Nch> scaling
62933 C... (since less radiation otherwise generates slower mult growth)
62935 ELSEIF (ITUNE.EQ.353) THEN
62936 C... mpiHi: high Lambda scale for MPI
62941 ELSEIF (ITUNE.EQ.354) THEN
62944 ELSEIF (ITUNE.EQ.355) THEN
62949 C... Compensate for higher <pT> with less CR
62952 C... Need slower energy scaling than CTEQ5L
62954 ELSEIF (ITUNE.EQ.356) THEN
62959 C... Need slower cutoff scaling than CTEQ5L
62961 ELSEIF (ITUNE.EQ.357) THEN
62964 ELSEIF (ITUNE.EQ.358) THEN
62967 ELSEIF (ITUNE.EQ.359) THEN
62976 C...Schulz-Skands 2011 tunes
62977 C...(written as modifications on top of Perugia 0)
62979 ELSEIF (ITUNSV.GE.360.AND.ITUNSV.LE.365) THEN
62982 IF (ITUNE.EQ.360) THEN
62988 ELSEIF (ITUNE.EQ.361) THEN
62993 ELSEIF (ITUNE.EQ.362) THEN
62998 ELSEIF (ITUNE.EQ.363) THEN
63003 ELSEIF (ITUNE.EQ.364) THEN
63008 ELSEIF (ITUNE.EQ.365) THEN
63017 C...Switch off trial joinings
63020 C...S0 (300), S0A (303)
63021 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
63023 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
63024 WRITE(M11,5030) CH60
63025 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
63026 WRITE(M11,5030) CH60
63027 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63028 WRITE(M11,5030) CH60
63029 IF (ITUNE.GE.310) THEN
63030 CH60='LEP parameters tuned by Professor,'//
63031 & ' hep-ph/0907.2973'
63032 WRITE(M11,5030) CH60
63037 ELSEIF(ITUNEB.EQ.301) THEN
63039 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63040 WRITE(M11,5030) CH60
63041 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63042 WRITE(M11,5030) CH60
63043 IF (ITUNE.GE.310) THEN
63044 CH60='LEP parameters tuned by Professor,'//
63045 & ' hep-ph/0907.2973'
63046 WRITE(M11,5030) CH60
63051 ELSEIF(ITUNEB.EQ.302) THEN
63053 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63054 WRITE(M11,5030) CH60
63055 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63056 WRITE(M11,5030) CH60
63057 IF (ITUNE.GE.310) THEN
63058 CH60='LEP parameters tuned by Professor,'//
63059 & ' hep-ph/0907.2973'
63060 WRITE(M11,5030) CH60
63065 ELSEIF(ITUNEB.EQ.304) THEN
63067 CH60='"best try" without colour reconnections'
63068 WRITE(M11,5030) CH60
63069 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
63070 WRITE(M11,5030) CH60
63071 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63072 WRITE(M11,5030) CH60
63073 IF (ITUNE.GE.310) THEN
63074 CH60='LEP parameters tuned by Professor,'//
63075 & ' hep-ph/0907.2973'
63076 WRITE(M11,5030) CH60
63080 C..."Lo FSR" retune (305)
63081 ELSEIF(ITUNEB.EQ.305) THEN
63083 CH60='"Lo FSR retune" with primitive colour reconnections'
63084 WRITE(M11,5030) CH60
63085 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
63086 WRITE(M11,5030) CH60
63087 IF (ITUNE.GE.310) THEN
63088 CH60='LEP parameters tuned by Professor,'//
63089 & ' hep-ph/0907.2973'
63090 WRITE(M11,5030) CH60
63094 C...Perugia Tunes (320-328 and 334)
63095 ELSEIF((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
63097 CH60='Tuned by P. Skands, hep-ph/1005.3457'
63098 WRITE(M11,5030) CH60
63099 CH60='Physics Model: '//
63100 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63101 WRITE(M11,5030) CH60
63102 IF (ITUNE.LE.326) THEN
63103 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63104 WRITE(M11,5030) CH60
63105 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63106 WRITE(M11,5030) CH60
63108 IF (ITUNE.EQ.325) THEN
63109 CH70='NB! This tune requires MRST LO* pdfs to be '//
63110 & 'externally linked'
63111 WRITE(M11,5035) CH70
63112 ELSEIF (ITUNE.EQ.326) THEN
63113 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63114 & 'externally linked'
63115 WRITE(M11,5035) CH70
63116 ELSEIF (ITUNE.EQ.321) THEN
63117 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
63118 WRITE(M11,5030) CH60
63119 ELSEIF (ITUNE.EQ.322) THEN
63120 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
63121 WRITE(M11,5030) CH60
63125 C...Professor-pTO (329)
63126 ELSEIF(ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
63127 & ITUNE.EQ.339) THEN
63129 CH60='Tuned by Professor, hep-ph/0907.2973'
63130 WRITE(M11,5030) CH60
63131 CH60='Physics Model: '//
63132 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63133 WRITE(M11,5030) CH60
63134 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63135 WRITE(M11,5030) CH60
63138 C...Perugia 2011 Tunes (350-359)
63139 ELSEIF(ITUNE.GE.350.AND.ITUNE.LE.359) THEN
63141 CH60='Tuned by P. Skands, hep-ph/1005.3457'
63142 WRITE(M11,5030) CH60
63143 CH60='Physics Model: '//
63144 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63145 WRITE(M11,5030) CH60
63146 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63147 WRITE(M11,5030) CH60
63148 IF (ITUNE.EQ.355) THEN
63149 CH70='NB! This tune requires MRST LO** pdfs to be '//
63150 & 'externally linked'
63151 WRITE(M11,5035) CH70
63152 ELSEIF (ITUNE.EQ.356) THEN
63153 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63154 & 'externally linked'
63155 WRITE(M11,5035) CH70
63159 C...Schulz-Skands Tunes (360-365)
63160 ELSEIF(ITUNE.GE.360.AND.ITUNE.LE.365) THEN
63162 CH60='Tuned by H. Schulz & P. Skands, MCNET-11-07'
63163 WRITE(M11,5030) CH60
63164 CH60='Based on Perugia 0, hep-ph/1005.3457'
63165 WRITE(M11,5030) CH60
63166 CH60='Physics Model: '//
63167 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63168 WRITE(M11,5030) CH60
63169 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63170 WRITE(M11,5030) CH60
63177 WRITE(M11,5030) ' '
63178 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63179 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63180 IF (MSTP(33).GE.10) THEN
63181 WRITE(M11,5050) 32, PARP(32), CHPARP(32)
63183 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63184 IF (MSTP(3).EQ.1) THEN
63185 WRITE(M11,6100) 112, MSTU(112), CHMSTU(112)
63186 WRITE(M11,6110) 112, PARU(112), CHPARU(112)
63187 WRITE(M11,5050) 1, PARP(1) , CHPARP( 1)
63189 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63191 & WRITE(M11,5050) 72, PARP(72) , CHPARP( 72)
63192 IF (MSTP(3).EQ.1) THEN
63193 WRITE(M11,5050) 61, PARP(61) , CHPARP( 61)
63195 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
63196 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63197 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
63198 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63199 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63200 WRITE(M11,5030) CH60
63201 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63202 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
63203 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63204 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
63205 IF (MSTP(70).EQ.0) THEN
63206 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63207 ELSEIF (MSTP(70).EQ.1) THEN
63208 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
63209 CH60='(Note: PARP(81) replaces PARP(62).)'
63210 WRITE(M11,5030) CH60
63212 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63213 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63214 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63215 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63216 IF (MSTP(70).EQ.2) THEN
63217 CH60='(Note: PARP(82) replaces PARP(62).)'
63218 WRITE(M11,5030) CH60
63220 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63221 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63222 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63223 IF (MSTP(82).EQ.5) THEN
63224 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63225 ELSEIF (MSTP(82).EQ.4) THEN
63226 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63227 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63229 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63230 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63231 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63232 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63233 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63234 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63235 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63236 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63237 IF (MSTP(95).GE.1) THEN
63238 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63239 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
63244 C=======================================================================
63245 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
63246 ELSEIF (ITUNE.EQ.306) THEN
63247 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
63248 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
63249 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63260 C...UE on, new model.
63265 C...Switch off trial joinings
63267 C...Primordial kT cutoff
63270 CH60='see presentations by A. Moraes (ATLAS),'
63271 WRITE(M11,5030) CH60
63272 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63273 WRITE(M11,5030) CH60
63274 WRITE(M11,5030) ' '
63275 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
63276 & 'externally linked'
63277 WRITE(M11,5035) CH70
63279 C...Smooth ISR, low FSR
63284 C...Transverse density profile.
63288 C...ISR & FSR in interactions after the first (default)
63291 C...No double-counting (default)
63293 C...Companion quark parent gluon (1-x) power
63295 C...Primordial kT compensation along chaings (default = 0 : uniform)
63297 C...Colour Reconnections
63300 C...Lambda_FSR scale.
63302 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
63307 C...Peterson charm frag, and c and b hadr parameters
63313 WRITE(M11,5030) ' '
63314 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63315 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63316 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63317 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63318 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63319 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63320 WRITE(M11,5030) CH60
63321 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
63322 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
63323 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63324 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63325 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
63326 WRITE(M11,5030) CH60
63327 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63328 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63329 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63330 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63331 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63332 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63333 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63334 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63335 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63336 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63337 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
63338 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63339 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63340 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63341 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63342 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63346 C=======================================================================
63347 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
63348 C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
63349 C...A-Pro, DW-Pro, etc (100-119), and Pro-Q2O (129)
63350 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
63351 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
63352 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
63353 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
63354 WRITE(M11,5010) ITUNE, CHNAME
63355 CH60='see R.D. Field, in hep-ph/0610012'
63356 WRITE(M11,5030) CH60
63357 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63358 WRITE(M11,5030) CH60
63359 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
63360 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63361 WRITE(M11,5030) CH60
63363 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
63364 WRITE(M11,5010) ITUNE, CHNAME
63365 CH60='Tuned by Professor, hep-ph/0907.2973'
63366 WRITE(M11,5030) CH60
63367 CH60='Physics Model: '//
63368 & 'T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63369 WRITE(M11,5030) CH60
63372 C...Make sure we start from old default fragmentation parameters
63376 C...Use Professor's LEP pars if ITUNE >= 110
63377 C...(i.e., for A-Pro, DW-Pro etc)
63378 IF (ITUNE.LT.110) THEN
63394 C...# Tuned flavour parameters:
63404 C...# Switch on Bowler:
63406 C...# Fragmentation
63415 C...Remove middle digit now for Professor variants, since identical pars
63417 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
63418 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
63421 C...Multiple interactions on, old framework
63423 C...Fast IR cutoff energy scaling by default
63426 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
63429 IF (ITUNEB.EQ.105) THEN
63432 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
63438 C...Double Gaussian matter distribution.
63444 C...Fragmentation functions and c and b parameters
63445 C...(only if not using Professor)
63446 IF (ITUNE.LE.109) THEN
63453 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
63456 c...String drawing almost completely minimizes string length.
63459 C...ISR cutoff, muR scale factor, and phase space size
63463 C...Intrinsic kT, size, and max
63467 C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
63468 IF (ITUNEB.EQ.101) THEN
63475 C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
63476 ELSEIF (ITUNEB.EQ.102) THEN
63479 c...String drawing completely minimizes string length.
63482 C...ISR cutoff, muR scale factor, and phase space size
63486 C...Intrinsic kT, size, and max
63492 ELSEIF (ITUNEB.EQ.103) THEN
63495 c...String drawing completely minimizes string length.
63498 C...ISR cutoff, muR scale factor, and phase space size
63502 C...Intrinsic kT, size, and max
63508 ELSEIF (ITUNEB.EQ.104) THEN
63511 C...Run II ref scale and slow scaling
63514 c...String drawing completely minimizes string length.
63517 C...ISR cutoff, muR scale factor, and phase space size
63521 C...Intrinsic kT, size, and max
63527 ELSEIF(ITUNEB.EQ.105) THEN
63529 WRITE(M11,5030) ' '
63530 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
63531 & 'externally linked'
63532 WRITE(M11,5035) CH70
63536 c...String drawing completely minimizes string length.
63539 C...ISR cutoff, muR scale factor, and phase space size
63543 C...Intrinsic kT, size, and max
63548 C...Tune D6 and D6T
63549 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
63551 WRITE(M11,5030) ' '
63552 CH70='NB! This tune requires CTEQ6L pdfs to be '//
63553 & 'externally linked'
63554 WRITE(M11,5035) CH70
63556 C...The "Rick" proton, double gauss with 0.5/0.4
63560 c...String drawing completely minimizes string length.
63563 IF (ITUNEB.EQ.108) THEN
63564 C...D6: pT0, Run I ref scale, and fast energy scaling
63569 C...D6T: pT0, Run II ref scale, and slow energy scaling
63574 C...ISR cutoff, muR scale factor, and phase space size
63578 C...Intrinsic kT, size, and max
63583 C...Old ATLAS-DC2 5-parameter tune
63584 ELSEIF(ITUNEB.EQ.106) THEN
63586 WRITE(M11,5010) ITUNE, CHNAME
63587 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
63588 WRITE(M11,5030) CH60
63589 CH60=' R. Field in hep-ph/0610012,'
63590 WRITE(M11,5030) CH60
63591 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63592 WRITE(M11,5030) CH60
63596 C... Different ref and rescaling pacee
63599 C... Parameters of mass distribution
63602 C... Old default string drawing
63605 C... ISR, phase space equivalent to Tune B
63616 C...Professor's Pro-Q2O Tune
63617 ELSEIF(ITUNE.EQ.129) THEN
63636 WRITE(M11,5030) ' '
63637 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63638 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63639 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63640 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63641 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63642 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63643 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63644 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63645 WRITE(M11,5030) CH60
63646 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63647 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63648 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63649 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63650 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63651 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63652 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63653 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63654 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63655 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63656 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63657 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
63658 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
63659 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63660 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63661 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63665 C=======================================================================
63666 C... ACR, tune A with new CR (107)
63667 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
63669 WRITE(M11,5010) ITUNE, CHNAME
63670 CH60='Tune A modified with new colour reconnections'
63671 WRITE(M11,5030) CH60
63672 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
63673 WRITE(M11,5030) CH60
63674 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
63675 WRITE(M11,5030) CH60
63676 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
63677 WRITE(M11,5030) CH60
63678 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63679 WRITE(M11,5030) CH60
63680 IF (ITUNE.EQ.117) THEN
63681 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63682 WRITE(M11,5030) CH60
63685 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
63686 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63687 & ' with tune. Using defaults.')
63691 C...Make sure we start from old default fragmentation parameters
63695 C...Use Professor's LEP pars if ITUNE >= 110
63696 C...(i.e., for A-Pro, DW-Pro etc)
63697 IF (ITUNE.LT.110) THEN
63700 C...# Old default flavour parameters
63707 C...# Tuned flavour parameters:
63717 C...# Switch on Bowler:
63719 C...# Fragmentation
63747 C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
63749 C...Frag functions (only if not using Professor)
63750 IF (ITUNE.LE.109) THEN
63758 WRITE(M11,5030) ' '
63759 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63760 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63761 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63762 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63763 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63764 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63765 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63766 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63767 WRITE(M11,5030) CH60
63768 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63769 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63770 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63771 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63772 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63773 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63774 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63775 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63776 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63777 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63778 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63779 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
63780 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
63781 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63782 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63783 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63784 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63785 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63789 C=======================================================================
63790 C...Intermediate model. Rap tune
63791 C...(retuned to post-6.406 IR factorization)
63792 ELSEIF(ITUNE.EQ.200) THEN
63794 WRITE(M11,5010) ITUNE, CHNAME
63795 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
63796 WRITE(M11,5030) CH60
63798 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
63799 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63817 C... ExpOfPow(1.8) overlap profile
63824 C... Default diquark, BR-g-BR supp
63827 C... Final state reconnect.
63830 C...Fragmentation functions and c and b parameters
63836 WRITE(M11,5030) ' '
63837 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63838 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63839 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63840 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63841 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63842 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63843 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63844 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63845 WRITE(M11,5030) CH60
63846 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63847 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63848 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63849 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63850 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63851 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63852 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63853 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63854 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63855 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63856 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63857 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63858 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63859 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63860 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63861 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63865 C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
63866 C...Old model for ISR and UE, new pT-ordered model for FSR
63867 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
63868 & .ITUNE.EQ.226) THEN
63870 WRITE(M11,5010) ITUNE, CHNAME
63871 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
63872 WRITE(M11,5030) CH60
63873 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
63874 WRITE(M11,5030) CH60
63875 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63876 WRITE(M11,5030) CH60
63877 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63878 WRITE(M11,5030) CH60
63879 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
63880 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63881 WRITE(M11,5030) CH60
63884 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
63885 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63888 C...First set as if Pythia tune A
63889 C...Multiple interactions on, old framework
63891 C...Fast IR cutoff energy scaling by default
63894 C...Default CTEQ5L (internal)
63897 C...Double Gaussian matter distribution.
63903 c...String drawing almost completely minimizes string length.
63906 C...ISR cutoff, muR scale factor, and phase space size
63910 C...Intrinsic kT, size, and max
63914 C...Use 2 GeV of primordial kT for "Perugia" version
63915 IF (ITUNE.EQ.221) THEN
63919 C...Use pT-ordered FSR
63921 C...Lambda_FSR scale for pT-ordering
63923 C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
63925 C...Fragmentation functions and c and b parameters
63926 C...(overwritten for 211, i.e., if using Professor pars)
63930 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
63931 IF (ITUNE.LT.210) THEN
63934 C...# Old default flavour parameters
63941 C...# Tuned flavour parameters:
63951 C...# Always use pT-ordered shower:
63953 C...# Switch on Bowler:
63955 C...# Fragmentation
63956 PARJ(21) = 3.1327e-01
63957 PARJ(41) = 4.8989e-01
63958 PARJ(42) = 1.2018e+00
63959 PARJ(47) = 1.0000e+00
63960 PARJ(81) = 2.5696e-01
63961 PARJ(82) = 8.0000e-01
63964 C...221, 226 : Perugia-APT and Perugia-APT6
63965 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
63971 C...The Perugia variants use Steve's showers off the old MPI
63973 C...And use a lower PARP(71) as suggested by Professor tunings
63974 C...(although not certain that applies to Q2-pT2 hybrid)
63977 C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
63978 IF (ITUNE.EQ.226) THEN
63979 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63980 & 'externally linked'
63981 WRITE(M11,5035) CH70
63991 WRITE(M11,5030) ' '
63992 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63993 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63994 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63995 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63996 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63997 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63998 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63999 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64000 WRITE(M11,5030) CH60
64001 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
64002 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
64003 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
64004 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
64005 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64006 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64007 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
64008 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
64009 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64010 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64011 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64012 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
64013 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
64014 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
64015 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
64016 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
64020 C======================================================================
64021 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
64022 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
64024 WRITE(M11,5010) ITUNE, CHNAME
64025 CH60='see J. Rathsman, PLB452(1999)364'
64026 WRITE(M11,5030) CH60
64027 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
64028 C ? WRITE(M11,5030)
64029 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64030 WRITE(M11,5030) CH60
64031 WRITE(M11,5030) ' '
64032 CH70='NB! The GAL model must be run with modified '//
64034 WRITE(M11,5035) CH70
64035 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
64036 WRITE(M11,5035) CH70
64037 WRITE(M11,5030) ' '
64039 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
64052 IF(CHNAME.EQ.'GAL Tune 1') THEN
64053 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
64059 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64060 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64061 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64062 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64063 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64067 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64068 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
64069 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64074 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64075 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
64076 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
64077 CH40='FSI SCI/GAL selection'
64078 WRITE(M11,6040) 1, MSWI(1), CH40
64079 CH40='FSI SCI/GAL sea quark treatment'
64080 WRITE(M11,6040) 2, MSWI(2), CH40
64081 CH40='FSI SCI/GAL sea quark treatment parm'
64082 WRITE(M11,6050) 1, PARSCI(1), CH40
64083 CH40='FSI SCI/GAL string reco probability R_0'
64084 WRITE(M11,6050) 2, PARSCI(2), CH40
64085 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
64086 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
64088 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
64090 WRITE(M11,5010) ITUNE, CHNAME
64091 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
64092 WRITE(M11,5030) CH60
64093 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64094 WRITE(M11,5030) CH60
64095 WRITE(M11,5030) ' '
64096 CH70='NB! The SCI model must be run with modified '//
64098 WRITE(M11,5035) CH70
64099 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
64100 WRITE(M11,5035) CH70
64101 WRITE(M11,5030) ' '
64103 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
64113 IF (CHNAME.EQ.'SCI Tune 1') THEN
64114 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
64122 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64123 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64124 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64125 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64126 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64130 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64131 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
64132 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64137 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
64138 CH40='FSI SCI/GAL selection'
64139 WRITE(M11,6040) 1, MSWI(1), CH40
64140 CH40='FSI SCI/GAL sea quark treatment'
64141 WRITE(M11,6040) 2, MSWI(2), CH40
64142 CH40='FSI SCI/GAL sea quark treatment parm'
64143 WRITE(M11,6050) 1, PARSCI(1), CH40
64144 CH40='FSI SCI/GAL string reco probability R_0'
64145 WRITE(M11,6050) 2, PARSCI(2), CH40
64146 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
64150 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
64154 C...Output of LEP parameters, common to all models
64157 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
64158 IF (MSTJ(11).EQ.3) THEN
64159 CH60='Warning: using Peterson fragmentation function'
64160 WRITE(M11,5030) CH60
64163 WRITE(M11,5060) 1, PARJ( 1), CHPARJ( 1)
64164 WRITE(M11,5060) 2, PARJ( 2), CHPARJ( 2)
64165 WRITE(M11,5060) 3, PARJ( 3), CHPARJ( 3)
64166 WRITE(M11,5060) 4, PARJ( 4), CHPARJ( 4)
64167 WRITE(M11,5060) 5, PARJ( 5), CHPARJ( 5)
64168 WRITE(M11,5060) 6, PARJ( 6), CHPARJ( 6)
64169 WRITE(M11,5060) 7, PARJ( 7), CHPARJ( 7)
64171 WRITE(M11,5060) 11, PARJ(11), CHPARJ(11)
64172 WRITE(M11,5060) 12, PARJ(12), CHPARJ(12)
64173 WRITE(M11,5060) 13, PARJ(13), CHPARJ(13)
64175 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
64177 WRITE(M11,5060) 25, PARJ(25), CHPARJ(25)
64178 WRITE(M11,5060) 26, PARJ(26), CHPARJ(26)
64180 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
64181 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
64182 WRITE(M11,5060) 45, PARJ(45), CHPARJ(45)
64184 IF (MSTJ(11).LE.3) THEN
64185 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
64186 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
64188 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
64190 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
64193 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
64197 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ',
64198 & 'Presets for underlying-event (and min-bias)',21x,'*'/' *',
64199 & 12x,'Last Change : ',A8,' - P. Skands',30x,'*'/' *',76x,'*')
64200 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
64201 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
64202 5030 FORMAT(' *',3x,10x,A60,3x,'*')
64203 5035 FORMAT(' *',3x,A70,3x,'*')
64204 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
64205 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
64206 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
64207 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
64208 5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*')
64209 6100 FORMAT(' *',5x,'MSTU(',I3,')= ',I12,3x,A42,3x,'*')
64210 6110 FORMAT(' *',5x,'PARU(',I3,')= ',F12.4,3x,A42,3x,'*')
64211 C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
64212 C 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
64213 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
64214 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
64215 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
64219 C*********************************************************************
64222 C...Administrates the fragmentation and decay chain.
64226 C...Double precision and integer declarations.
64227 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64228 IMPLICIT INTEGER(I-N)
64229 INTEGER PYK,PYCHGE,PYCOMP
64231 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64232 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64233 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64234 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
64235 COMMON/PYINT1/MINT(400),VINT(400)
64236 COMMON/PYINT4/MWID(500),WIDS(500,5)
64237 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
64239 DIMENSION PS(2,6),IJOIN(100)
64241 C...Initialize and reset.
64243 IF(MSTU(12).NE.12345) CALL PYLIST(0)
64245 MSTU(31)=MSTU(31)+1
64249 IF(MSTU(17).LE.0) MSTU(90)=0
64252 C...Sum up momentum, energy and charge for starting entries.
64260 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
64262 PS(1,J)=PS(1,J)+P(I,J)
64264 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
64268 C...Start by all decays of coloured resonances involved in shower.
64271 IF(K(I,1).EQ.3) THEN
64273 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
64277 C...Prepare system for subsequent fragmentation/decay.
64279 IF(MINT(51).NE.0) RETURN
64281 C...Loop through jet fragmentation and particle decays.
64287 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
64290 C...Deal with any remaining undecayed resonance
64291 C...(normally the task of PYEVNT, so seldom used).
64292 ELSEIF(MWID(KC).NE.0) THEN
64294 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
64297 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
64298 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
64301 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
64302 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
64305 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
64313 IF(MINT(51).NE.0) RETURN
64315 C...Particle decay if unstable and allowed. Save long-lived particle
64316 C...decays until second pass after Bose-Einstein effects.
64317 ELSEIF(KCHG(KC,2).EQ.0) THEN
64318 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
64319 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
64322 C...Decay products may develop a shower.
64323 IF(MSTJ(92).GT.0) THEN
64325 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
64326 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
64328 CALL PYSHOW(IP1,IP1+1,QMAX)
64330 IF(MINT(51).NE.0) RETURN
64332 ELSEIF(MSTJ(92).LT.0) THEN
64335 CALL PYSHOW(IP1,-3,P(IP,5))
64337 IF(MINT(51).NE.0) RETURN
64341 C...Jet fragmentation: string or independent fragmentation.
64342 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
64344 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
64345 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
64346 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
64347 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
64348 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
64351 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
64352 IF(MFRAG.EQ.2) CALL PYINDF(IP)
64353 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
64354 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
64357 C...Loop back if enough space left in PYJETS and no error abort.
64358 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
64359 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
64361 ELSEIF(IP.LT.N) THEN
64362 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
64365 C...Include simple Bose-Einstein effect parametrization if desired.
64366 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
64371 C...Check that momentum, energy and charge were conserved.
64373 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
64375 PS(2,J)=PS(2,J)+P(I,J)
64377 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
64379 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
64380 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
64381 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
64382 &'(PYEXEC:) four-momentum was not conserved')
64383 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
64384 &'(PYEXEC:) charge was not conserved')
64389 C*********************************************************************
64392 C...Rearranges partons along strings.
64393 C...Special considerations for systems with junctions, with
64394 C...possibility of junction-antijunction annihilation.
64395 C...Allows small systems to collapse into one or two particles.
64396 C...Checks flavours and colour singlet invariant masses.
64398 SUBROUTINE PYPREP(IP)
64400 C...Double precision and integer declarations.
64401 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64402 INTEGER PYK,PYCHGE,PYCOMP
64404 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64406 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
64407 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64408 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
64409 COMMON/PYINT1/MINT(400),VINT(400)
64410 C...The common block of colour tags.
64411 COMMON/PYCTAG/NCT,MCT(4000,2)
64412 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
64417 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
64418 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
64419 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
64420 &IJCP(0:6),TJUOLD(5)
64423 C...Function to give four-product.
64424 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)
64426 C...Rearrange parton shower product listing along strings: begin loop.
64434 DO 100 I=MAX(1,IP),N
64435 C...First store junction positions.
64436 IF(K(I,1).EQ.42) THEN
64444 DO 240 I=MAX(1,IP),N
64445 C...Special treatment for junctions
64446 IF (K(I,1).LE.0) GOTO 240
64447 IF(K(I,1).EQ.42) THEN
64448 C...MQGST=2: Look for junction-junction strings (not detected in the
64449 C...main search below).
64450 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
64451 IF (NJJSTR.EQ.0) THEN
64452 NJJSTR = (3*NJUNC-NPIECE)/2
64454 C...Check how many already identified strings end on this junction
64457 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
64459 C...If less than 3, remaining must be to another junction
64462 C...Multiple j-j connections not handled yet.
64464 & '(PYPREP:) Too many junction-junction strings.')
64468 C...The colour information in the junction is unreadable for the
64469 C...colour space search further down in this routine, so we must
64470 C...start on the colour mother of this junction and then "artificially"
64471 C...prevent the colour mother from connecting here again.
64472 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
64474 IF (MOD(ITJUNC,2).EQ.0) KCS=5
64475 C...Switch colour if the junction-junction leg is presumably a
64476 C...junction mother leg rather than a junction daughter leg.
64477 IF (ITJUNC.GE.3) KCS=9-KCS
64478 IF (MINT(33).EQ.0) THEN
64479 C...Find the unconnected leg and reorder junction daughter pointers so
64480 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
64482 IA=MOD(K(I,4),MSTU(5))
64483 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
64484 ITMP=MOD(K(I,5),MSTU(5))
64485 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
64486 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
64487 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
64489 K(I,5)=K(I,5)+(IA-ITMP)
64491 K(I,4)=K(I,4)+(ITMP-IA)
64494 IF (ITJUNC.LE.2) THEN
64495 C...Beam baryon junction
64496 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
64497 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
64498 C...Else 1 -> 2 decay junction
64500 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
64501 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
64506 C...Alternatively use colour tag information.
64508 C...Find a final state parton with appropriate dangling colour tag.
64512 DO 140 J1=MAX(1,IP),N
64513 IF (K(J1,1).NE.3) GOTO 140
64514 C...Check for matching final-state colour tag
64516 DO 120 J2=MAX(1,IP),N
64517 IF (K(J2,1).NE.3) GOTO 120
64518 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
64520 IF (IMATCH.EQ.1) GOTO 140
64521 C...Check whether this colour tag belongs to the present junction
64522 C...by seeing whether any parton with this colour tag has the same
64523 C...mother as the junction.
64526 DO 130 J2=MINT(84)+1,N
64528 C...First scattering partons have IMO1 = 3 and 4.
64529 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
64531 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
64534 IF (IMATCH.EQ.0) GOTO 140
64537 C...Check for junction-junction strings without intermediate final state
64538 C...glue (not detected above).
64542 IF (IJU2.EQ.I) GOTO 160
64543 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
64544 C...Only opposite types of junctions can connect to each other.
64545 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
64548 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
64550 IF (IS.EQ.3) GOTO 160
64555 C...Switch to other side of adjacent parton and step from there.
64561 ELSE IF (ILC.NE.3) THEN
64566 C...Look for coloured string endpoint, or (later) leftover gluon.
64567 IF(K(I,1).NE.3) GOTO 240
64569 IF(KC.EQ.0) GOTO 240
64571 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
64573 C...Pick up loose string end.
64575 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
64581 IF(NSTP.GT.4*N) THEN
64582 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
64587 C...Copy undecayed parton. Finished if reached string endpoint.
64588 IF(K(IA,1).EQ.3) THEN
64589 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
64590 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
64597 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
64607 IF(K(I1,1).EQ.1) GOTO 240
64610 C...Also finished (for now) if reached junction; then copy to end.
64611 IF(K(IA,1).EQ.42) THEN
64613 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
64614 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
64619 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
64620 DO 200 ICOPY=1,NCOPY
64622 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
64623 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
64624 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
64628 C...For junction-junction strings, find end leg and reorder junction
64629 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
64630 C...junction-junction string piece.
64631 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
64632 ITMP=MOD(K(IA,4),MSTU(5))
64633 IF (ITMP.NE.IB) THEN
64634 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
64635 K(IA,5)=K(IA,5)+(ITMP-IB)
64637 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
64639 K(IA,4)=K(IA,4)+(IB-ITMP)
64644 C...0: endpoint in original ER
64647 C...3: Parton immediately next to junction
64650 IPIECE(NPIECE,1)=MSTU32+1
64651 IPIECE(NPIECE,2)=MSTU32+NCOPY
64652 IPIECE(NPIECE,3)=IB
64653 IPIECE(NPIECE,4)=IA
64654 MSTU32=MSTU32+NCOPY
64659 C...GOTO next parton in colour space.
64661 IF (MINT(33).EQ.0) THEN
64662 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
64664 IA=MOD(K(IB,KCS),MSTU(5))
64665 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
64668 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
64669 & MSTU(5)).EQ.0) KCS=9-KCS
64670 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
64671 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
64674 IF(IA.LE.0.OR.IA.GT.N) THEN
64675 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
64676 IF(NERRPR.LT.5) THEN
64678 WRITE(MSTU(11),*) 'started at:', I
64679 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
64680 WRITE(MSTU(11),*) 'MQGST =',MQGST
64686 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
64687 & ,MSTU(5)).EQ.IB) THEN
64688 IF(MREV.EQ.1) KCS=9-KCS
64689 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
64690 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
64692 IF(MREV.EQ.0) KCS=9-KCS
64693 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
64694 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
64696 IF(IA.NE.I) GOTO 170
64697 C...Use colour tag information
64699 C...First create colour tags starting on IB if none already present.
64700 IF (MCT(IB,KCS-3).EQ.0) THEN
64701 CALL PYCTTR(IB,KCS,IB)
64702 IF(MINT(51).NE.0) RETURN
64706 C...Find final state tag partner
64707 DO 210 IT=MAX(1,IP),N
64708 IF (IT.EQ.IB) GOTO 210
64709 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
64715 C...Just copy and goto next if exactly one partner found.
64716 IF (IFOUND.EQ.1) THEN
64718 C...When no match found, match is presumably junction.
64719 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
64720 C...Check whether this colour tag matches a junction
64721 C...by seeing whether any parton with this colour tag has the same
64722 C...mother as a junction.
64723 C...NB: Only type 1 and 2 junctions handled presently.
64725 IJUMO=K(IJUNC(IJU,0),3)
64726 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
64727 C...Colours only connect to junctions, anti-colours to antijunctions:
64728 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
64730 DO 220 J1=MAX(1,IP),N
64731 IF (K(J1,1).LE.0) GOTO 220
64732 C...First scattering partons have IMO1 = 3 and 4.
64734 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
64736 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
64737 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
64739 C...Attempt at handling type > 3 junctions also. Not tested.
64740 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
64743 IF (IMATCH.EQ.0) GOTO 230
64748 IF (IFOUND.EQ.1) THEN
64750 ELSEIF (IFOUND.EQ.0) THEN
64751 WRITE(CHTMP,'(I6)') JCT
64752 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
64754 IF(NERRPR.LT.5) THEN
64761 ELSEIF (IFOUND.GE.2) THEN
64762 WRITE(CHTMP,'(I6)') JCT
64764 & ,'(PYPREP:) too many occurences of colour line: '//
64766 IF(NERRPR.LT.5) THEN
64778 C...Junction systems remain.
64784 260 IJUCNT=IJUCNT+1
64785 IF (IJUCNT.LE.NJUNC) THEN
64786 C...If we are not processing a j-j string, treat this junction as new.
64787 IF (IJJSTR.EQ.0) THEN
64788 IJU=IJUNC(IJUCNT,0)
64790 C...If junction has already been read, ignore it.
64791 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
64792 C...If we are on a j-j string, goto second j-j junction.
64797 C...Mark selected junction read.
64799 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
64801 C...Determine junction type
64802 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
64803 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
64804 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
64805 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
64806 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
64809 C...Find which quarks belong to given junction.
64811 DO 290 IPC=1,NPIECE
64812 IF (IPIECE(IPC,4).EQ.IJU) THEN
64814 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
64816 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
64818 C...IHK = 3 is special. Either normal string piece, or j-j string.
64820 IF (MREV.NE.1) THEN
64821 DO 300 IPC=1,NPIECE
64822 C...If there is a j-j string starting on the present junction which has
64823 C...zero length, insert next junction immediately.
64824 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
64825 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
64831 C...If MREV is 1 and IHK is 3 we are finished with this system.
64838 C...If we've gotten this far, then either IHK < 3, or
64839 C...an interjunction string exists, or just a third normal string.
64840 IJUNC(IJUCNT,IHK)=0
64842 C..Order pieces belonging to this junction. Also look for j-j.
64843 DO 310 IPC=1,NPIECE
64844 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
64845 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
64846 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
64847 IJUNC(IJUCNT,IHK)=IPC
64852 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
64853 IPC=IJUNC(IJUCNT,IHK)
64854 C...Temporary solution to cover for bug.
64856 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
64860 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
64863 K(I1,J)=K(MSTU(4)-ICP,J)
64864 P(I1,J)=P(MSTU(4)-ICP,J)
64865 V(I1,J)=V(MSTU(4)-ICP,J)
64869 C...Mark last quark.
64870 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
64871 C...Do not insert junctions at wrong places.
64872 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
64873 C...Insert junction.
64876 C...Shift to end junction if a j-j string has been processed.
64877 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
64887 K(IJUS,1)=K(IJUS,1)+10
64890 360 IF (IHK.LT.3) GOTO 280
64892 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
64896 IF (IJUCNT.NE.NJUNC) GOTO 260
64900 C...Rearrange three strings from junction, e.g. in case one has been
64901 C...shortened by shower, so the last is the largest-energy one.
64902 IF(NJUNC.GE.1) THEN
64903 C...Find systems with exactly one junction.
64907 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
64908 ELSEIF(K(I,1).EQ.41) THEN
64910 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
64915 C...Sum up energy-momentum in each junction string.
64922 DO 390 I1=NBEG,NEND
64923 IF(K(I1,2).NE.21) THEN
64928 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
64931 C...Find which of them has highest energy (minus mass) in rest frame.
64933 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
64935 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
64938 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
64939 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
64941 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
64942 C...Decide how to rearrange so that new last has highest energy.
64943 IF(PJU(1,6).LT.PJU(2,6)) THEN
64945 IRNG(1,2)=IJUR(2)-1
64947 IRNG(2,2)=IJUR(3)+1
64948 IRNG(4,1)=IJUR(3)-1
64952 IRNG(1,2)=IJUR(3)+1
64954 IRNG(2,2)=IJUR(3)-1
64955 IRNG(4,1)=IJUR(2)-1
64960 C...Copy in correct order below bottom of current event record.
64963 DO 430 I1=IRNG(II,1),IRNG(II,2),
64964 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
64966 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
64968 & '(PYPREP:) no more memory left in PYJETS')
64978 IF(K(I2,1).EQ.1) K(I2,1)=2
64982 C...Copy back up, overwriting but now in correct order.
64983 DO 460 I1=NBEG,NEND
64997 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
64998 C...to two q-qbar systems.
64999 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
65000 IF (MSTJ(19).NE.1) THEN
65004 C...Force collapse when MSTJ(19)=2.
65005 IF (MSTJ(19).EQ.2) THEN
65009 C...Find systems with exactly two junctions.
65011 C...Count junctions
65012 IF (K(I,1).EQ.41) THEN
65014 C...Check for interjunction gluons
65015 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
65018 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
65019 C...If end of system reached with either zero or one junction, restart
65020 C...with next system.
65024 ELSEIF(K(I,1).EQ.1) THEN
65025 C...If end of system reached with exactly two junctions, compute string
65026 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
65027 C...length measure for the (q-qbar)(q-qbar) topology.
65029 C...Loop down through chain.
65031 DO 480 I1=NBEG,NEND
65032 C...Store string piece division locations in event record
65033 IF (K(I1,2).NE.21) THEN
65038 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
65040 IF (PYR(0).LT.0.5D0) ISW=1
65041 C...Randomly choose which qqbar string gets the jj gluons.
65043 IF (PYR(0).GT.0.5D0) IGS=2
65044 C...Only compute string lengths when no topology forced.
65045 IF (MSTJ(19).EQ.0) THEN
65046 C...Repeat following for each junction
65048 C...Initialize iterative procedure for finding JRF
65054 C...Start iteration. Sum up momenta in string pieces
65056 C...JD=-1 for first junction, +1 for second junction.
65057 C...Find out where piece starts and ends and which direction to go.
65060 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
65061 IB = IJCP((IJU-1)*7 - JD*IJS)
65062 ELSEIF (IJS.EQ.3) THEN
65064 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
65065 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
65067 C...Initialize junction pull 4-vector.
65071 C...Initialize weight
65074 C...Sum up (weighted) momenta along each string piece
65075 DO 530 ISP=IA,IB,JD
65076 C...If present parton not last in chain
65077 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
65078 C...If last parton was a junction, store present weight
65079 IF (K(ISP-JD,2).EQ.88) THEN
65081 C...If last parton was a quark, reset to stored weight.
65082 ELSEIF (K(ISP-JD,2).NE.21) THEN
65086 C...Skip next parton if weight already large
65087 IF (PWT.GT.10D0) GOTO 530
65088 C...Compute momentum in TJUOLD frame:
65089 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
65091 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
65093 TMP=P(ISP,J)+TJUOLD(J)*BFC
65094 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
65097 TMP=TJUOLD(4)*P(ISP,4)+TDP
65098 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
65100 PWT=PWT+TMP/PARJ(48)
65101 C...Put |p| rather than m in 5th slot
65102 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
65109 C...Combine new boost (T) with old boost (TJUOLD)
65110 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
65112 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
65115 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
65117 C...If last boost small, accept JRF, else iterate.
65118 C...Also prevent possibility of infinite loop.
65119 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
65120 & IJRFIT.LT.MSTJ(18))THEN
65122 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
65123 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
65125 C...Store final boost, with change of sign since TJJ motion vector.
65127 TJJ(IJU,IX)=-TJUOLD(IX)
65129 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
65132 C...String length measure for (q-qbar)(q-qbar) topology.
65133 C...Note only momenta of nearest partons used (since rest of system
65135 IF (JJGLUE.EQ.0) THEN
65136 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
65137 & -1,IJCP(5-ISW)+1)
65139 C...Put jj gluons on selected string (IGS selected randomly above).
65141 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
65142 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
65144 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
65145 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
65149 C...String length measure for q-q-j-j-q-q topology.
65158 C...Note only momenta of nearest partons used (since rest of system
65161 IF (IX.EQ.4) ISGN=1
65162 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
65163 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
65164 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
65165 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
65166 IF (JJGLUE.EQ.0) THEN
65167 C...Junction motion vector dot product gives length when inter-junction
65169 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
65171 C...Junction motion vector dot products with gluon momenta give length
65172 C...when inter-junction gluons present.
65173 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
65174 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
65177 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
65178 IF (JJGLUE.EQ.0) THEN
65179 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
65181 DELMJJ=DELMJJ*4D0*T1G1*T2G2
65184 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
65185 C...(Always the case for MSTJ(19)=2 due to initialization above)
65186 IF (DELMJJ.GT.DELMQQ) THEN
65187 C...Put new system at end of event record
65190 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
65193 P(NCOP,IX)=P(ICOP,IX)
65194 K(NCOP,IX)=K(ICOP,IX)
65197 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
65198 C...Insert inter-junction gluon string piece (reversed)
65200 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
65204 P(NCOP,IX)=P(ICOP,IX)
65205 K(NCOP,IX)=K(ICOP,IX)
65210 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
65213 P(NCOP,IX)=P(ICOP,IX)
65214 K(NCOP,IX)=K(ICOP,IX)
65219 C...Copy system back in right order
65220 DO 670 ICOP=NBEG,NEND-2
65222 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
65223 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
65226 C...Shift down rest of event record
65227 DO 690 ICOP=NEND+1,N
65229 P(ICOP-2,IX)=P(ICOP,IX)
65230 K(ICOP-2,IX)=K(ICOP,IX)
65233 C...Update length of event record.
65243 C...Done if no checks on small-mass systems.
65244 IF(MSTJ(14).LT.0) RETURN
65245 IF(MSTJ(14).EQ.0) GOTO 1140
65247 C...Find lowest-mass colour singlet jet system.
65252 DO 770 I=MAX(1,IP),N
65253 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
65254 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
65261 DPS(5)=PYMASS(K(I,2))
65262 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
65264 DPS(J)=DPS(J)+P(I,J)
65267 DPS(5)=DPS(5)+PYMASS(K(I,2))
65268 ELSEIF(K(I,1).EQ.2) THEN
65270 DPS(J)=DPS(J)+P(I,J)
65272 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
65274 DPS(J)=DPS(J)+P(I,J)
65277 DPS(5)=DPS(5)+PYMASS(K(I,2))
65278 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
65280 IF(PD.LT.PDMIN) THEN
65294 C...Done if lowest-mass system above threshold for string frag.
65295 IF(PDMIN.GE.PARJ(32)) GOTO 1140
65297 C...Fill small-mass system as cluster.
65299 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
65309 C...Set up history, assuming cluster -> 2 hadrons.
65315 IF(MSTU(16).NE.2) THEN
65330 C...Find total flavour content - complicated by presence of junctions.
65334 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
65337 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
65341 C...If several diquarks, split up one to give even number of flavours.
65342 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
65344 IF(IABS(KFQ(3)).LT.1000) I1=1
65345 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
65346 KFQ(I1)=KFQ(I1)/1000
65351 C...If four quark ends, join two to diquark.
65352 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
65355 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
65356 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
65357 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
65358 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
65359 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
65360 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
65366 C...If two quark ends, plus quark or diquark, join quarks to diquark.
65370 IF(IABS(KFQ(I1)).GT.1000) I1=3
65371 IF(IABS(KFQ(I2)).GT.1000) I2=3
65372 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
65373 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
65374 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
65375 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
65381 C...Form two particles from flavours of lowest-mass system, if feasible.
65383 790 NTRY = NTRY + 1
65385 C...Open string with two specified endpoint flavours.
65389 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
65390 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
65391 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
65392 IF(KQ1+KQ2.NE.0) GOTO 1140
65393 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
65395 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
65397 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
65398 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
65399 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
65401 C...Open string with four specified flavours.
65402 ELSEIF(NQ.EQ.4) THEN
65407 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
65408 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
65409 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
65410 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
65411 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
65412 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
65413 C...Combine flavours pairwise to form two hadrons.
65416 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
65417 & IABS(KFQ(2)).GT.1000)) I2=3
65418 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
65419 & IABS(KFQ(3)).GT.1000))) I2=4
65423 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
65424 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
65425 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
65429 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
65430 C...No room for popcorn mesons in closed string -> 2 hadrons.
65432 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
65433 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
65434 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
65435 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
65437 P(N+2,5)=PYMASS(K(N+2,2))
65438 P(N+3,5)=PYMASS(K(N+3,2))
65440 C...If it does not work: try again (a number of times), give up (if no
65441 C...place to shuffle momentum or too many flavours), or form one hadron.
65442 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
65443 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
65445 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
65452 C...Perform two-particle decay of jet system.
65453 C...First step: find reference axis in decaying system rest frame.
65454 C...(Borrow slot N+2 for temporary direction.)
65458 DO 850 I=IC1+1,IC2-1
65459 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
65460 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
65461 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
65463 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
65467 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
65469 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
65470 PHI1=PYANGL(P(N+2,1),P(N+2,2))
65472 C...Second step: generate isotropic/anisotropic decay.
65473 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
65474 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
65476 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
65477 PT2=(1D0-UE(3)**2)*PA**2
65478 IF(MSTJ(16).LE.0) THEN
65481 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
65482 PR1=P(N+2,5)**2+PT2
65483 PR2=P(N+3,5)**2+PT2
65484 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
65486 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65487 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
65489 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
65491 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
65492 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
65497 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
65498 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
65500 C...Third step: move back to event frame and set production vertex.
65501 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
65511 C...Else form one particle, if possible.
65519 C...Select hadron flavour from available quark flavours.
65520 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
65522 ELSEIF(NQ.EQ.2) THEN
65523 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
65525 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
65526 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
65528 IF(K(N+2,2).EQ.0) GOTO 910
65529 P(N+2,5)=PYMASS(K(N+2,2))
65531 C...Use old algorithm for E/p conservation? (EN)
65532 IF (MSTJ(16).LE.0) GOTO 1080
65534 C...Find the string piece closest to the cluster by a loop
65535 C...over the undecayed partons not in present cluster. (EN)
65540 DO 940 I1=MAX(1,IP),N-1
65541 IF(K(I1,1).EQ.1) NJUNC=0
65542 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
65543 IF(K(I1,1).EQ.41) GOTO 940
65544 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
65546 ELSEIF(K(I1,1).EQ.2) THEN
65550 IF(K(I2,1).EQ.41) GOTO 940
65551 IF(K(I2,1).GT.10) GOTO 920
65552 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
65553 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
65554 & NJUNC.EQ.0) GOTO 940
65555 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
65556 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
65557 & K(I2,1).NE.1)) GOTO 940
65559 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
65561 E1(J)=P(I1,J)/P(I1,4)
65562 E2(J)=P(I2,J)/P(I2,4)
65563 ECL(J)=P(N+1,J)/P(N+1,4)
65568 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
65569 E3S=E3(1)**2+E3(2)**2+E3(3)**2
65570 E4S=E4(1)**2+E4(2)**2+E4(3)**2
65571 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
65572 IF(E34.LE.0D0) THEN
65574 ELSEIF(E34.LT.E3S) THEN
65575 DDMIN=E4S-E34**2/E3S
65577 DDMIN=E4S-2D0*E34+E3S
65580 C...Is this the smallest so far?
65581 IF(DDMIN.LT.DGLOMI) THEN
65586 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
65591 C... Check if there are any strings to connect to the new gluon. (EN)
65592 IF (IBEG.EQ.0) GOTO 1080
65594 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
65595 IF (P(N+1,5).GE.P(N+2,5)) THEN
65597 C...Construct 'gluon' that is needed to put hadron on the mass shell.
65598 FRAC=P(N+2,5)/P(N+1,5)
65600 P(N+2,J)=FRAC*P(N+1,J)
65601 PG(J)=(1D0-FRAC)*P(N+1,J)
65604 C... Copy string with new gluon put in.
65608 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
65609 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
65630 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
65633 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
65634 C...from string piece endpoints.
65637 C...Begin by copying string that should give energy to cluster.
65641 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
65642 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
65654 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
65657 C...Set initial Phad.
65659 P(NSAV+2,J)=P(NSAV+1,J)
65662 C...Calculate Pg, a part of which will be added to Phad later. (EN)
65663 1020 IF(MSTJ(16).EQ.1) THEN
65667 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
65668 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
65671 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
65673 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
65675 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
65676 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
65678 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
65679 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
65680 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
65682 C...If all gluon energy eaten, zero it and take a step back.
65684 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
65687 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
65693 IF(K(I1,1).EQ.41) ITER=-1
65695 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
65698 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
65704 IF(K(I2,1).EQ.41) ITER=-1
65706 IF(ITER.EQ.1) GOTO 1020
65708 C...If also all endpoint energy eaten, revert to old procedure.
65709 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
65710 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
65721 C... Construct the collapsed hadron and modified string partons.
65723 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
65724 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
65725 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
65727 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
65728 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
65730 C...Finished with string collapse in new scheme.
65734 C... Use old algorithm; by choice or when in trouble.
65736 C...Find parton/particle which combines to largest extra mass.
65741 IF(IR.NE.0) GOTO 1100
65742 DO 1090 I=MAX(1,IP),N
65743 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
65744 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
65745 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
65746 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
65747 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
65748 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
65750 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
65751 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
65752 IF(HSR.GT.HSM) THEN
65760 C...Shuffle energy and momentum to put new particle on mass shell.
65765 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
65766 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
65767 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
65769 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
65770 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
65774 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
65778 C...Mark collapsed system and store daughter pointers. Iterate.
65779 1120 DO 1130 I=IC1,IC2
65780 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
65781 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
65783 IF(MSTU(16).NE.2) THEN
65788 K(I,5)=NSAV+1+NBODY
65791 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
65793 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
65795 C...Check flavours and invariant masses in parton systems.
65803 DO 1180 I=MAX(1,IP),N
65804 IF(K(I,1).EQ.41) NJU=NJU+1
65805 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
65807 IF(KC.EQ.0) GOTO 1180
65808 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65809 IF(KQ.EQ.0) GOTO 1180
65815 DPS(5)=DPS(5)+PYMASS(K(I,2))
65818 DPS(J)=DPS(J)+P(I,J)
65820 IF(K(I,1).EQ.1) THEN
65822 IF(NJU.EQ.0.AND.NP.NE.1) THEN
65823 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
65824 ELSEIF(NJU.EQ.1) THEN
65825 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
65826 ELSEIF(NJU.EQ.2) THEN
65827 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
65828 ELSEIF(NJU.GE.3) THEN
65831 IF(NFERR.EQ.1) THEN
65832 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
65836 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
65837 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
65838 & '(PYPREP:) too small mass in jet system')
65852 C*********************************************************************
65855 C...Handles the fragmentation of an arbitrary colour singlet
65856 C...jet system according to the Lund string fragmentation model.
65858 SUBROUTINE PYSTRF(IP)
65860 C...Double precision and integer declarations.
65861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65862 IMPLICIT INTEGER(I-N)
65863 INTEGER PYK,PYCHGE,PYCOMP
65865 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65867 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65868 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65869 C...Local arrays. All MOPS variables ends with MO
65870 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
65871 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
65872 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
65873 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
65874 &PBST(3,5),TJUOLD(5)
65876 C...Function: four-product of two vectors.
65877 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)
65878 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
65881 C...Reset counters.
65896 C...Identify parton system.
65899 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65900 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
65901 IF(MSTU(21).GE.1) RETURN
65903 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
65905 IF(KC.EQ.0) GOTO 110
65906 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65907 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
65908 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
65909 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65910 IF(MSTU(21).GE.1) RETURN
65913 C...Take copy of partons to be considered. Check flavour sum.
65918 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
65920 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
65922 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65923 IF(K(I,1).EQ.41) THEN
65924 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
65932 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
65933 IF(MOD(KQSUM,3).NE.0) THEN
65934 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
65935 IF(MSTU(21).GE.1) RETURN
65937 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
65939 C...Boost copied system to CM frame (for better numerical precision).
65940 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
65943 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
65947 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
65949 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65950 IF(P(I,3).GT.0D0) THEN
65951 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
65952 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65953 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65955 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
65956 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65957 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65962 C...Search for very nearby partons that may be recombined.
65971 IF(MJU(1).GT.0) NRMIN=NRMIN+2
65972 IF(MJU(2).GT.0) NRMIN=NRMIN+2
65973 140 IF(NR.GT.NRMIN) THEN
65976 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
65978 IF(I.EQ.N+NR) I1=N+1
65979 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
65980 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
65982 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
65984 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
65985 & P(I1,2)**2+P(I1,3)**2))
65986 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
65987 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
65988 IF(PDR.LT.PDRMIN) THEN
65994 C...Recombine very nearby partons to avoid machine precision problems.
65995 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
65997 P(N+1,J)=P(N+1,J)+P(N+NR,J)
65999 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
66003 ELSEIF(PDRMIN.LT.PARU12) THEN
66005 P(IR,J)=P(IR,J)+P(IR+1,J)
66007 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
66009 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
66010 DO 190 I=IR+1,N+NR-1
66017 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
66019 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
66020 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
66026 C...Reset particle counter. Skip ahead if no junctions are present;
66027 C...this is usually the case!
66028 NRS=MAX(5*NR+11,NP)
66031 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66035 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
66036 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66037 IF(MSTU(21).GE.1) RETURN
66041 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
66042 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
66043 & ' junction strings not handled by MSTJ(12)>3 options')
66046 IF(MJU(JT).EQ.0) GOTO 640
66050 C...Find and sum up momentum on three sides of junction.
66051 C...Begin with previous boost = zero.
66056 C...Prevent IJU (specifically IJU(5)) from containing junk below
66062 C...Beginning and end of string system in event record.
66063 I1BEG=N+1+(JT-1)*(NR-1)
66064 I1END=N+NR+(JT-1)*(1-NR)
66065 C...Look for junction string piece end points
66066 DO 230 I1=I1BEG,I1END,JS
66067 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
66068 C...Store junction string piece end points.
66069 C 1-junction systems 2-junction systems
66070 C IU : 1 2 3 4 1 2 3 4 5 6
66071 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
66075 C...Sum over momenta, from junction outwards.
66079 C...Initialize junction drag and string piece 4-vectors.
66084 C...First two branches. Inwards out means opposite direction to JS.
66085 C...(JS is 1 for JT=1, -1 for JT=2)
66090 C...Last branch (gq or gjgqgq). Direction now reversed.
66096 DO 270 I1=I1A,I1B,IDIR
66097 C...Sum up momentum directions with exponential suppression
66098 C...for use in finding junction rest frame below.
66099 IF (K(I1,2).EQ.88) THEN
66100 C...gjgqgq type system encountered. Use current PWT as start
66101 C...for both strings.
66104 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
66105 C...Sum up string piece (boosted) 4-momenta.
66107 PJU(IU,J)=PJU(IU,J)+P(I1,J)
66109 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
66110 C...boost is zero, see above). Skip parton if suppression factor large.
66111 IF (PWT.GT.10D0) GOTO 270
66112 C...Compute momentum in current frame:
66113 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
66114 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
66116 PTMP=P(I1,J)+TJUOLD(J)*BFC
66117 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
66120 PTMP=TJUOLD(4)*P(I1,4)+TDP
66121 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
66122 PWT=PWT+PTMP/PARJ(48)
66125 C...Put |p| rather than m in 5th slot.
66126 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
66127 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
66130 C...Calculate boost from present frame to next JRF candidate.
66132 CALL PYJURF(PBST,TJU)
66134 C...After some iterations do not take full step in new direction.
66135 IF(IJRFIT.GT.5) THEN
66136 REDUCE=0.8D0**(IJRFIT-5)
66137 TJU(1)=REDUCE*TJU(1)
66138 TJU(2)=REDUCE*TJU(2)
66139 TJU(3)=REDUCE*TJU(3)
66140 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
66143 C...Combine new boost (TJU) with old boost (TJUOLD)
66144 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
66146 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
66148 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
66150 C...If last boost small, accept JRF, else iterate.
66151 C...Also prevent possibility of infinite loop.
66152 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
66153 & IJRFIT.LT.MSTJ(18)) THEN
66155 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
66156 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
66159 C...Now store total boost in TJU and change perception.
66160 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
66161 C...TJU = junction motion vector in string CM, so the sign changes.
66165 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
66169 C...Calculate string piece energies in junction rest frame.
66171 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
66173 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
66174 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
66177 C...Start preparing for fragmentation of two strings from junction.
66180 320 NTRYER=NTRYER+1
66183 NS=IABS(IJU(IU+1)-IJU(IU))
66185 C...Junction strings: find longitudinal string directions.
66187 IS1=IJU(IU)+JS*(IS-1)
66190 DP(1,J)=0.5D0*P(IS1,J)
66191 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
66192 DP(2,J)=0.5D0*P(IS2,J)
66193 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
66194 & (PJU(IU,5)/PBST(IU,5))
66196 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
66197 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
66201 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
66202 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66203 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66208 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
66209 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
66210 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
66212 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
66214 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
66215 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
66219 C...Junction strings: initialize flavour, momentum and starting pos.
66223 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66227 ELSEIF(NTRY.GT.100) THEN
66228 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66229 IF(MSTU(21).GE.1) RETURN
66234 IE(1)=K(N+1+(JT/2)*(NP-1),3)
66235 IF (MOD(JT+IU,2).NE.0) THEN
66237 IF (NP-NR.NE.0) THEN
66238 C...If gluons have disappeared. Original IJU must be used.
66242 IF (K(IT,2).NE.21) THEN
66245 IF (NE.EQ.IU+4*(JT-1)) THEN
66247 ELSEIF (IT.LE.IP+NP) THEN
66250 CALL PYERRM(14,'(PYSTRF:) '//
66251 & 'Original IJU could not be reconstructed!')
66259 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
66265 KFL(1)=K(IJU(IU),2)
66273 C...Junction strings: find initial transverse directions.
66276 DP(2,J)=P(IN(4)+1,J)
66280 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66281 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66282 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66283 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66284 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66285 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66286 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66287 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66288 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66290 DHCX1=DFOUR(3,1)/DHC12
66291 DHCX2=DFOUR(3,2)/DHC12
66292 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66293 DHCY1=DFOUR(4,1)/DHC12
66294 DHCY2=DFOUR(4,2)/DHC12
66295 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66296 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66298 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66300 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66304 C...Junction strings: produce new particle, origin.
66306 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
66307 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
66308 IF(MSTU(21).GE.1) RETURN
66316 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
66317 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
66318 IF(K(I,2).EQ.0) GOTO 360
66319 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
66320 & IABS(KFL(3)).GT.10) THEN
66321 IF(PYR(0).GT.PARJ(19)) GOTO 440
66323 P(I,5)=PYMASS(K(I,2))
66324 CALL PYPTDI(KFL(1),PX(3),PY(3))
66325 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
66326 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
66327 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
66328 & MSTU(90).LT.8) THEN
66329 MSTU(90)=MSTU(90)+1
66330 MSTU(90+MSTU(90))=I
66331 PARU(90+MSTU(90))=Z
66333 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
66338 C...Junction strings: stepping within 'low' string region.
66339 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
66340 & P(IN(1),5)**2.GE.PR(1)) THEN
66341 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
66342 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
66344 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
66347 C...Has used up energy of junction string, i.e. no more hadrons in it.
66348 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
66353 C...Stepping from 'low' string region
66354 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
66355 P(IN(2)+2,4)=P(IN(2)+2,3)
66358 IF(IN(2).GT.N+NR+4*NS) GOTO 360
66359 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66360 P(IN(1)+2,4)=P(IN(1)+2,3)
66366 C...Junction strings: find new transverse directions.
66367 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
66368 & IN(1).GT.IN(2)) GOTO 360
66369 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
66376 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66377 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66379 IF(DHC12.LE.1D-2) THEN
66380 P(IN(1)+2,4)=P(IN(1)+2,3)
66386 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66387 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66388 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66389 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66390 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66391 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66392 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66393 DHCX1=DFOUR(3,1)/DHC12
66394 DHCX2=DFOUR(3,2)/DHC12
66395 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66396 DHCY1=DFOUR(4,1)/DHC12
66397 DHCY2=DFOUR(4,2)/DHC12
66398 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66399 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66401 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66403 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66406 C...Express pT with respect to new axes, if sensible.
66407 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
66408 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
66409 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
66415 C...Junction strings: sum up known four-momentum, coefficients for m2.
66418 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
66419 & PY(3)*P(IN(3)+1,J)
66420 DO 510 IN1=IN(4),IN(1)-4,4
66421 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
66423 DO 520 IN2=IN(5),IN(2)-4,4
66424 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
66428 DHM(2)=2D0*FOUR(I,IN(1))
66429 DHM(3)=2D0*FOUR(I,IN(2))
66430 DHM(4)=2D0*FOUR(IN(1),IN(2))
66432 C...Junction strings: find coefficients for Gamma expression.
66433 DO 550 IN2=IN(1)+1,IN(2),4
66434 DO 540 IN1=IN(1),IN2-1,4
66435 DHC=2D0*FOUR(IN1,IN2)
66436 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
66437 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
66438 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
66439 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
66443 C...Junction strings: solve (m2, Gamma) equation system for energies.
66444 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
66445 IF(ABS(DHS1).LT.1D-4) GOTO 360
66446 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
66447 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
66448 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
66449 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
66450 & ABS(DHS1)-DHS2/DHS1)
66451 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
66452 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
66453 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
66455 C...Junction strings: step to new region if necessary.
66456 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
66457 P(IN(2)+2,4)=P(IN(2)+2,3)
66460 IF(IN(2).GT.N+NR+4*NS) GOTO 360
66461 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66462 P(IN(1)+2,4)=P(IN(1)+2,3)
66467 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
66468 P(IN(1)+2,4)=P(IN(1)+2,3)
66474 C...Junction strings: particle four-momentum, remainder, loop back.
66476 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
66477 & P(IN(2)+2,4)*P(IN(2),J)
66478 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
66480 IF(P(I,4).LT.P(I,5)) GOTO 360
66481 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
66482 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
66483 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
66488 IF(IN(3).NE.IN(6)) THEN
66490 P(IN(6),J)=P(IN(3),J)
66491 P(IN(6)+1,J)=P(IN(3)+1,J)
66496 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
66497 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
66502 C...Junction strings: save quantities left after each string.
66503 IF(IABS(KFL(1)).GT.10) GOTO 360
66507 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
66510 C...Junction strings: loopback if much unused energy in both strings.
66511 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
66512 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
66513 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
66515 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
66516 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
66517 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
66518 & .AND.NTRYER.LT.10) GOTO 320
66520 C...Junction strings: put together to new effective string endpoint.
66522 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
66523 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
66524 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
66525 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
66527 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
66528 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
66530 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
66535 C...Open versus closed strings. Choose breakup region for latter.
66536 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
66539 ELSEIF(MJU(1).NE.0) THEN
66542 ELSEIF(MJU(2).NE.0) THEN
66545 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
66552 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
66553 W2SUM=W2SUM+P(N+NR+IS,1)
66558 W2SUM=W2SUM-P(N+NR+NB,1)
66559 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
66562 C...Find longitudinal string directions (i.e. lightlike four-vectors).
66564 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
66565 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
66568 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
66569 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
66571 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
66572 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
66574 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
66575 & DP(1,2)**2-DP(1,3)**2))
66576 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
66577 & DP(2,2)**2-DP(2,3)**2))
66581 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
66582 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
66583 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
66584 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
66586 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
66588 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
66589 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
66593 C...Begin initialization: sum up energy, set starting position.
66597 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66601 ELSEIF(NTRY.GT.100) THEN
66602 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66603 IF(MSTU(21).GE.1) RETURN
66610 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
66615 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
66616 IF(NS.GT.NR) IRANK(JT)=1
66618 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
66619 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
66620 IN(3*JT+2)=IN(3*JT+1)+1
66621 IN(3*JT+3)=N+NR+4*NS+2*JT-1
66622 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
66629 C.. MOPS variables and switches
66635 C...Initialize flavour and pT variables for open string.
66639 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
66643 KFL(JT)=K(IE(JT),2)
66644 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
66645 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
66647 PMQ(JT)=PYMASS(KFL(JT))
66651 C...Closed string: random initial breakup flavour, pT and vertex.
66653 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
66655 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
66656 C.. Closed string: first vertex diq attempt => enforced second
66658 IF(IABS(KFL(1)).GT.10)THEN
66663 IF(IBMO.EQ.1) MSTU(121)=-1
66665 CALL PYPTDI(KFL(1),PX(1),PY(1))
66668 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
66669 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
66670 ZR=PR3/(Z*P(N+NR+1,5)**2)
66671 IF(ZR.GE.1D0) GOTO 780
66674 PMQ(JT)=PYMASS(KFL(JT))
66675 GAM(JT)=PR3*(1D0-Z)/Z
66676 IN1=N+NR+3+4*(JT/2)*(NS-1)
66679 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
66682 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
66688 PM2QMO(JT)=PMQ(JT)**2
66689 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
66692 C...Find initial transverse directions (i.e. spacelike four-vectors).
66694 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
66703 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66704 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66705 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66706 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66707 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66708 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66709 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66710 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66711 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66713 DHCX1=DFOUR(3,1)/DHC12
66714 DHCX2=DFOUR(3,2)/DHC12
66715 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66716 DHCY1=DFOUR(4,1)/DHC12
66717 DHCY2=DFOUR(4,2)/DHC12
66718 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66719 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66721 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66723 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66728 P(IN3+2,J)=P(IN3,J)
66729 P(IN3+3,J)=P(IN3+1,J)
66734 C...Remove energy used up in junction string fragmentation.
66735 IF(MJU(1)+MJU(2).GT.0) THEN
66737 IF(NJS(JT).EQ.0) GOTO 860
66739 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
66743 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
66744 WMIN=PARJST+PMQ(1)+PMQ(2)
66745 WREM2=FOUR(N+NRS,N+NRS)
66746 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
66748 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
66753 C...Produce new particle: side, origin.
66755 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
66756 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
66757 IF(MSTU(21).GE.1) RETURN
66759 C.. New side priority for popcorn systems
66760 IF(MSTU(121).LE.0)THEN
66762 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
66763 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
66767 IRANK(JT)=IRANK(JT)+1
66772 C...Generate flavour, hadron and pT.
66774 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
66775 IF(K(I,2).EQ.0) GOTO 710
66777 IF(MSTU(121).EQ.-1) GOTO 910
66778 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
66779 &IABS(KFL(3)).GT.10) THEN
66780 IF(PYR(0).GT.PARJ(19)) GOTO 880
66782 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
66784 P(I,5)=PYMASS(K(I,2))
66785 CALL PYPTDI(KFL(JT),PX(3),PY(3))
66786 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
66788 C...Final hadrons for small invariant mass.
66790 PMQ(3)=PYMASS(KFL(3))
66792 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
66793 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
66794 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
66795 &WMIN-0.5D0*PARJ(36)*PMQ(3)
66796 WREM2=FOUR(N+NRS,N+NRS)
66797 IF(WREM2.LT.0.10D0) GOTO 710
66798 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
66799 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
66801 C...Choose z, which gives Gamma. Shift z for heavy flavours.
66802 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
66803 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
66804 &MSTU(90).LT.8) THEN
66805 MSTU(90)=MSTU(90)+1
66806 MSTU(90+MSTU(90))=I
66807 PARU(90+MSTU(90))=Z
66811 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
66812 &MOD(KFL2A/1000,10)).GE.4) THEN
66813 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
66814 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
66815 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
66816 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
66817 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
66819 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
66821 C.. MOPS baryon model modification
66822 XTMO3=(1D0-Z)*XTMO(JT)
66823 IF(IABS(KFL(3)).LE.10) NRVMO=0
66824 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
66828 IF(IABS(KFL(JT)).LE.10)THEN
66829 XBMO=MIN(XTMO3,1D0-(2D-10))
66832 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
66833 GTSTMO=1D0-PARF(192)**PGMO
66835 IF(IRANK(JT).EQ.1) THEN
66840 IF(XBMO.LT.1D0-(1D-10))THEN
66841 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
66842 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
66845 IF(MSTJ(12).GE.5)THEN
66846 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
66847 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
66848 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
66853 C.. MOPS Accepting popcorn system hadron.
66854 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
66855 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
66857 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
66859 & '(PYSTRF:) no more memory left in PYJETS')
66860 IF(MSTU(21).GE.1) RETURN
66872 DO 890 LINE=1,I-N-NR
66873 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
66874 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
66881 C..Reject popcorn system, flag=-1 if enforcing new one
66883 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
66888 C..Lift restoring string outside MOPS block
66889 910 IF(MSTU(121).LT.0) THEN
66890 IF(MSTU(121).EQ.-2) MSTU(121)=0
66893 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
66904 DO 920 LINE=1,I-N-NR
66905 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
66906 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
66914 C.. MOPS end of modification
66920 C...Stepping within or from 'low' string region easy.
66921 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
66922 &P(IN(1),5)**2.GE.PR(JT)) THEN
66923 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
66924 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
66926 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
66929 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
66930 P(IN(JR)+2,4)=P(IN(JR)+2,3)
66933 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
66934 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66935 P(IN(JT)+2,4)=P(IN(JT)+2,3)
66941 C...Find new transverse directions (i.e. spacelike string vectors).
66942 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
66943 &IN(1).GT.IN(2)) GOTO 710
66944 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
66951 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66952 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66954 IF(DHC12.LE.1D-2) THEN
66955 P(IN(JT)+2,4)=P(IN(JT)+2,3)
66961 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66962 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66963 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66964 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66965 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66966 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66967 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66968 DHCX1=DFOUR(3,1)/DHC12
66969 DHCX2=DFOUR(3,2)/DHC12
66970 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66971 DHCY1=DFOUR(4,1)/DHC12
66972 DHCY2=DFOUR(4,2)/DHC12
66973 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66974 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66976 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66978 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66981 C...Express pT with respect to new axes, if sensible.
66982 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
66983 & FOUR(IN(3*JT+3)+1,IN(3)))
66984 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
66985 & FOUR(IN(3*JT+3)+1,IN(3)+1))
66986 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
66992 C...Sum up known four-momentum. Gives coefficients for m2 expression.
66995 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
66996 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
66997 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
66998 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
67000 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
67001 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
67005 DHM(2)=2D0*FOUR(I,IN(1))
67006 DHM(3)=2D0*FOUR(I,IN(2))
67007 DHM(4)=2D0*FOUR(IN(1),IN(2))
67009 C...Find coefficients for Gamma expression.
67010 DO 1030 IN2=IN(1)+1,IN(2),4
67011 DO 1020 IN1=IN(1),IN2-1,4
67012 DHC=2D0*FOUR(IN1,IN2)
67013 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
67014 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
67015 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
67016 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
67020 C...Solve (m2, Gamma) equation system for energies taken.
67021 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
67022 IF(ABS(DHS1).LT.1D-4) GOTO 710
67023 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
67024 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
67025 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
67026 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
67027 &ABS(DHS1)-DHS2/DHS1)
67028 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
67029 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
67030 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
67032 C...Step to new region if necessary.
67033 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
67034 P(IN(JR)+2,4)=P(IN(JR)+2,3)
67037 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
67038 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
67039 P(IN(JT)+2,4)=P(IN(JT)+2,3)
67044 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
67045 P(IN(JT)+2,4)=P(IN(JT)+2,3)
67051 C...Four-momentum of particle. Remaining quantities. Loop back.
67053 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
67054 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
67056 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
67057 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
67059 IF(P(I,4).LT.P(I,5)) GOTO 710
67065 IF(IN(3).NE.IN(3*JT+3)) THEN
67067 P(IN(3*JT+3),J)=P(IN(3),J)
67068 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
67073 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
67074 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
67076 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67080 C...Final hadron: side, flavour, hadron, mass.
67086 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
67087 IF(K(I,2).EQ.0) GOTO 710
67088 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
67090 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67092 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67094 P(I,5)=PYMASS(K(I,2))
67095 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
67097 C...Final two hadrons: find common setup of four-vectors.
67099 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
67100 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
67101 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
67102 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
67103 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
67104 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
67105 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
67106 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
67107 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
67108 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
67111 C...Solve kinematics for final two hadrons, if possible.
67112 WREM2=2D0*DHR1*DHR2*DHC12
67113 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
67114 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
67115 IF(FD.GE.1D0) GOTO 710
67116 FA=WREM2+PR(JT)-PR(JR)
67117 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
67119 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
67120 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
67121 FB=SIGN(FB,JS*(PYR(0)-PREV))
67124 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
67125 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
67126 &4D0*WREM2*PR(JT))),DBLE(JS))
67128 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
67129 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
67130 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
67131 P(I,J)=P(N+NRS,J)-P(I-1,J)
67133 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
67134 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
67135 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
67136 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
67138 IF(NTRYFN.LT.100) GOTO 140
67139 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
67142 C...Mark jets as fragmented and give daughter pointers.
67144 DO 1100 I=NSAV+1,NSAV+NP
67147 IF(MSTU(16).NE.2) THEN
67156 C...Document string system. Move up particles.
67167 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
67171 K(I,J)=K(I+NRS-1,J)
67172 P(I,J)=P(I+NRS-1,J)
67177 DO 1140 IZ=MSTU90+1,MSTU91
67178 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
67179 PARU9T(IZ)=PARU(90+IZ)
67183 C...Order particles in rank along the chain. Update mother pointer.
67186 K(I-NSAV+N,J)=K(I,J)
67187 P(I-NSAV+N,J)=P(I,J)
67191 DO 1190 I=N+1,2*N-NSAV
67192 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
67198 IF(MSTU(16).NE.2) K(I1,3)=NSAV
67199 DO 1180 IZ=MSTU90+1,MSTU91
67200 IF(MSTU9T(IZ).EQ.I) THEN
67201 MSTU(90)=MSTU(90)+1
67202 MSTU(90+MSTU(90))=I1
67203 PARU(90+MSTU(90))=PARU9T(IZ)
67207 DO 1220 I=2*N-NSAV,N+1,-1
67208 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
67214 IF(MSTU(16).NE.2) K(I1,3)=NSAV
67215 DO 1210 IZ=MSTU90+1,MSTU91
67216 IF(MSTU9T(IZ).EQ.I) THEN
67217 MSTU(90)=MSTU(90)+1
67218 MSTU(90+MSTU(90))=I1
67219 PARU(90+MSTU(90))=PARU9T(IZ)
67224 C...Boost back particle system. Set production vertices.
67227 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
67231 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
67232 IF(P(I,3).GT.0D0) THEN
67233 HHPEZ=(P(I,4)+P(I,3))*HHBZ
67234 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
67235 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
67237 HHPEZ=(P(I,4)-P(I,3))/HHBZ
67238 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
67239 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
67252 C*********************************************************************
67255 C...From three given input vectors in PJU the boost VJU from
67256 C...the "lab frame" to the junction rest frame is constructed.
67258 SUBROUTINE PYJURF(PJU,VJU)
67260 C...Double precision and integer declarations.
67261 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67262 IMPLICIT INTEGER(I-N)
67264 C...Input, output and local arrays.
67265 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
67266 DATA TWOPI/6.283186D0/
67268 C...Calculate masses and other invariants.
67270 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
67272 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
67273 PSUM(5)=SQRT(PSUM2)
67276 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
67277 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
67281 C...Pick I to be most massive parton and J to be the one closest to I.
67284 IF(A(2,2).GT.A(1,1)) I=2
67285 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
67289 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
67300 C...Trivial find new parton energies if all three partons are massless.
67301 IF(PMI2.LT.1D-4) THEN
67302 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
67303 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
67304 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
67306 C...Else find momentum range for parton I and values at extremes.
67312 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
67313 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
67314 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
67315 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
67316 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
67317 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
67318 HI=PEIMAX**2-0.25D0*PAIMAX**2
67319 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
67320 & 0.5D0*PAIMAX*AIJ)/HI
67321 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
67322 & 0.5D0*PAIMAX*AIK)/HI
67323 PEJMAX=SQRT(PAJMAX**2+PMJ2)
67324 PEKMAX=SQRT(PAKMAX**2+PMK2)
67325 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
67327 C...If unexpected values at upper endpoint then pick another parton.
67328 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
67330 IF(A(I1,I1).GE.1D-4) THEN
67336 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
67342 C..Start binary + linear search to find solution inside range.
67346 PAI=0.5D0*(PAIMIN+PAIMAX)
67349 C...Derive momentum of other two partons and distance to root.
67350 PEI=SQRT(PAI**2+PMI2)
67351 HI=PEI**2-0.25D0*PAI**2
67352 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
67353 PEJ=SQRT(PAJ**2+PMJ2)
67354 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
67355 PEK=SQRT(PAK**2+PMK2)
67356 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
67358 C...Pick next I momentum to explore, hopefully closer to root.
67359 IF(FNOW.GT.0D0) THEN
67368 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
67370 PAI=0.5D0*(PAIMIN+PAIMAX)
67372 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
67373 & ABS(FNOW).GT.1D-12*PSUM2) THEN
67374 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
67379 C...Now know energies in junction rest frame.
67384 C...Boost (copy of) partons to their rest frame.
67385 VXCM=-PSUM(1)/PSUM(5)
67386 VYCM=-PSUM(2)/PSUM(5)
67387 VZCM=-PSUM(3)/PSUM(5)
67388 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
67390 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
67391 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
67392 PCM(I,1)=PJU(I,1)+FAC2*VXCM
67393 PCM(I,2)=PJU(I,2)+FAC2*VYCM
67394 PCM(I,3)=PJU(I,3)+FAC2*VZCM
67395 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
67396 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
67399 C...Construct difference vectors and boost to junction rest frame.
67401 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
67402 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
67404 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
67405 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
67406 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
67407 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
67408 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
67409 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
67410 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
67411 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
67412 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
67413 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
67414 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
67416 C...Add two boosts, giving final result.
67417 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
67418 VJU(1)=VXJU+FCM*VXCM
67419 VJU(2)=VYJU+FCM*VYCM
67420 VJU(3)=VZJU+FCM*VZCM
67421 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
67424 C...In case of error in reconstruction: revert to CM frame of system.
67425 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
67426 &(PCM(1,5)*PCM(2,5))
67427 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
67428 &(PCM(1,5)*PCM(3,5))
67429 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
67430 &(PCM(2,5)*PCM(3,5))
67431 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
67432 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
67434 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
67435 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
67436 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
67437 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
67438 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
67439 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
67440 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
67442 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
67443 &(PCM(1,5)*PCM(2,5))
67444 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
67445 &(PCM(1,5)*PCM(3,5))
67446 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
67447 &(PCM(2,5)*PCM(3,5))
67448 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
67449 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
67450 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
67460 C*********************************************************************
67463 C...Handles the fragmentation of a jet system (or a single
67464 C...jet) according to independent fragmentation models.
67466 SUBROUTINE PYINDF(IP)
67468 C...Double precision and integer declarations.
67469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67470 IMPLICIT INTEGER(I-N)
67471 INTEGER PYK,PYCHGE,PYCOMP
67473 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67474 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67475 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67476 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
67478 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
67479 &KFLO(2),PXO(2),PYO(2),WO(2)
67481 C.. MOPS error message
67482 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
67483 &' are not treated as expected in independent fragmentation')
67485 C...Reset counters. Identify parton system and take copy. Check flavour.
67495 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
67496 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
67497 IF(MSTU(21).GE.1) RETURN
67499 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
67501 IF(KC.EQ.0) GOTO 110
67502 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
67503 IF(KQ.EQ.0) GOTO 110
67505 IF(KQ.NE.2) KQSUM=KQSUM+KQ
67507 K(NSAV+NJET,J)=K(I,J)
67508 P(NSAV+NJET,J)=P(I,J)
67509 DPS(J)=DPS(J)+P(I,J)
67512 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
67513 &K(I+1,1).EQ.2)) GOTO 110
67514 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
67515 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
67516 IF(MSTU(21).GE.1) RETURN
67519 C...Boost copied system to CM frame. Find CM energy and sum flavours.
67522 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
67523 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
67529 DO 140 I=NSAV+1,NSAV+NJET
67533 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
67534 ELSEIF(KFA.GT.1000) THEN
67535 KFLA=MOD(KFA/1000,10)
67536 KFLB=MOD(KFA/100,10)
67537 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
67538 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
67542 C...Loop over attempts made. Reset counters.
67545 IF(NTRY.GT.200) THEN
67546 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
67547 IF(MSTU(21).GE.1) RETURN
67557 C...Loop over jets to be fragmented.
67558 DO 230 IP1=NSAV+1,NSAV+NJET
67563 C...Initial flavour and momentum values. Jet along +z axis.
67564 KFLH=IABS(K(IP1,2))
67565 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
67567 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
67569 C...Initial values for quark or diquark jet.
67570 170 IF(IABS(K(IP1,2)).NE.21) THEN
67573 CALL PYPTDI(0,PXO(1),PYO(1))
67576 C...Initial values for gluon treated like random quark jet.
67577 ELSEIF(MSTJ(2).LE.2) THEN
67579 IF(MSTJ(2).EQ.2) MSTJ(91)=1
67580 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
67581 CALL PYPTDI(0,PXO(1),PYO(1))
67584 C...Initial values for gluon treated like quark-antiquark jet pair,
67585 C...sharing energy according to Altarelli-Parisi splitting function.
67588 IF(MSTJ(2).EQ.4) MSTJ(91)=1
67589 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
67591 CALL PYPTDI(0,PXO(1),PYO(1))
67594 WO(1)=WF*PYR(0)**(1D0/3D0)
67598 C...Initial values for rank, flavour, pT and W+.
67608 C...New hadron. Generate flavour and hadron species.
67610 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
67611 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
67612 IF(MSTU(21).GE.1) RETURN
67619 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
67620 IF(K(I,2).EQ.0) GOTO 180
67621 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
67622 IF(PYR(0).GT.PARJ(19)) GOTO 200
67625 C...Find hadron mass. Generate four-momentum.
67626 P(I,5)=PYMASS(K(I,2))
67627 CALL PYPTDI(KFL1,PX2,PY2)
67630 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
67631 CALL PYZDIS(KFL1,KFL2,PR,Z)
67633 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
67635 MSTU(90)=MSTU(90)+1
67636 MSTU(90+MSTU(90))=I
67637 PARU(90+MSTU(90))=Z
67639 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
67640 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
67641 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
67642 & P(I,3).LE.0.001D0) THEN
67643 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
67649 C...Remaining flavour and momentum.
67658 C...Check if pL acceptable. Go back for new hadron if enough energy.
67659 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
67661 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
67663 IF(W.GT.PARJ(31)) GOTO 190
67666 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
67667 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
67669 C...Rotate jet to new direction.
67670 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
67671 PHI=PYANGL(P(IP1,1),P(IP1,2))
67673 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
67674 K(K(IP1,3),4)=NSAV1+1
67677 C...End of jet generation loop. Skip conservation in some cases.
67679 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
67680 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
67682 C...Subtract off produced hadron flavours, finished if zero.
67683 DO 240 I=NSAV+NJET+1,N
67685 KFLA=MOD(KFA/1000,10)
67686 KFLB=MOD(KFA/100,10)
67687 KFLC=MOD(KFA/10,10)
67689 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
67690 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
67692 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
67693 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
67694 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
67697 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67698 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67699 IF(NREQ.EQ.0) GOTO 320
67701 C...Take away flavour of low-momentum particles until enough freedom.
67705 DO 260 I=NSAV+NJET+1,N
67706 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
67707 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
67708 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
67710 IF(IREM.EQ.0) GOTO 150
67712 KFA=IABS(K(IREM,2))
67713 KFLA=MOD(KFA/1000,10)
67714 KFLB=MOD(KFA/100,10)
67715 KFLC=MOD(KFA/10,10)
67716 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
67717 IF(K(IREM,1).EQ.8) GOTO 250
67719 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
67720 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
67721 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
67723 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
67724 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
67725 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
67728 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67729 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67730 IF(NREQ.GT.NREM) GOTO 250
67731 DO 270 I=NSAV+NJET+1,N
67732 IF(K(I,1).EQ.8) K(I,1)=1
67735 C...Find combination of existing and new flavours for hadron.
67737 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
67738 IF(NREQ.LT.NREM) NFET=1
67739 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
67741 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
67742 KFLF(J)=ISIGN(1,NFL(1))
67743 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
67744 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
67746 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
67748 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
67749 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
67750 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
67751 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
67752 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
67753 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
67754 IF(NFET.LE.2) KFLF(3)=0
67755 IF(KFLF(3).NE.0) THEN
67756 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
67757 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
67758 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
67759 & KFLFC=KFLFC+ISIGN(2,KFLFC)
67763 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
67764 IF(KF.EQ.0) GOTO 280
67765 DO 300 J=1,MAX(2,NFET)
67766 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
67769 C...Store hadron at random among free positions.
67770 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
67771 DO 310 I=NSAV+NJET+1,N
67772 IF(K(I,1).EQ.7) NPOS=NPOS-1
67773 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
67776 P(I,5)=PYMASS(K(I,2))
67777 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67780 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67781 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67782 IF(NREM.GT.0) GOTO 280
67784 C...Compensate for missing momentum in global scheme (3 options).
67785 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
67788 DO 330 I=NSAV+NJET+1,N
67789 PSI(J)=PSI(J)+P(I,J)
67792 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
67794 DO 350 I=NSAV+NJET+1,N
67795 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
67796 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
67797 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
67798 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
67800 DO 370 I=NSAV+NJET+1,N
67801 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
67802 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
67803 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
67804 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
67806 P(I,J)=P(I,J)-PSI(J)*PW/PWS
67808 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67811 C...Compensate for missing momentum withing each jet separately.
67812 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
67813 DO 390 I=N+1,N+NJET
67819 DO 410 I=NSAV+NJET+1,N
67822 K(IR2,1)=K(IR2,1)+1
67823 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
67824 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
67826 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
67828 P(IR2,4)=P(IR2,4)+P(I,4)
67829 P(IR2,5)=P(IR2,5)+PLS
67832 DO 420 I=N+1,N+NJET
67833 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
67835 DO 440 I=NSAV+NJET+1,N
67838 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
67839 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
67841 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
67844 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67848 C...Scale momenta for energy conservation.
67849 IF(MOD(MSTJ(3),5).NE.0) THEN
67853 DO 450 I=NSAV+NJET+1,N
67856 PQS=PQS+P(I,5)**2/P(I,4)
67858 IF(PMS.GE.PECM) GOTO 150
67861 PFAC=(PECM-PQS)/(PES-PQS)
67864 DO 480 I=NSAV+NJET+1,N
67868 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67870 PQS=PQS+P(I,5)**2/P(I,4)
67872 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
67875 C...Origin of produced particles and parton daughter pointers.
67876 490 DO 500 I=NSAV+NJET+1,N
67877 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
67878 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
67880 DO 510 I=NSAV+1,NSAV+NJET
67883 IF(MSTU(16).NE.2) THEN
67887 K(I1,4)=K(I1,4)-NJET+1
67888 K(I1,5)=K(I1,5)-NJET+1
67889 IF(K(I1,5).LT.K(I1,4)) THEN
67896 C...Document independent fragmentation system. Remove copy of jets.
67907 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
67909 DO 540 I=NSAV+NJET,N
67911 K(I-NJET+1,J)=K(I,J)
67912 P(I-NJET+1,J)=P(I,J)
67913 V(I-NJET+1,J)=V(I,J)
67917 DO 550 IZ=MSTU90+1,MSTU(90)
67918 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
67921 C...Boost back particle system. Set production vertices.
67922 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
67923 &DPS(2)/DPS(4),DPS(3)/DPS(4))
67933 C*********************************************************************
67936 C...Handles the decay of unstable particles.
67938 SUBROUTINE PYDECY(IP)
67940 C...Double precision and integer declarations.
67941 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67942 IMPLICIT INTEGER(I-N)
67943 INTEGER PYK,PYCHGE,PYCOMP
67945 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67946 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67947 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67948 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
67949 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
67951 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
67952 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
67954 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
67956 C...Functions: momentum in two-particle decays and four-product.
67957 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
67958 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)
67960 C...Initial values.
67964 KFS=ISIGN(1,K(IP,2))
67968 C...Choose lifetime and determine decay vertex.
67969 IF(K(IP,1).EQ.5) THEN
67971 ELSEIF(K(IP,1).NE.4) THEN
67972 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
67975 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
67978 C...Determine whether decay allowed or not.
67980 IF(MSTJ(22).EQ.2) THEN
67981 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
67982 ELSEIF(MSTJ(22).EQ.3) THEN
67983 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
67984 ELSEIF(MSTJ(22).EQ.4) THEN
67985 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
67986 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
67988 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
67993 C...Interface to external tau decay library (for tau polarization).
67994 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
67996 C...Starting values for pointers and momenta.
68000 PCMTAU(J)=P(ITAU,J)
68003 C...Iterate to find position and code of mother of tau.
68005 120 IMTAU=K(IMTAU,3)
68007 IF(IMTAU.EQ.0) THEN
68008 C...If no known origin then impossible to do anything further.
68012 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
68013 C...If tau -> tau + gamma then add gamma energy and loop.
68014 IF(K(K(IMTAU,4),2).EQ.22) THEN
68016 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
68018 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
68020 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
68025 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
68026 C...If coming from weak decay of hadron then W is not stored in record,
68027 C...but can be reconstructed by adding neutrino momentum.
68028 KFORIG=-ISIGN(24,K(ITAU,2))
68030 DO 160 II=K(IMTAU,4),K(IMTAU,5)
68031 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
68033 PCMTAU(J)=PCMTAU(J)+P(II,J)
68039 C...If coming from resonance decay then find latest copy of this
68040 C...resonance (may not completely agree).
68043 DO 170 II=IMTAU+1,IP-1
68044 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
68045 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
68048 PCMTAU(J)=P(IORIG,J)
68052 C...Boost tau to rest frame of production process (where known)
68053 C...and rotate it to sit along +z axis.
68055 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
68057 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
68058 & -DBETAU(2),-DBETAU(3))
68059 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
68060 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
68061 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
68062 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
68064 C...Call tau decay routine (if meaningful) and fill extra info.
68065 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
68066 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
68067 DO 200 II=NSAV+1,NSAV+NDECAY
68076 C...Boost back decay tau and decay products.
68080 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
68081 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
68082 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
68083 & DBETAU(2),DBETAU(3))
68085 C...Skip past ordinary tau decay treatment.
68093 C...B-Bbar mixing: flip sign of meson appropriately.
68095 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
68097 IF(KFA.EQ.531) XBBMIX=PARJ(77)
68098 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
68099 IF(MMIX.EQ.1) KFS=-KFS
68102 C...Check existence of decay channels. Particle/antiparticle rules.
68104 IF(MDCY(KC,2).GT.0) THEN
68105 MDMDCY=MDME(MDCY(KC,2),2)
68106 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
68108 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
68109 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
68112 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
68113 IF(KCHG(KC,3).EQ.0) THEN
68116 IF(PYR(0).GT.0.5D0) KFS=-KFS
68117 ELSEIF(KFS.GT.0) THEN
68125 C...Sum branching ratios of allowed decay channels.
68128 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
68129 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
68130 & KFSN*MDME(IDL,1).NE.3) GOTO 230
68131 IF(MDME(IDL,2).GT.100) GOTO 230
68133 BRSU=BRSU+BRAT(IDL)
68136 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
68140 C...Select decay channel among allowed ones.
68141 240 RBR=BRSU*PYR(0)
68144 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
68145 &KFSN*MDME(IDL,1).NE.3) THEN
68146 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
68147 ELSEIF(MDME(IDL,2).GT.100) THEN
68148 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
68152 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
68155 C...Start readout of decay channel: matrix element, reset counters.
68158 IF(MOD(NTRY,200).EQ.0) THEN
68159 WRITE(CIDC,'(I4)') IDC
68160 C...Do not print warning for some well-known special cases.
68161 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
68162 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
68166 IF(NTRY.GT.1000) THEN
68167 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
68168 IF(MSTU(21).GE.1) RETURN
68174 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
68177 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
68179 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
68185 IF(KFA.GT.80) MHADDY=1
68186 C.. Random flavour and popcorn system memory.
68192 C...Read out decay products. Convert to standard flavour code.
68194 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
68196 IF(JT.LE.5) KP=KFDP(IDC,JT)
68197 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
68198 IF(KP.EQ.0) GOTO 280
68201 IF(KPA.GT.80) MHADDY=1
68202 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
68204 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
68206 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
68207 KFP=-KFS*MOD(KFA/10,10)
68208 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
68209 KFP=KFS*(100*MOD(KFA/10,100)+3)
68210 ELSEIF(KPA.EQ.81) THEN
68211 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
68212 ELSEIF(KP.EQ.82) THEN
68213 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
68214 IF(KFP.EQ.0) GOTO 260
68218 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
68219 ELSEIF(KP.EQ.-82) THEN
68222 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
68224 C...Add decay product to event record or to quark flavour list.
68227 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
68230 C...set rndmflav popcorn system pointer
68231 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
68233 PSQ=PSQ+PYMASS(KFLO(NQ))
68234 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
68235 & MOD(NQ,2).EQ.1) THEN
68240 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
68241 IF(K(I,2).EQ.0) GOTO 260
68243 P(I,5)=PYMASS(K(I,2))
68248 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
68249 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
68251 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
68252 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
68262 C...Check masses for resonance decays.
68263 IF(MHADDY.EQ.0) THEN
68264 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
68267 C...Choose decay multiplicity in phase space model.
68268 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
68270 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
68271 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
68273 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
68274 IF(IRNDMO.EQ.0) THEN
68277 ELSEIF(IRNDMO.EQ.1) THEN
68282 IF(NTRY.GT.1000) THEN
68283 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
68284 IF(MSTU(21).GE.1) RETURN
68286 IF(MMAT.LE.20) THEN
68287 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
68288 & SIN(PARU(2)*PYR(0))
68289 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
68290 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
68291 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
68292 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
68293 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
68297 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
68299 IF(MSTU(121).GT.MSTU(125)) GOTO 300
68301 C...Form hadrons from flavour content.
68305 IF(ND.EQ.NP+NQ/2) GOTO 330
68306 DO 320 I=N+NP+1,N+ND-NQ/2
68307 C.. Stick to started popcorn system, else pick side at random
68309 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
68310 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
68311 IF(K(I,2).EQ.0) GOTO 300
68312 MSTU(125)=MSTU(125)-1
68314 IF(MSTU(121).GT.0) JTMO=JT
68320 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
68321 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
68322 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
68325 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
68326 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
68327 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
68328 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
68330 C...Check that sum of decay product masses not too large.
68332 DO 340 I=N+NP+1,N+ND
68337 P(I,5)=PYMASS(K(I,2))
68340 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
68342 C...Rescale energy to subtract off spectator quark mass.
68343 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
68344 & .AND.NP.GE.3) THEN
68346 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
68348 P(N+NP,J)=PQT*PV(1,J)
68349 PV(1,J)=(1D0-PQT)*PV(1,J)
68351 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
68355 C...Fully specified final state: check mass broadening effects.
68357 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
68361 C...Determine position of grandmother, number of sisters.
68367 IF(IM.LT.0.OR.IM.GE.IP) IM=0
68368 IF(IM.NE.0) KFAM=IABS(K(IM,2))
68370 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
68371 IF(K(IL,3).EQ.IM) NM=NM+1
68372 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
68374 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
68375 & MOD(KFAM/1000,10).NE.0) NM=0
68377 KFAS=IABS(K(ISIS,2))
68378 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
68379 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
68384 C...Kinematics of one-particle decays.
68392 C...Calculate maximum weight ND-particle decay.
68395 WTMAX=1D0/WTCOR(ND-2)
68396 PMAX=PV(1,5)-PS+P(N+ND,5)
68398 DO 380 IL=ND-1,1,-1
68399 PMAX=PMAX+P(N+IL,5)
68400 PMIN=PMIN+P(N+IL+1,5)
68401 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
68405 C...Find virtual gamma mass in Dalitz decay.
68406 390 IF(ND.EQ.2) THEN
68407 ELSEIF(MMAT.EQ.2) THEN
68408 PMES=4D0*PMAS(11,1)**2
68409 PMRHO2=PMAS(131,1)**2
68410 PGRHO2=PMAS(131,2)**2
68411 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
68412 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
68413 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
68414 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
68415 IF(WT.LT.PYR(0)) GOTO 400
68416 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
68418 C...M-generator gives weight. If rejected, try again.
68423 DO 420 IL2=IL1-1,1,-1
68424 IF(RSAV.LE.RORD(IL2)) GOTO 430
68425 RORD(IL2+1)=RORD(IL2)
68427 430 RORD(IL2+1)=RSAV
68431 DO 450 IL=ND-1,1,-1
68432 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
68434 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
68436 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
68439 C...Perform two-particle decays in respective CM frame.
68440 460 DO 480 IL=1,ND-1
68441 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
68442 UE(3)=2D0*PYR(0)-1D0
68444 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
68445 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
68448 PV(IL+1,J)=-PA*UE(J)
68450 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
68451 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
68454 C...Lorentz transform decay products to lab frame.
68458 DO 530 IL=ND-1,1,-1
68460 BE(J)=PV(IL,J)/PV(IL,4)
68462 GA=PV(IL,4)/PV(IL,5)
68464 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
68466 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
68468 P(I,4)=GA*(P(I,4)+BEP)
68472 C...Check that no infinite loop in matrix element weight.
68474 IF(NTRY.GT.800) GOTO 560
68476 C...Matrix elements for omega and phi decays.
68478 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
68479 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
68480 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
68481 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
68483 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
68484 ELSEIF(MMAT.EQ.2) THEN
68485 FOUR12=FOUR(N+1,N+2)
68486 FOUR13=FOUR(N+1,N+3)
68487 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
68488 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
68489 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
68491 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
68492 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
68493 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
68494 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
68496 FOUR12=FOUR(IP,N+1)
68497 FOUR02=FOUR(IM,N+1)
68501 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
68502 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
68503 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
68504 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
68505 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
68506 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
68508 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
68509 ELSEIF(MMAT.EQ.4) THEN
68510 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
68511 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
68512 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
68513 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
68514 & ((1D0-HX3)/(HX1*HX2))**2
68515 IF(WT.LT.2D0*PYR(0)) GOTO 390
68516 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
68519 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
68520 ELSEIF(MMAT.EQ.41) THEN
68521 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
68522 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
68523 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
68524 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
68526 C...Matrix elements for weak decays (only semileptonic for c and b)
68527 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
68528 & .AND.ND.EQ.3) THEN
68529 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
68530 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
68531 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
68532 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
68536 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
68539 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
68540 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
68541 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
68544 C...Scale back energy and reattach spectator.
68545 560 IF(MREM.EQ.1) THEN
68547 PV(1,J)=PV(1,J)/(1D0-PQT)
68553 C...Low invariant mass for system with spectator quark gives particle,
68554 C...not two jets. Readjust momenta accordingly.
68555 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
68557 PM2=PYMASS(K(N+2,2))
68559 PM3=PYMASS(K(N+3,2))
68560 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
68561 & (PARJ(32)+PM2+PM3)**2) GOTO 630
68564 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
68565 IF(K(N+2,2).EQ.0) GOTO 260
68566 P(N+2,5)=PYMASS(K(N+2,2))
68567 PS=P(N+1,5)+P(N+2,5)
68572 ELSEIF(MMAT.EQ.44) THEN
68574 PM3=PYMASS(K(N+3,2))
68576 PM4=PYMASS(K(N+4,2))
68577 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
68578 & (PARJ(32)+PM3+PM4)**2) GOTO 600
68581 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
68582 IF(K(N+3,2).EQ.0) GOTO 260
68583 P(N+3,5)=PYMASS(K(N+3,2))
68585 P(N+3,J)=P(N+3,J)+P(N+4,J)
68587 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)
68588 HA=P(N+1,4)**2-P(N+2,4)**2
68589 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
68590 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
68591 & (P(N+1,3)-P(N+2,3))**2
68592 HD=(PV(1,4)-P(N+3,4))**2
68593 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
68596 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
68598 PCOR=HH*(P(N+1,J)-P(N+2,J))
68599 P(N+1,J)=P(N+1,J)+PCOR
68600 P(N+2,J)=P(N+2,J)-PCOR
68602 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)
68603 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)
68607 C...Check invariant mass of W jets. May give one particle or start over.
68608 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
68609 &.AND.IABS(K(N+1,2)).LT.10) THEN
68610 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
68612 PM1=PYMASS(K(N+1,2))
68614 PM2=PYMASS(K(N+2,2))
68615 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
68616 KFLDUM=INT(1.5D0+PYR(0))
68617 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
68618 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
68619 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
68620 PSM=PYMASS(KF1)+PYMASS(KF2)
68621 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
68622 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
68623 IF(MMAT.EQ.48) GOTO 390
68624 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
68627 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
68628 IF(K(N+1,2).EQ.0) GOTO 260
68629 P(N+1,5)=PYMASS(K(N+1,2))
68632 PS=P(N+1,5)+P(N+2,5)
68633 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
68640 C...Phase space decay of partons from W decay.
68641 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
68647 PV(1,J)=P(N+1,J)+P(N+2,J)
68656 PSQ=PYMASS(KFLO(1))
68658 PSQ=PSQ+PYMASS(KFLO(2))
68663 C...Boost back for rapidly moving particle.
68667 BE(J)=P(IP,J)/P(IP,4)
68671 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
68673 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
68675 P(I,4)=GA*(P(I,4)+BEP)
68679 C...Fill in position of decay vertex.
68687 C...Set up for parton shower evolution from jets.
68688 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
68692 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
68693 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
68694 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
68695 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
68696 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
68697 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
68699 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
68702 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
68703 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
68704 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
68705 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
68707 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
68708 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
68711 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
68712 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
68713 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
68714 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
68716 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
68717 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
68719 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
68724 KCP=PYCOMP(K(NSAV+1,2))
68725 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
68727 IF(KQP.LT.0) JCON=5
68728 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
68729 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
68730 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
68731 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
68733 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
68736 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
68737 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
68738 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
68739 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
68743 C...Mark decayed particle; special option for B-Bbar mixing.
68744 IF(K(IP,1).EQ.5) K(IP,1)=15
68745 IF(K(IP,1).LE.10) K(IP,1)=11
68746 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
68754 C*********************************************************************
68757 C...Handles flavour production in the decay of unstable particles
68758 C...and small string clusters.
68760 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
68762 C...Double precision and integer declarations.
68763 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68764 IMPLICIT INTEGER(I-N)
68765 INTEGER PYK,PYCHGE,PYCOMP
68767 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68768 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68769 SAVE /PYDAT1/,/PYDAT2/
68772 C.. Call PYKFDI directly if no popcorn option is on
68773 IF(MSTJ(12).LT.2) THEN
68774 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
68781 IF(KFL1.EQ.0) RETURN
68786 NMAX=MIN(MSTU(125),10)
68788 C.. Identify rank 0 cluster qq
68790 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
68793 C.. Join jets: Fails if store not empty
68794 IF(MSTU(121).GT.0) THEN
68798 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
68799 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
68800 C.. Pick popcorn meson from store, return same qq, decrease store
68801 KF=MSTU(NSTO+MSTU(121))
68803 MSTU(121)=MSTU(121)-1
68805 C.. Generate new flavour. Then done if no diquark is generated
68806 100 CALL PYKFDI(KFL1,0,KFL3,KF)
68807 IF(MSTU(121).EQ.-1) GOTO 100
68809 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
68811 C.. Simple case if no dynamical popcorn suppressions are considered
68812 IF(MSTJ(12).LT.4) THEN
68813 IF(MSTU(121).EQ.0) RETURN
68816 CALL PYKFDI(KFPREV,0,KFL3,KFM)
68817 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
68818 IF(IABS(KFL3).LE.10)THEN
68825 C test output qq against fake Gamma, then return if no popcorn.
68828 CALL PYZDIS(1,2103,5D0,Z)
68830 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
68835 IF(MSTU(121).EQ.0) RETURN
68837 C..Set store size memory. Pick fake dynamical variables of qq.
68839 CALL PYPTDI(1,PX3,PY3)
68845 C.. Pick next popcorn meson, test with fake dynamical variables
68849 CALL PYKFDI(KFPREV,0,KFL3,KFM)
68850 IF(MSTU(121).EQ.-1) GOTO 100
68851 CALL PYPTDI(KFL3,PX3,PY3)
68852 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
68853 CALL PYZDIS(KFPREV,KFL3,PM,Z)
68860 IF(MSTJ(12).GT.4)THEN
68861 POPMN=SQRT((1D0-X)*(G/X-GB))
68862 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68863 PTST=EXP((POPM-POPMN)*PARF(193))
68868 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
68871 IF(RTST.GT.PTST*GTST)THEN
68873 IF(RTST.GT.PTST) MSTU(121)=-1
68878 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
68879 IF(MSTU(121).GT.0) GOTO 110
68881 C.. Test accepted system size. If OK set global popcorn size variable.
68882 IF(NMES.GT.NMAX)THEN
68893 C********************************************************************
68896 C...Generates a new flavour pair and combines off a hadron
68898 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
68900 C...Double precision and integer declarations.
68901 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68902 IMPLICIT INTEGER(I-N)
68903 INTEGER PYK,PYCHGE,PYCOMP
68905 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68906 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68907 SAVE /PYDAT1/,/PYDAT2/
68911 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
68913 C...Default flavour values. Input consistency checks.
68918 IF(KF1A.EQ.0) RETURN
68920 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
68921 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
68922 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
68925 C...Check if tabulated flavour probabilities are to be used.
68926 IF(MSTJ(15).EQ.1) THEN
68927 IF(MSTJ(12).GE.5) CALL PYERRM(29,
68928 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
68929 & ' together with MSTJ(12)>=5 modification')
68931 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
68932 KFL1A=MOD(KF1A/1000,10)
68933 KFL1B=MOD(KF1A/100,10)
68935 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
68936 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
68937 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
68938 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
68942 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
68943 KFL2A=MOD(KF2A/1000,10)
68944 KFL2B=MOD(KF2A/100,10)
68946 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
68947 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
68948 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
68950 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
68953 C.. Recognize rank 0 diquark case
68955 KFDIQ=MAX(KF1A,KF2A)
68956 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
68958 C.. Join two flavours to meson or baryon. Test for popcorn.
68961 IF(KFDIQ.GT.10) THEN
68962 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
68963 & CALL PYNMES(KFDIQ)
68964 IF(MSTU(121).NE.0) THEN
68975 C.. Separate incoming flavours, curtain flavour consistency check
68981 KFL1A=MOD(KF1A/1000,10)
68982 KFL1B=MOD(KF1A/100,10)
68985 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
68986 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
68987 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
68989 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
68993 KFQOLD=KFL1A+KFL1B-KFQPOP
68996 C...Meson/baryon choice. Set number of mesons if starting a popcorn
68999 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
69000 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
69004 ELSEIF(KF1A.GT.10)THEN
69006 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
69007 IF(MSTU(121).GT.0) MBARY=-1
69010 C..x->H+q: Choose single vertex quark. Jump to form hadron.
69011 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
69012 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
69013 KFL3=ISIGN(KFQVER,-KFIN)
69017 C..x->H+qq: (IDW=proper PARF position for diquark weights)
69020 IF(MSTU(121).EQ.0) IDW=150
69022 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
69023 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
69024 C.. Shift to s-curtain parameters if needed
69025 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
69026 PARF(194)=PARF(138)*PARF(139)
69027 PARF(193)=PARJ(8)+PARJ(9)
69031 C.. x->H+qq: Get vertex quark
69032 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
69034 MSTU(121)=MSTU(121)-1
69035 IF(IDW.EQ.170) THEN
69036 IF(MSTU(121).EQ.0)THEN
69037 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
69039 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
69042 IF(MSTU(121).EQ.0)THEN
69043 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
69045 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
69051 RMES=PYR(0)*PARF(194)
69053 RMES=RMES-PARF(IPOS+IMES)
69054 IF(IMES.EQ.30) THEN
69059 IF(RMES.GT.0D0) GOTO 120
69062 IF(KMUL.EQ.2) KFJ=10003
69063 IF(KMUL.EQ.3) KFJ=10001
69064 IF(KMUL.EQ.4) KFJ=20003
69065 IF(KMUL.EQ.5) KFJ=5
69067 KFQVER=MOD(IMES,5)+1
69068 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
69069 IF(KFQVER.GT.3)THEN
69074 IF(MBARY.EQ.-1) IDW=170
69076 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
69077 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
69078 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
69079 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
69081 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
69085 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
69087 IF(KFQPOP.NE.KFQVER)THEN
69089 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
69090 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
69091 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
69093 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
69095 KFL3=ISIGN(KFDIQ,KFIN)
69097 C..x->M+y: flavour for meson.
69098 130 IF(MBARY.LE.0)THEN
69099 KFLA=MAX(KFQOLD,KFQVER)
69100 KFLB=MIN(KFQOLD,KFQVER)
69102 IF(KFLA.NE.KFQOLD) KFS=-KFS
69103 C... Form meson, with spin and flavour mixing for diagonal states.
69104 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
69105 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
69106 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
69109 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
69110 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
69111 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
69112 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
69113 IF(PYR(0).LT.PARJ(14)) KMUL=2
69114 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
69116 IF(RMUL.LT.PARJ(15)) KMUL=3
69117 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
69118 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
69121 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
69122 IF(KMUL.EQ.5) KFLS=5
69123 IF(KFLA.NE.KFLB)THEN
69124 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
69127 IMIX=2*KFLA+10*KMUL
69128 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
69129 & INT(RMIX+PARF(IMIX)))+KFLS
69130 IF(KFLA.GE.4) KF=110*KFLA+KFLS
69132 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
69133 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
69135 C..Optional extra suppression of eta and eta'.
69136 C..Allow shift to qq->B+q in old version (set IRANK to 0)
69137 IF(KF.EQ.221.OR.KF.EQ.331)THEN
69138 IF(PYR(0).GT.PARJ(25+KF/300))THEN
69139 IF(KF2A.GT.0) GOTO 130
69140 IF(MSTJ(12).LT.4) IRANK=0
69146 C.. x->B+y: Flavour for baryon
69149 IF(KF1A.LE.10) KFLA=KFQOLD
69150 KFLB=MOD(KFDIQ/1000,10)
69151 KFLC=MOD(KFDIQ/100,10)
69152 KFLDS=MOD(KFDIQ,10)
69153 KFLD=MAX(KFLA,KFLB,KFLC)
69154 KFLF=MIN(KFLA,KFLB,KFLC)
69155 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
69157 C... SU(6) factors for formation of baryon.
69161 IF(KFLB.NE.KFLC)THEN
69164 IF(KFLB.GT.2) KDMAX=KDMAX+2
69166 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
69171 SU6MAX=PARF(140+KDMAX)
69174 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
69179 SU6OCT=PARF(60+KBARY)
69180 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
69181 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
69182 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
69184 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
69186 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
69188 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
69189 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
69191 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
69195 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
69198 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
69199 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
69201 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
69203 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
69204 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
69208 C...Use tabulated probabilities to select new flavour and hadron.
69209 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
69212 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
69215 ELSEIF(KTAB2.EQ.0) THEN
69224 DO 150 KT3=KT3L,KT3U
69225 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
69231 DO 170 KT3=KT3L,KT3U
69233 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
69234 IF(RFL.LE.0D0) GOTO 190
69239 C...Reconstruct flavour of produced quark/diquark.
69240 IF(KTAB3.LE.6) THEN
69243 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
69246 IF(KTAB3.GE.8) KFL3A=2
69247 IF(KTAB3.GE.11) KFL3A=3
69248 IF(KTAB3.GE.16) KFL3A=4
69249 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
69250 KFL3=1000*KFL3A+100*KFL3B+1
69251 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
69253 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
69256 C...Reconstruct meson code.
69257 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
69259 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
69260 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
69262 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
69263 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
69264 & 25*KTABS)) KF=330+2*KTABS+1
69265 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
69266 KFLA=MAX(KTAB1,KTAB3)
69267 KFLB=MIN(KTAB1,KTAB3)
69269 IF(KFLA.NE.KF1A) KFS=-KFS
69270 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
69271 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
69273 IF(KFL1A.EQ.KFL3A) THEN
69274 KFLA=MAX(KFL1B,KFL3B)
69275 KFLB=MIN(KFL1B,KFL3B)
69276 IF(KFLA.NE.KFL1B) KFS=-KFS
69277 ELSEIF(KFL1A.EQ.KFL3B) THEN
69281 ELSEIF(KFL1B.EQ.KFL3A) THEN
69284 ELSEIF(KFL1B.EQ.KFL3B) THEN
69285 KFLA=MAX(KFL1A,KFL3A)
69286 KFLB=MIN(KFL1A,KFL3A)
69287 IF(KFLA.NE.KFL1A) KFS=-KFS
69289 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
69292 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
69294 C...Reconstruct baryon code.
69296 IF(KTAB1.GE.7) THEN
69305 KFLD=MAX(KFLA,KFLB,KFLC)
69306 KFLF=MIN(KFLA,KFLB,KFLC)
69307 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
69308 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
69309 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
69312 C...Check that constructed flavour code is an allowed one.
69313 IF(KFL2.NE.0) KFL3=0
69316 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
69324 C*********************************************************************
69327 C...Generates number of popcorn mesons and stores some relevant
69330 SUBROUTINE PYNMES(KFDIQ)
69332 C...Double precision and integer declarations.
69333 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69334 IMPLICIT INTEGER(I-N)
69335 INTEGER PYK,PYCHGE,PYCOMP
69337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69338 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69339 SAVE /PYDAT1/,/PYDAT2/
69342 IF(MSTJ(12).LT.2) RETURN
69344 C..Old version: Get 1 or 0 popcorn mesons
69345 IF(MSTJ(12).LT.5)THEN
69347 IF(KFDIQ.NE.0) THEN
69349 KFA=MOD(KFDIQA/1000,10)
69350 KFB=MOD(KFDIQA/100,10)
69353 IF(KFA.EQ.3) POPWT=PARF(133)
69354 IF(KFB.EQ.3) POPWT=PARF(134)
69355 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
69357 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
69361 C..New version: Store popcorn- or rank 0 diquark parameters
69364 PARF(194)=PARF(139)
69365 IF(KFDIQ.NE.0) THEN
69368 PARF(194)=PARF(140)
69370 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
69371 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
69372 & '(PYNMES:) Neglecting too large popcorn possibility')
69376 C..New version: Get number of popcorn mesons
69379 110 MSTU(121)=MSTU(121)+1
69380 RTST=RTST/PARF(194)
69381 IF(RTST.LT.1D0) GOTO 110
69382 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
69383 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
69387 C***************************************************************
69390 C...Precalculates a set of diquark and popcorn weights.
69394 C...Double precision and integer declarations.
69395 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69396 IMPLICIT INTEGER(I-N)
69397 INTEGER PYK,PYCHGE,PYCOMP
69399 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69400 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69401 SAVE /PYDAT1/,/PYDAT2/
69403 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
69407 C..Diquark indices for dimensional variables
69416 C.. *** SU(6) factors **
69417 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
69419 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
69420 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
69421 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
69424 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
69426 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
69427 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
69429 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
69430 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
69433 C..SU(6)max q q' s,c,b
69434 SU6MUD =MAX(SU6(1) , SU6(8) )
69435 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
69436 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
69437 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
69438 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
69439 SU6M(IUS0)=SU6M(ISU0)
69440 SU6M(ISS1)=SU6M(IUU1)
69441 SU6M(IUS1)=SU6M(ISU1)
69443 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
69445 PARF(142)=SU6M(IUD1)
69446 PARF(143)=SU6M(ISU0)
69447 PARF(144)=SU6M(ISU1)
69448 PARF(145)=SU6M(ISS1)
69450 C..diquark SU(6) survival =
69451 C..sum over quark (quark tunnel weight)*(SU(6)).
69452 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
69453 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
69454 DMB(IUS0)=DMB(ISU0)
69455 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
69456 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
69457 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
69458 DMB(IUS1)=DMB(ISU1)
69459 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
69461 C.. *** Tunneling factors for Diquark production***
69462 C.. T: half a curtain pair = sqrt(curtain pair factor)
69463 IF(MSTJ(12).GE.5) THEN
69465 PMUD1=PYMASS(2103)-PMUD0
69466 PMUS0=PYMASS(3201)-PMUD0
69467 PMUS1=PYMASS(3203)-PMUS0-PMUD0
69468 PMSS1=PYMASS(3303)-PMUS0-PMUD0
69469 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
69470 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
69471 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
69472 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
69473 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
69474 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
69475 QBB(IUD1)=QBB(IUU1)
69477 PAR2M=SQRT(PARJ(2))
69478 PAR3M=SQRT(PARJ(3))
69479 PAR4M=SQRT(PARJ(4))
69480 QBB(ISU0)=PAR2M*PAR3M
69482 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
69484 QBB(ISU1)=PAR4M*QBB(ISU0)
69485 QBB(IUS1)=PAR4M*QBB(IUS0)
69489 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
69490 QBM(ISU0)=QBB(ISU0)
69491 QBM(IUS0)=PARJ(2)*QBB(IUS0)
69492 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
69493 QBM(IUU1)=6D0*QBB(IUU1)
69494 QBM(ISU1)=3D0*QBB(ISU1)
69495 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
69496 QBM(IUD1)=3D0*QBB(IUD1)
69498 C.. Combine T and tau to diquark weight for q-> B+B+..
69500 QBB(I)=QBB(I)*QBM(I)
69503 IF(MSTJ(12).GE.5)THEN
69504 C..New version: tau for rank 0 diquark.
69505 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
69506 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
69507 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
69508 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
69509 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
69510 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
69511 DMB(7+IUD1)=DMB(7+IUU1)/2D0
69513 C..New version: curtain flavour ratios.
69514 C.. s/u for q->B+M+...
69515 C.. s/u for rank 0 diquark: su -> ...M+B+...
69516 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
69517 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
69518 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
69519 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
69520 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
69521 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
69522 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
69524 C..Old version: reset unused rank 0 diquark weights and
69525 C.. unused diquark SU(6) survival weights
69527 IF(MSTJ(12).LT.3) DMB(I)=1D0
69531 C..Old version: Shuffle PARJ(7) into tau
69532 QBM(IUS0)=QBM(IUS0)*PARJ(7)
69533 QBM(ISS1)=QBM(ISS1)*PARJ(7)
69534 QBM(IUS1)=QBM(IUS1)*PARJ(7)
69536 C..Old version: curtain flavour ratios.
69537 C.. s/u for q->B+M+...
69538 C.. s/u for rank 0 diquark: su -> ...M+B+...
69539 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
69540 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
69541 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
69542 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
69543 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
69546 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
69547 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
69549 DMB(7+I)=DMB(7+I)*DMB(I)
69550 DMB(I)=DMB(I)*QBM(I)
69551 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
69552 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
69555 C.. *** Popcorn factors ***
69557 IF(MSTJ(12).LT.5)THEN
69558 C.. Old version: Resulting popcorn weights.
69560 WS=PARF(135)*PARF(138)
69562 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
69564 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
69565 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
69566 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
69567 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
69568 & (1D0+QBB(IUD1)+QBB(IUU1)+
69569 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
69571 C..New version: Store weights for popcorn mesons,
69572 C..get prel. popcorn weights.
69573 DO 150 IPOS=201,1400
69582 IF(MR.EQ.7) PARF(193)=PARJ(10)
69583 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
69584 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
69585 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
69587 IF(NMES.EQ.1) SQWT=PARJ(2)
69589 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
69590 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
69591 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
69593 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
69594 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
69597 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
69599 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
69600 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
69606 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
69607 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
69608 IF(PJWT.LE.0D0) GOTO 190
69609 IF(PJWT.GT.1D0) PJWT=1D0
69611 IMIX=2*KFQOLD+10*KMUL
69613 IF(KMUL.EQ.2) KFJ=10003
69614 IF(KMUL.EQ.3) KFJ=10001
69615 IF(KMUL.EQ.4) KFJ=20003
69616 IF(KMUL.EQ.5) KFJ=5
69618 KFLA=MAX(KFQOLD,KFQVER)
69619 KFLB=MIN(KFQOLD,KFQVER)
69620 SWT=PARJ(11+KFLA/3+KFLA/4)
69621 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
69623 QWT=SQWT/(2D0+SQWT)
69624 IF(KFQVER.LT.3)THEN
69625 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
69626 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
69628 IF(KFQVER.NE.KFQOLD)THEN
69630 KFM=100*KFLA+10*KFLB+KFJ
69631 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
69632 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
69633 WTTOT=WTTOT+PARF(IPOS+IMES)
69636 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
69637 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
69638 IF(ID.EQ.5) DWT=PARF(IMIX)
69640 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
69641 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
69642 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
69643 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
69644 PARF(IPOS+5*KMUL+ID)=
69645 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
69647 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
69653 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
69655 IF(MR.EQ.7) PARF(140)=
69656 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
69657 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
69658 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
69664 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
69669 C..Recombine diquark weights to flavour and spin ratios
69670 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
69671 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
69672 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
69673 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
69674 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
69675 PARF(155)=QBB(ISU1)/QBB(ISU0)
69676 PARF(156)=QBB(IUS1)/QBB(IUS0)
69677 PARF(157)=QBB(IUD1)
69679 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
69680 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
69681 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
69682 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
69683 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
69684 PARF(165)=QBM(ISU1)/QBM(ISU0)
69685 PARF(166)=QBM(IUS1)/QBM(IUS0)
69686 PARF(167)=QBM(IUD1)
69688 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
69689 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
69690 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
69691 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
69692 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
69693 PARF(175)=DMB(ISU1)/DMB(ISU0)
69694 PARF(176)=DMB(IUS1)/DMB(IUS0)
69695 PARF(177)=DMB(IUD1)
69697 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
69698 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
69699 PARF(187)=DMB(7+IUD1)
69705 C*********************************************************************
69708 C...Generates transverse momentum according to a Gaussian.
69710 SUBROUTINE PYPTDI(KFL,PX,PY)
69712 C...Double precision and integer declarations.
69713 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69714 IMPLICIT INTEGER(I-N)
69715 INTEGER PYK,PYCHGE,PYCOMP
69717 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69720 C...Generate p_T and azimuthal angle, gives p_x and p_y.
69722 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
69723 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
69724 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
69725 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
69733 C*********************************************************************
69736 C...Generates the longitudinal splitting variable z.
69738 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
69740 C...Double precision and integer declarations.
69741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69742 IMPLICIT INTEGER(I-N)
69743 INTEGER PYK,PYCHGE,PYCOMP
69745 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69746 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69747 SAVE /PYDAT1/,/PYDAT2/
69749 C...Check if heavy flavour fragmentation.
69753 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
69755 C...Lund symmetric scaling function: determine parameters of shape.
69756 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
69757 &MSTJ(11).GE.4) THEN
69759 IF(MSTJ(91).EQ.1) FA=PARJ(43)
69760 IF(KFLB.GE.10) FA=FA+PARJ(45)
69762 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
69765 IF(KFLA.GE.10) FC=FC-PARJ(45)
69766 IF(KFLB.GE.10) FC=FC+PARJ(45)
69767 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
69769 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
69770 FC=FC+FRED*FBB*PARF(100+KFLH)**2
69773 IF(ABS(FC-1D0).GT.0.01D0) MC=2
69775 C...Determine position of maximum. Special cases for a = 0 or a = c.
69776 IF(FA.LT.0.02D0) THEN
69779 IF(FC.GT.FB) ZMAX=FB/FC
69780 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
69785 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
69786 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
69789 C...Subdivide z range if distribution very peaked near endpoint.
69791 IF(ZMAX.LT.0.1D0) THEN
69797 ZDIVC=ZDIV**(1D0-FC)
69798 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
69800 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
69802 FSCB=SQRT(4D0+(FC/FB)**2)
69803 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
69804 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
69805 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
69806 FINT=1D0+FB*(1D0-ZDIV)
69809 C...Choice of z, preweighted for peaks at low or high z.
69813 IF(FINT*PYR(0).LE.1D0) THEN
69815 ELSEIF(MC.EQ.1) THEN
69819 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
69822 ELSEIF(MMAX.EQ.3) THEN
69823 IF(FINT*PYR(0).LE.1D0) THEN
69825 FPRE=EXP(FB*(Z-ZDIV))
69827 Z=ZDIV+Z*(1D0-ZDIV)
69831 C...Weighting according to correct formula.
69832 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
69833 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
69834 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
69835 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
69836 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
69838 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
69840 FC=PARJ(50+MAX(1,KFLH))
69841 IF(MSTJ(91).EQ.1) FC=PARJ(59)
69843 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
69844 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
69845 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
69846 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
69849 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
69850 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
69857 C*********************************************************************
69860 C...Generates timelike parton showers from given partons.
69862 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
69864 C...Double precision and integer declarations.
69865 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69866 IMPLICIT INTEGER(I-N)
69867 INTEGER PYK,PYCHGE,PYCOMP
69868 C...Parameter statement to help give large particle numbers.
69869 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69870 &KEXCIT=4000000,KDIMEN=5000000)
69871 PARAMETER (MAXNUR=1000)
69873 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69874 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69875 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69876 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69877 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69878 COMMON/PYINT1/MINT(400),VINT(400)
69879 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
69881 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
69882 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
69883 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
69884 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
69887 C...Check that QMAX not too low.
69888 IF(MSTJ(41).LE.0) THEN
69890 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
69891 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
69893 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
69897 C...Store positions of shower initiating partons.
69899 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
69902 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
69907 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
69908 & .AND.IP2.GE.-80) THEN
69913 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
69921 & '(PYSHOW:) failed to reconstruct showering system')
69922 IF(MSTU(21).GE.1) RETURN
69925 C...Send off to PYPTFS for pT-ordered evolution if requested,
69926 C...if at least 2 partons, and without predefined shower branchings.
69927 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
69932 PTPART(II)=0.5D0*QMAX
69934 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
69938 C...Initialization of cutoff masses etc.
69946 PMTH(1,21)=PYMASS(21)
69947 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
69948 PMTH(3,21)=2D0*PMTH(2,21)
69949 PMTH(4,21)=PMTH(3,21)
69950 PMTH(5,21)=PMTH(3,21)
69951 PMTH(1,22)=PYMASS(22)
69952 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
69953 PMTH(3,22)=2D0*PMTH(2,22)
69954 PMTH(4,22)=PMTH(3,22)
69955 PMTH(5,22)=PMTH(3,22)
69957 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
69958 PMQT1E=MIN(PMQTH1,PARJ(90))
69960 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
69961 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
69964 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
69966 PMTH(1,IFL)=PYMASS(IFL)
69967 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
69968 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
69969 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
69970 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
69973 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
69974 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
69975 PMTH(1,IFL)=PYMASS(IFL)
69976 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
69977 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
69978 PMTH(4,IFL)=PMTH(3,IFL)
69979 PMTH(5,IFL)=PMTH(3,IFL)
69981 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
69983 ALFM=LOG(PT2MIN/ALAMS)
69985 C...Check on phase space available for emission.
69993 KFLA(I)=IABS(K(IPA(I),2))
69995 C...Special cutoff masses for initial partons (may be a heavy quark,
69996 C...squark, ..., and need not be on the mass shell).
69998 IF(NPA.LE.1) IREF(I)=IR
69999 IF(NPA.GE.2) IREF(I+1)=IR
70003 IF(KFLA(I).LE.8) THEN
70005 IF(MSTJ(41).GE.2) ISCHG(IR)=1
70006 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
70007 & KFLA(I).EQ.17) THEN
70008 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
70009 ELSEIF(KFLA(I).EQ.21) THEN
70011 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
70012 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
70014 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
70017 C...same for QQ~[3S18]
70018 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
70019 & KFLA(I).EQ.9900553)) THEN
70024 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
70025 C...(only intended for studying the effects of switching such rad on/off)
70026 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
70031 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
70033 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
70034 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
70035 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
70036 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
70037 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
70038 ELSEIF(ISCOL(IR).EQ.1) THEN
70039 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
70040 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
70041 PMTH(4,IR)=PMTH(3,IR)
70042 PMTH(5,IR)=PMTH(3,IR)
70043 ELSEIF(ISCHG(IR).EQ.1) THEN
70044 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
70045 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
70046 PMTH(4,IR)=PMTH(3,IR)
70047 PMTH(5,IR)=PMTH(3,IR)
70049 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
70051 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
70053 PS(J)=PS(J)+P(IPA(I),J)
70056 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
70057 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
70058 IF(NPA.EQ.1) PS(5)=PS(4)
70059 IF(PS(5).LE.PM+PMQT1E) RETURN
70061 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70064 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
70065 KFSRCE=IABS(K(K(IP1,3),2))
70067 IPAR1=MAX(1,K(IP1,3))
70068 IPAR2=MAX(1,K(IP2,3))
70069 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
70070 & KFSRCE=IABS(K(K(IPAR1,3),2))
70073 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70074 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70075 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70076 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70077 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70078 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70079 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70080 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70082 C...Identify two primary showerers.
70084 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
70085 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
70086 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
70087 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
70088 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
70089 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
70090 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
70091 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
70093 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
70094 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
70095 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
70096 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
70097 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
70098 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
70099 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
70100 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
70102 C...Order of showerers. Presence of gluino.
70103 ITYPMN=MIN(ITYPE1,ITYPE2)
70104 ITYPMX=MAX(ITYPE1,ITYPE2)
70106 IF(ITYPE1.GT.ITYPE2) IORD=2
70108 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70110 C...Check if 3-jet matrix elements to be used.
70113 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
70114 IF(MSTJ(38).NE.0) THEN
70118 ELSEIF(MSTJ(47).GE.6) THEN
70124 C...Vector/axial vector -> q + qbar; q -> q + V.
70125 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70126 & ITYPES.EQ.3)) THEN
70128 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70130 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70131 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
70132 C...gamma*/Z0: assume e+e- initial state if unknown.
70134 IF(KFSRCE.EQ.23) THEN
70135 IANNFL=K(K(IP1,3),3)
70136 IF(IANNFL.NE.0) THEN
70137 KANNFL=IABS(K(IANNFL,2))
70138 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70141 AI=SIGN(1D0,EI+0.1D0)
70142 VI=AI-4D0*EI*PARU(102)
70143 EF=KCHG(KFLA(1),1)/3D0
70144 AF=SIGN(1D0,EF+0.1D0)
70145 VF=AF-4D0*EF*PARU(102)
70146 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70149 SQWZ=PS(5)*PMAS(23,2)
70150 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70151 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70152 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70153 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70155 ALPHA=VECT/(VECT+AXIV)
70156 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70159 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70160 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70162 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70163 & ITYPES.EQ.1)) THEN
70166 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70167 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70169 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70171 ELSEIF(KFSRCE.EQ.36) THEN
70174 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70175 & ITYPES.EQ.1)) THEN
70178 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70179 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70180 & ITYPES.EQ.3)) THEN
70182 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70183 & ITYPES.EQ.2)) THEN
70185 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70187 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70188 & ITYPES.EQ.2)) THEN
70191 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70192 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70193 & ITYPES.EQ.5)) THEN
70195 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70196 & ITYPES.EQ.2)) THEN
70198 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70199 & ITYPES.EQ.1)) THEN
70202 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70203 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70205 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70206 & ITYPES.EQ.2)) THEN
70208 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70209 & ITYPES.EQ.1)) THEN
70212 C...g -> ~g + ~g (eikonal approximation).
70213 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70216 M3JC=5*ICLASS+ICOMBI
70220 C...Find if interference with initial state partons.
70222 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
70223 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
70224 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
70229 KCA=PYCOMP(KFLA(I))
70230 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
70232 IF(KCII(I).NE.0) THEN
70234 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
70235 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
70236 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
70238 IIIS(I,NIIS(I))=ICSI
70243 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
70246 C...Boost interfering initial partons to rest frame
70247 C...and reconstruct their polar and azimuthal angles.
70251 K(N+I,J)=K(IPA(I),J)
70252 P(N+I,J)=P(IPA(I),J)
70256 DO 230 I=3,2+NIIS(1)
70258 K(N+I,J)=K(IIIS(1,I-2),J)
70259 P(N+I,J)=P(IIIS(1,I-2),J)
70263 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
70265 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
70266 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
70270 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
70271 & -PS(2)/PS(4),-PS(3)/PS(4))
70272 PHI=PYANGL(P(N+1,1),P(N+1,2))
70273 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
70274 THE=PYANGL(P(N+1,3),P(N+1,1))
70275 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
70276 DO 260 I=3,2+NIIS(1)
70277 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
70278 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
70280 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
70281 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
70282 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
70283 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
70287 C...Boost 3 or more partons to their rest frame.
70288 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
70289 &-PS(2)/PS(4),-PS(3)/PS(4))
70291 C...Define imagined single initiator of shower for parton system.
70293 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
70294 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
70295 IF(MSTU(21).GE.1) RETURN
70314 C...Loop over partons that may branch.
70317 IF(NPA.EQ.1) IM=NS-1
70320 IF(IM.GT.N) GOTO 600
70323 IF(KSH(IR).EQ.0) GOTO 290
70324 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
70329 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
70330 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
70331 IF(MSTU(21).GE.1) RETURN
70334 C...Position of aunt (sister to branching parton).
70335 C...Origin and flavour of daughters.
70338 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
70339 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
70351 K(N+I,2)=K(IPA(I),2)
70353 ELSEIF(KFLM.NE.21) THEN
70356 IREF(N+1-NS)=IREF(IM-NS)
70357 IREF(N+2-NS)=IABS(K(N+2,2))
70358 ELSEIF(K(IM,5).EQ.21) THEN
70366 IREF(N+1-NS)=IABS(K(N+1,2))
70367 IREF(N+2-NS)=IABS(K(N+2,2))
70370 C...Reset flags on daughters and tries made.
70375 KFLD(IP)=IABS(K(N+IP,2))
70376 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
70380 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
70384 C...Maximum virtuality of daughters.
70387 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
70388 P(N+I,5)=MIN(QMAX,PS(5))
70390 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
70391 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
70394 IF(MSTJ(43).LE.2) PEM=V(IM,2)
70395 IF(MSTJ(43).GE.3) PEM=P(IM,4)
70396 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
70397 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
70398 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
70402 IF(ISI(I).EQ.1) THEN
70404 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
70406 V(N+I,5)=P(N+I,5)**2
70409 C...Choose one of the daughters for evolution.
70411 IF(NEP.EQ.1) INUM=1
70413 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
70416 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
70418 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
70424 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
70425 RPM=P(N+I,5)/PMSD(I)
70427 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
70435 C...Cancel choice of predetermined daughter already treated.
70438 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
70439 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
70440 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
70441 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
70442 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
70445 C...Store information on choice of evolving daughter.
70449 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
70452 KFL(I)=IABS(K(IEP(I),2))
70454 ITRY(INUM)=ITRY(INUM)+1
70455 IF(ITRY(INUM).GT.200) THEN
70456 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
70457 IF(MSTU(21).GE.1) RETURN
70461 IF(KSH(IR).EQ.0) GOTO 450
70462 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
70464 C...Check if evolution already predetermined for daughter.
70466 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
70467 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
70468 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
70469 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
70470 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
70472 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
70474 IF(IPSPD.NE.0) ISSET(INUM)=1
70477 C...Select side for interference with initial state partons.
70478 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
70481 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
70483 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
70484 IF(PYR(0).GT.0.5D0) ISII(III)=1
70485 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
70487 IF(PYR(0).GT.0.5D0) ISII(III)=2
70491 C...Calculate allowed z range.
70494 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
70497 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
70498 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
70500 IF(MOD(MSTJ(43),2).EQ.1) THEN
70502 ZCE=PMTH(2,22)/PMED
70503 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
70505 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
70506 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
70508 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
70509 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
70510 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
70513 ZCE=MIN(ZCE,0.49991D0)
70514 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
70515 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
70516 P(IEP(1),5)=PMTH(1,IR)
70517 V(IEP(1),5)=P(IEP(1),5)**2
70521 C...Integral of Altarelli-Parisi z kernel for QCD.
70522 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
70523 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
70524 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
70526 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
70527 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
70528 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
70529 FBR=6D0*LOG((1D0-ZC)/ZC)
70531 ELSEIF(MSTJ(49).EQ.0) THEN
70532 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
70533 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
70535 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
70536 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
70537 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
70538 ELSEIF(MSTJ(49).EQ.1) THEN
70539 FBR=(1D0-2D0*ZC)/3D0
70540 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
70542 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
70543 ELSEIF(KFL(1).EQ.21) THEN
70544 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
70546 FBR=2D0*LOG((1D0-ZC)/ZC)
70549 C...Reset QCD probability for colourless.
70550 IF(ISCOL(IR).EQ.0) FBR=0D0
70552 C...Integral of Altarelli-Parisi kernel for photon emission.
70554 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
70555 IF(KFL(1).LE.18) THEN
70556 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
70558 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
70561 C...Inner veto algorithm starts. Find maximum mass for evolution.
70562 410 PMS=V(IEP(1),5)
70567 IRI=IREF(IEP(I)-NS)
70568 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
70571 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
70574 C...Select mass for daughter in QCD evolution.
70576 DO 430 IFF=4,MSTJ(45)
70577 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
70579 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
70580 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
70581 C...Already predetermined choice.
70582 IF(IPSPD.NE.0) THEN
70583 PMSQCD=P(IPSPD,5)**2
70584 ELSEIF(FBR.LT.1D-3) THEN
70586 ELSEIF(MSTJ(44).LE.0) THEN
70587 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
70588 ELSEIF(MSTJ(44).EQ.1) THEN
70589 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
70591 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
70593 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
70594 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
70595 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
70599 C...Select mass for daughter in QED evolution.
70600 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
70601 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
70602 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
70603 IF(FBRE.LT.1D-3) THEN
70606 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
70607 & (PARU(101)*FBRE)))
70609 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
70610 PMSQED=PMSQED+PMTH(1,IR)**2
70611 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
70613 IF(PMSQED.GT.PMSQCD) THEN
70619 C...Check whether daughter mass below cutoff.
70620 P(IEP(1),5)=SQRT(V(IEP(1),5))
70621 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
70622 P(IEP(1),5)=PMTH(1,IR)
70623 V(IEP(1),5)=P(IEP(1),5)**2
70627 C...Already predetermined choice of z, and flavour in g -> qqbar.
70628 IF(IPSPD.NE.0) THEN
70631 PMSGD1=P(IPSGD1,5)**2
70632 PMSGD2=P(IPSGD2,5)**2
70633 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
70634 & 4D0*PMSGD1*PMSGD2))
70635 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
70636 & PMSGD1+PMSGD2)/ALAMPS
70637 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
70638 IF(KFL(1).NE.21) THEN
70641 K(IEP(1),5)=IABS(K(IPSGD1,2))
70644 C...Select z value of branching: q -> qgamma.
70645 ELSEIF(MCE.EQ.2) THEN
70646 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
70647 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
70651 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
70652 ELSEIF(MSTJ(49).EQ.0.AND.
70653 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
70654 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70655 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
70656 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
70657 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
70661 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
70662 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
70663 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70664 C...Only do z weighting when no ME correction afterwards.
70665 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
70667 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
70668 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70669 IF(PYR(0).GT.0.5D0) Z=1D0-Z
70670 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
70672 ELSEIF(MSTJ(49).NE.1) THEN
70674 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
70675 KFLB=1+INT(MSTJ(45)*PYR(0))
70676 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
70677 IF(PMQ.GE.1D0) GOTO 410
70678 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
70679 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
70680 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
70681 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
70682 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
70684 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
70688 C...Ditto for scalar gluon model.
70689 ELSEIF(KFL(1).NE.21) THEN
70690 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
70692 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
70693 Z=ZC+(1D0-2D0*ZC)*PYR(0)
70696 Z=ZC+(1D0-2D0*ZC)*PYR(0)
70697 KFLB=1+INT(MSTJ(45)*PYR(0))
70698 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
70699 IF(PMQ.GE.1D0) GOTO 410
70703 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
70704 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
70705 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
70706 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
70707 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
70709 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
70710 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
70711 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
70712 IF(PT2APP.LT.PT2MIN) GOTO 410
70713 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
70717 C...Check if z consistent with chosen m.
70718 IF(KFL(1).EQ.21) THEN
70719 IRGD1=IABS(K(IEP(1),5))
70723 IRGD2=IABS(K(IEP(1),5))
70727 ELSEIF(NEP.GE.3) THEN
70729 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
70730 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
70732 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
70733 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
70735 IF(MOD(MSTJ(43),2).EQ.1) THEN
70736 PMQTH3=0.5D0*PARJ(82)
70737 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
70738 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
70739 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
70740 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
70741 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
70745 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
70748 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
70749 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
70750 ELSEIF(IPSPD.NE.0) THEN
70754 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
70756 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
70758 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
70760 C...Width suppression for q -> q + g.
70761 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
70763 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
70767 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
70768 IF(MSTJ(40).EQ.1) THEN
70769 IF(CHI.LT.PYR(0)) GOTO 410
70770 ELSEIF(MSTJ(40).EQ.2) THEN
70771 IF(1D0-CHI.LT.PYR(0)) GOTO 410
70775 C...Three-jet matrix element correction.
70780 C...QED matrix elements: only for massless case so far.
70781 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
70782 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
70783 X2=1D0-V(IEP(1),5)/V(NS+1,5)
70784 X3=(1D0-X1)+(1D0-X2)
70786 KI2=K(IPA(3-INUM),2)
70787 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
70788 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
70789 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
70790 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
70791 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70792 ELSEIF(MCE.EQ.2) THEN
70794 C...QCD matrix elements, including mass effects.
70795 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
70799 IF(IR.GE.31.AND.IGM.EQ.0) THEN
70800 C...QCD ME: original parton, first branching.
70801 PM2ME=PMTH(1,63-IR)
70803 ELSEIF(IR.GE.31) THEN
70804 C...QCD ME: original parton, subsequent branchings.
70805 PM2ME=PMTH(1,63-IR)
70806 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
70807 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70808 ELSEIF(K(IM,2).EQ.21) THEN
70809 C...QCD ME: secondary partons, first branching.
70812 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
70813 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
70814 & 4D0*PS1ME*PM2ME**2))
70815 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
70817 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70820 C...QCD ME: secondary partons, subsequent branchings.
70822 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
70823 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70826 C...Construct ME variables.
70829 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
70830 X2=1D0+R2ME**2-PS1ME/ECMME**2
70831 C...Call ME, with right order important for two inequivalent showerers.
70832 IF(IR.EQ.IORD+30) THEN
70833 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
70835 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
70837 C...Split up total ME when two radiating partons.
70839 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
70840 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
70841 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
70842 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
70843 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
70844 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70845 & MAX(1D-10,2D0-X1-X2)
70846 C...Evaluate shower rate to be compared with.
70847 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
70848 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70849 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
70850 ELSEIF(MSTJ(49).NE.1) THEN
70852 C...Toy model scalar theory matrix elements; no mass effects.
70854 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
70855 X2=1D0-V(IEP(1),5)/V(NS+1,5)
70856 X3=(1D0-X1)+(1D0-X2)
70857 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
70859 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
70863 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
70866 C...Impose angular ordering by rejection of nonordered emission.
70867 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
70868 PEMAO=V(IM,1)*P(IM,4)
70869 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
70870 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
70872 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
70873 & .OR.MSTJ(42).EQ.7)) THEN
70875 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
70876 & .OR.MSTJ(42).EQ.6)) THEN
70878 PMDAO=PMTH(2,K(IEP(1),5))
70879 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
70882 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
70883 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
70884 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
70888 440 IF(K(IAOM,5).EQ.22) THEN
70890 IF(K(IAOM,3).LE.NS) MAOM=0
70891 IF(MAOM.EQ.1) GOTO 440
70893 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
70894 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
70895 IF(THE2ID.LT.THE2IM) GOTO 410
70899 C...Impose user-defined maximum angle at first branching.
70900 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
70901 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
70902 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
70903 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
70904 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
70905 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
70906 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
70907 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
70908 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
70909 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
70913 C...Impose angular constraint in first branching from interference
70914 C...with initial state partons.
70915 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
70916 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
70917 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
70918 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
70919 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
70920 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
70924 C...End of inner veto algorithm. Check if only one leg evolved so far.
70928 IF(NEP.EQ.1) GOTO 490
70929 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
70932 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
70933 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
70937 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
70941 PMSUM=PMSUM+P(N+I,5)
70943 IF(PMSUM.GE.PS(5)) GOTO 350
70944 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
70947 IF(KSH(IRDA).EQ.0) GOTO 480
70948 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
70949 IF(IRDA.EQ.21) THEN
70950 IRGD1=IABS(K(I1,5))
70954 IRGD2=IABS(K(I1,5))
70957 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
70958 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
70960 IF(I1.EQ.N+1) ZM=V(IM,1)
70961 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
70962 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
70963 & 4D0*V(N+1,5)*V(N+2,5))
70964 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
70967 IF(MOD(MSTJ(43),2).EQ.1) THEN
70968 PMQTH3=0.5D0*PARJ(82)
70969 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
70970 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
70971 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
70972 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
70973 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
70977 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
70980 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
70981 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
70985 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
70986 & ISSET(1).EQ.0) THEN
70988 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
70989 & ISSET(2).EQ.0) THEN
70993 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
70995 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
70997 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
71000 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
71001 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
71002 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
71003 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
71004 IF(ISL(1).EQ.1) ISL(2)=0
71005 IF(ISL(1).EQ.0) ISLM=1
71006 IF(ISL(2).EQ.0) ISLM=2
71008 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
71013 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
71014 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
71015 PMQ1=V(N+1,5)/V(IM,5)
71016 PMQ2=V(N+2,5)/V(IM,5)
71017 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
71022 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
71026 C...Accepted branch. Construct four-momentum for initial partons.
71032 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
71034 P(N+1,4)=P(IPA(1),4)
71036 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
71037 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
71040 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
71045 P(N+2,4)=P(IM,5)-PED1
71048 ELSEIF(NEP.GE.3) THEN
71049 C...Rescale all momenta for energy conservation.
71055 P(N+I,J)=P(IPA(I),J)
71058 PQS=PQS+P(N+I,5)**2/P(N+I,4)
71061 FAC=(PS(5)-PQS)/(PES-PQS)
71066 P(N+I,J)=FAC*P(N+I,J)
71068 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)
71071 PQS=PQS+P(N+I,5)**2/P(N+I,4)
71073 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
71075 C...Construct transverse momentum for ordinary branching in shower.
71079 550 LOOPPT=LOOPPT+1
71080 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
71081 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
71082 IF(PZM.LE.0D0) THEN
71084 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71085 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71086 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
71087 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
71088 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
71089 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
71091 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
71093 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
71096 ELSEIF(PTS.LT.0D0) THEN
71099 PT=SQRT(MAX(0D0,PTS))
71101 C...Global statistics.
71102 MINT(353)=MINT(353)+1
71103 VINT(353)=VINT(353)+PT
71104 IF (MINT(353).EQ.1) VINT(358)=PT
71106 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
71108 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
71109 & .AND.IAU.NE.0) THEN
71110 IF(K(IGM,3).NE.0) MAZIP=1
71112 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
71113 IF(MAZIP.EQ.0) ZAU=0D0
71114 IF(K(IGM,2).NE.21) THEN
71115 HAZIP=2D0*ZAU/(1D0+ZAU**2)
71117 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
71119 IF(K(N+1,2).NE.21) THEN
71120 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
71122 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
71126 C...Find coefficient of azimuthal asymmetry due to soft gluon
71129 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
71130 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
71131 IF(K(IGM,3).NE.0) MAZIC=N+1
71132 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
71133 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
71134 & ZM.GT.0.5D0) MAZIC=N+2
71135 IF(K(IAU,2).EQ.22) MAZIC=0
71137 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
71139 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
71140 IF(MAZIC.EQ.0) ZGM=1D0
71141 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
71142 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
71143 HAZIC=MIN(0.95D0,HAZIC)
71147 C...Construct energies for ordinary branching in shower.
71148 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
71149 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71150 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71151 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
71152 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
71153 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
71154 P(N+1,4)=PEM*V(IM,1)
71156 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
71157 & SQRT(PMLS)*ZM)/V(IM,5)
71160 C...Already predetermined choice of phi angle or not
71162 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
71164 IF(K(IPSPD,4).GT.0) THEN
71166 IF(IM.EQ.NS+2) THEN
71167 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
71169 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
71172 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
71174 IF(K(IPSPD,4).GT.0) THEN
71176 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
71177 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
71178 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
71179 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
71180 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
71181 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
71185 C...Construct momenta for ordinary branching in shower.
71186 P(N+1,1)=PT*COS(PHI)
71187 P(N+1,2)=PT*SIN(PHI)
71188 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71189 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71190 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
71191 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
71192 ELSEIF(PZM.GT.0D0) THEN
71193 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
71194 & 2D0*PEM*P(N+1,4))/PZM
71200 P(N+2,3)=PZM-P(N+1,3)
71201 P(N+2,4)=PEM-P(N+1,4)
71202 IF(MSTJ(43).LE.2) THEN
71203 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
71204 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
71208 C...Rotate and boost daughters.
71210 IF(MSTJ(43).LE.2) THEN
71211 BEX=P(IGM,1)/P(IGM,4)
71212 BEY=P(IGM,2)/P(IGM,4)
71213 BEZ=P(IGM,3)/P(IGM,4)
71214 GA=P(IGM,4)/P(IGM,5)
71215 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
71224 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
71225 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
71226 IF(PTIMB.GT.1D-4) THEN
71227 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
71232 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
71233 & SIN(THE)*COS(PHI)*P(I,3)
71234 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
71235 & SIN(THE)*SIN(PHI)*P(I,3)
71236 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
71238 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
71239 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
71240 P(I,1)=DP(1)+DGABP*BEX
71241 P(I,2)=DP(2)+DGABP*BEY
71242 P(I,3)=DP(3)+DGABP*BEZ
71243 P(I,4)=GA*(DP(4)+DBP)
71247 C...Weight with azimuthal distribution, if required.
71248 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
71254 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
71255 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
71256 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
71258 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
71259 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
71261 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
71262 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
71263 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
71264 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
71265 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
71266 IF(MAZIP.NE.0) THEN
71267 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
71270 IF(MAZIC.NE.0) THEN
71271 IF(MAZIC.EQ.N+2) CAD=-CAD
71272 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
71273 & .LT.PYR(0)) GOTO 560
71278 C...Azimuthal anisotropy due to interference with initial state partons.
71279 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
71280 &K(N+2,2).EQ.21)) THEN
71282 IF(ISII(III).GE.1) THEN
71284 IF(K(N+1,2).NE.21) IAZIID=N+2
71285 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
71286 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
71287 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
71288 IF(III.EQ.2) THEIID=PARU(1)-THEIID
71289 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
71290 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
71291 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
71292 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
71293 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
71294 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
71295 & .LT.PYR(0)) GOTO 560
71299 C...Continue loop over partons that may branch, until none left.
71300 IF(IGM.GE.0) K(IM,1)=14
71303 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
71304 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
71305 IF(MSTU(21).GE.1) N=NS
71306 IF(MSTU(21).GE.1) RETURN
71310 C...Set information on imagined shower initiator.
71311 600 IF(NPA.GE.2) THEN
71315 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
71323 C...Reconstruct string drawing information.
71324 DO 610 I=NS+1+IIM,N
71325 KQ=KCHG(PYCOMP(K(I,2)),2)
71326 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
71328 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
71329 & IABS(K(I,2)).LE.18) THEN
71331 ELSEIF(K(I,1).LE.10) THEN
71332 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
71333 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
71334 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
71335 ID1=MOD(K(I,4),MSTU(5))
71336 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
71337 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
71338 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
71339 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
71340 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
71341 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
71342 K(ID1,4)=K(ID1,4)+MSTU(5)*I
71343 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
71344 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
71345 K(ID2,5)=K(ID2,5)+MSTU(5)*I
71347 ID1=MOD(K(I,4),MSTU(5))
71349 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
71350 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
71351 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
71352 K(ID1,4)=K(ID1,4)+MSTU(5)*I
71353 K(ID1,5)=K(ID1,5)+MSTU(5)*I
71363 C...Transformation from CM frame.
71365 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
71366 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
71368 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
71369 ELSEIF(NPA.EQ.2) THEN
71374 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
71375 & /(1D0+GA)-P(IPA(1),4))
71376 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
71377 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
71378 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
71380 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
71382 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
71385 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
71388 C...Decay vertex of shower.
71395 C...Delete trivial shower, else connect initiators.
71396 IF(N.LE.NS+NPA+IIM) THEN
71401 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
71402 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
71403 K(NS+IIM+IP,3)=IPA(IP)
71404 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
71405 IF(K(NS+IIM+IP,1).NE.1) THEN
71406 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
71407 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
71415 C*********************************************************************
71418 C...Generates pT-ordered timelike final-state parton showers.
71420 C...MODE defines how to find radiators and recoilers.
71421 C... = 0 : based on colour flow between undecayed partons.
71422 C... = 1 : for IPART <= NPARTD only consider primary partons,
71423 C... whether decayed or not; else as above.
71424 C... = 2 : based on common history, whether decayed or not.
71425 C... = 3 : use (or create) MCT color information to shower partons
71427 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
71429 C...Double precision and integer declarations.
71430 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71431 IMPLICIT INTEGER(I-N)
71432 INTEGER PYK,PYCHGE,PYCOMP
71433 C...Parameter statement to help give large particle numbers.
71434 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71435 &KEXCIT=4000000,KDIMEN=5000000)
71436 C...Parameter statement for maximum size of showers.
71437 PARAMETER (MAXNUR=1000)
71439 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
71440 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71441 COMMON/PYCTAG/NCT,MCT(4000,2)
71442 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71443 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71444 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
71445 COMMON/PYINT1/MINT(400),VINT(400)
71446 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
71449 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
71450 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
71451 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
71452 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
71453 C...Statement functions.
71454 SHAT(L,J)=(P(L,4)+P(J,4))**2-(P(L,1)+P(J,1))**2-
71455 &(P(L,2)+P(J,2))**2-(P(L,3)+P(J,3))**2
71456 DOTP(L,J)=P(L,4)*P(J,4)-P(L,1)*P(J,1)-P(L,2)*P(J,2)-P(L,3)*P(J,3)
71458 C...Initial values. Check that valid system.
71460 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
71461 &MSTJ(41).NE.12) RETURN
71462 IF(NPART.LE.0) THEN
71463 CALL PYERRM(2,'(PYPTFS:) showering system too small')
71469 C...Mass thresholds and Lambda for QCD evolution.
71473 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
71474 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
71481 C...Cutoff scale for QCD evolution. Starting pT2.
71482 NFLAV=MAX(0,MIN(5,MSTJ(45)))
71483 PT0C=0.5D0*PARJ(82)
71484 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
71486 C...Parameters for QED evolution.
71487 AEM2PI=PARU(101)/PARU(2)
71488 PT0EQ=0.5D0*PARJ(83)
71489 PT0EL=0.5D0*PARJ(90)
71491 C...Reset. Remove irrelevant colour tags.
71496 DO 110 I=MINT(84)+1,N
71497 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
71501 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
71508 C...Begin loop to set up showering partons. Sum four-momenta.
71511 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
71512 IF(K(I,1).GT.10) GOTO 230
71513 ELSEIF(K(I,3).GT.MINT(84)) THEN
71514 IF(K(I,3).GT.MINT(84)+2) GOTO 230
71516 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
71519 PSUM(J)=PSUM(J)+P(I,J)
71522 C...Find colour and charge, but skip diquarks.
71523 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
71528 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
71529 IF (MSTP(148).GE.1) THEN
71530 C...Temporary: force no radiation from quarkonia since not yet treated
71531 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
71532 & //' PYPTFS, switched off')
71533 CALL PYGIVE('MSTP(148)=0')
71535 IF (MSTP(148).EQ.0) THEN
71536 C...Skip quarkonia if radiation switched off
71542 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
71543 C...(only intended for studying the effects of switching such rad on/off)
71544 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
71548 C...Either colour or anticolour charge radiates; for gluon both.
71549 DO 180 JSGCOL=1,-1,-2
71550 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
71551 JCOL=4+(1-JSGCOL)/2
71554 C...Basic info about radiating parton.
71558 ISCOL(NEVOL)=JSGCOL
71560 PTSCA(NEVOL)=PTPART(IP)
71562 C...Begin search for colour recoiler when MODE = 0 or 1.
71564 C...Find sister with matching anticolour to the radiating parton.
71566 IRNEW=K(IROLD,JCOL)/MSTU(5)
71569 C...Skip radiation off loose colour ends.
71570 130 IF(IRNEW.EQ.0) THEN
71574 C...Optionally skip radiation on dipole to beam remnant.
71575 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
71579 C...For now always skip radiation on dipole to junction.
71580 ELSEIF(K(IRNEW,2).EQ.88) THEN
71584 C...For MODE=1: if reached primary then done.
71585 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
71586 & IRNEW.LE.NPARTD) THEN
71588 C...If sister stable and points back then done.
71589 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
71591 IF(K(IRNEW,1).LT.10) THEN
71593 C...If sister unstable then go to her daughter.
71596 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
71601 C...If found mother then look for aunt.
71602 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
71605 IRNEW=K(IROLD,JCOL)/MSTU(5)
71608 C...If daughter stable then done.
71609 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
71611 IF(K(IRNEW,1).LT.10) THEN
71613 C...If daughter unstable then go to granddaughter.
71616 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
71621 C...If daughter points to another daughter then done or move up.
71622 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
71624 IF(K(IRNEW,1).LT.10) THEN
71627 IRNEW=K(IRNEW,JCOL)/MSTU(5)
71633 C...Begin search for colour recoiler when MODE = 2.
71634 ELSEIF (MODE.EQ.2) THEN
71636 IRNEW=K(IROLD,JCOL)/MSTU(5)
71637 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
71638 C...If no color partner found, pick at random among other primaries
71639 C...(e.g., when the color line is traced all the way to the beam)
71640 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71641 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71642 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
71643 C...Step up to mother if radiating parton already branched.
71644 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
71646 IRNEW=K(IROLD,JCOL)/MSTU(5)
71648 C...Pick sister by history if no anticolour available.
71650 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
71652 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
71655 C...Last resort: pick at random among other primaries.
71657 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71658 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71662 C...Trace down if sister branched.
71663 150 IF(K(IRNEW,1).GT.10) THEN
71664 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
71665 C...If no correct color-daughter found, swap.
71666 IF (IRTMP.EQ.0) THEN
71669 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
71674 ELSEIF (MODE.EQ.3) THEN
71675 C...The following will add MCT colour tracing for unprepped events
71676 C...If not done, trace Les Houches colour tags for this dipole
71678 IF (MCT(I,JCOL-3).EQ.0) THEN
71679 C...Special end code -1 : trace to color partner or 0, return in IEND
71681 CALL PYCTTR(I,JCOL,IEND)
71682 C...Clean up mother/daughter 'read' tags set by PYCTTR
71685 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
71686 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
71693 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
71697 C...If no color partner, then we hit beam
71698 IF (IEND.LE.0) THEN
71699 C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
71700 IF (MSTP(72).LE.1) THEN
71704 C...Else try a random partner
71705 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71706 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71709 C...Else save recoiling colour partner
71715 C...Now found other end of colour dipole.
71720 C...Also electrical charge may radiate; so far only quarks and leptons.
71721 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
71722 & IABS(K(I,2)).LE.18) THEN
71724 C...Basic info about radiating parton.
71730 PTSCA(NEVOL)=PTPART(IP)
71732 C...Pick nearest (= smallest invariant mass) charged particle
71733 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
71737 DO 190 IP2=1,NPART+N-MINT(53)
71738 IF(IP2.EQ.IP) GOTO 190
71739 IF(IP2.LE.NPART) THEN
71741 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
71742 IF(K(I2,1).GT.10) GOTO 190
71743 ELSEIF(K(I2,3).GT.MINT(84)) THEN
71744 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
71746 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
71749 I2=MINT(53)+IP2-NPART
71751 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
71752 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
71753 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
71754 IF(PM2INV.LT.PM2MIN) THEN
71759 IF(IRNEW.EQ.0) THEN
71764 C...Begin search for charge recoiler when MODE = 2.
71767 C...Pick sister by history; step up if parton already branched.
71768 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
71772 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
71774 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
71776 C...Last resort: pick at random among other primaries.
71778 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71779 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71781 C...Trace down if sister branched.
71782 210 IF(K(IRNEW,1).GT.10) THEN
71783 DO 220 IR=IRNEW+1,N
71784 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
71794 C...End loop to set up showering partons. System invariant mass.
71796 IF(NEVOL.LE.0) RETURN
71797 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
71798 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
71800 C...Check if 3-jet matrix elements to be used.
71804 IF(MSTJ(47).GE.1) THEN
71806 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
71808 IPART1=K(IPART(1),3)
71809 IPART2=K(IPART(2),3)
71810 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
71811 KFSRCE=IABS(K(IPART1,2))
71812 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
71815 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
71820 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
71821 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
71822 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
71823 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
71824 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
71825 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
71826 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
71827 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
71829 C...Identify two primary showerers.
71830 KFLA1=IABS(K(IPART(1),2))
71832 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
71833 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
71834 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
71835 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
71836 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
71837 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
71838 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
71839 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
71840 KFLA2=IABS(K(IPART(2),2))
71842 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
71843 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
71844 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
71845 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
71846 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
71847 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
71848 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
71849 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
71851 C...Order of showerers. Presence of gluino.
71852 ITYPMN=MIN(ITYPE1,ITYPE2)
71853 ITYPMX=MAX(ITYPE1,ITYPE2)
71855 IF(ITYPE1.GT.ITYPE2) IORD=2
71857 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
71859 C...Require exactly two primary showerers for ME corrections.
71861 IF(IPART1.GT.0) THEN
71863 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
71866 IF(NPRIM.NE.2) THEN
71868 C...Predetermined and default matrix element kinds.
71869 ELSEIF(MSTJ(38).NE.0) THEN
71873 ELSEIF(MSTJ(47).GE.6) THEN
71879 C...Vector/axial vector -> q + qbar; q -> q + V.
71880 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
71881 & ITYPES.EQ.3)) THEN
71883 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
71885 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
71886 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
71887 C...gamma*/Z0: assume e+e- initial state if unknown.
71889 IF(KFSRCE.EQ.23) THEN
71891 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
71892 IF(IANNFL.GT.0) THEN
71893 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
71895 IF(IANNFL.NE.0) THEN
71896 KANNFL=IABS(K(IANNFL,2))
71897 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
71900 AI=SIGN(1D0,EI+0.1D0)
71901 VI=AI-4D0*EI*PARU(102)
71902 EF=KCHG(KFLA1,1)/3D0
71903 AF=SIGN(1D0,EF+0.1D0)
71904 VF=AF-4D0*EF*PARU(102)
71905 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
71908 SQWZ=PSUM(5)*PMAS(23,2)
71909 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
71910 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
71911 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
71912 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
71914 ALPHA=VECT/(VECT+AXIV)
71915 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
71918 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
71919 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
71921 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
71922 & ITYPES.EQ.1)) THEN
71925 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
71926 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
71928 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
71930 ELSEIF(KFSRCE.EQ.36) THEN
71933 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
71934 & ITYPES.EQ.1)) THEN
71937 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
71938 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
71939 & ITYPES.EQ.3)) THEN
71941 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
71942 & ITYPES.EQ.2)) THEN
71944 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
71946 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
71947 & ITYPES.EQ.2)) THEN
71950 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
71951 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
71952 & ITYPES.EQ.5)) THEN
71954 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
71955 & ITYPES.EQ.2)) THEN
71957 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
71958 & ITYPES.EQ.1)) THEN
71961 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
71962 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
71964 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
71965 & ITYPES.EQ.2)) THEN
71967 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
71968 & ITYPES.EQ.1)) THEN
71971 C...g -> ~g + ~g (eikonal approximation).
71972 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
71975 M3JC=5*ICLASS+ICOMBI
71978 C...Store pair that together define matrix element treatment.
71981 MESYS(NMESYS,0)=M3JC
71982 MESYS(NMESYS,1)=IPART(1)
71983 MESYS(NMESYS,2)=IPART(2)
71986 C...Store qqbar or l+l- pairs for QED radiation.
71987 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
71989 MESYS(NMESYS,0)=101
71990 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
71991 MESYS(NMESYS,1)=IPART(1)
71992 MESYS(NMESYS,2)=IPART(2)
71995 C...Store other qqbar/l+l- pairs from g/gamma branchings.
71997 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
71999 260 IF(I1M.GT.0) THEN
72000 IF(K(I1M,2).EQ.K(I1,2)) THEN
72005 C...Move up this check to avoid out-of-bounds.
72006 IF(I1M.EQ.0) GOTO 290
72007 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
72009 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
72011 270 IF(I2M.GT.0) THEN
72012 IF(K(I2M,2).EQ.K(I2,2)) THEN
72017 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
72023 MESYS(NMESYS,0)=102
72031 C..Loopback point for counting number of emissions.
72035 C...Begin loop to evolve all existing partons, if required.
72038 DO 380 IEVOL=1,NEVOL
72039 IF(IFLG(IEVOL).EQ.0) THEN
72041 C...Basic info on radiator and recoil.
72048 C...Skip any particles that are "turned off"
72049 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) GOTO 380
72051 C...Invariant mass of "dipole".Starting value for pT evolution.
72052 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
72053 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
72055 C...Case of evolution by QCD branching.
72056 IF(ISCOL(IEVOL).NE.0) THEN
72058 C...Parton-by-parton maximum scale from initial conditions.
72059 IF(MSTP(72).EQ.0) THEN
72060 DO 320 IPRT=1,NPARTS
72061 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
72065 C...If kinematically impossible then do not evolve.
72066 IF(PT2.LT.PT2CMN) THEN
72071 C...Check if part of system for which ME corrections should be applied.
72073 DO 330 IME=1,NMESYS
72074 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
72075 & MESYS(IME,0).LT.100) IMESYS=IME
72078 C...Special flag for colour octet states.
72079 C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
72081 KC = PYCOMP(K(I,2))
72082 IF(K(I,2).EQ.21) THEN
72084 ELSEIF(KCHG(KC,2).EQ.2) THEN
72088 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
72089 & IABS(K(I,2)).LE.9910555) MOCT=2
72093 C...Upper estimate for matrix element weighting and colour factor.
72094 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
72097 IF(MOCT.GE.1) COLFAC=3D0/2D0
72098 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
72099 WTPSQQ=0.5D0*0.5D0*NFLAV
72101 C...Determine overestimated z range: switch at c and b masses.
72106 IF(PT2.GT.1.01D0*PMCS) THEN
72112 IF(PT2.GT.1.01D0*PMBS) THEN
72118 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
72119 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
72121 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
72122 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
72125 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
72126 EVCOEF=EVCOEF+EVEMQQ
72129 C...Pick pT2 (in overestimated z range).
72130 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
72132 C...Loopback if crossed c/b mass thresholds.
72133 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
72137 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
72142 C...Finish if below lower cutoff.
72143 IF(PT2.LT.PT2CMN) THEN
72148 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
72149 C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
72151 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
72153 C...Pick z: dz/(1-z) or dz.
72154 IF(IFLAG.EQ.1) THEN
72155 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
72157 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
72160 C...Loopback if outside allowed range for given pT2.
72161 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
72162 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
72163 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
72164 PM2=PM2I+PT2/(Z*(1D0-Z))
72165 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
72167 C...No weighting for primary partons; to be done later on.
72168 IF(IMESYS.GT.0) THEN
72170 C...Weighting of q->qg/X->Xg branching.
72171 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
72172 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
72174 C...Weighting of g->gg branching.
72175 ELSEIF(IFLAG.EQ.1) THEN
72176 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
72178 C...Flavour choice and weighting of g->qqbar branching.
72180 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
72182 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
72183 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
72184 IF(WTME.LT.PYR(0)) GOTO 350
72188 C...Case of evolution by QED branching.
72189 ELSEIF(ISCHG(IEVOL).NE.0) THEN
72191 C...If kinematically impossible then do not evolve.
72193 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
72194 IF(PT2.LT.PT2EMN) THEN
72199 C...Check if part of system for which ME corrections should be applied.
72201 DO 360 IME=1,NMESYS
72202 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
72203 & MESYS(IME,0).GT.100) IMESYS=IME
72206 C...Charge. Matrix element weighting factor.
72207 CHG=ISCHG(IEVOL)/3D0
72210 C...Determine overestimated z range. Find evolution coefficient.
72211 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
72212 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
72213 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
72215 C...Pick pT2 (in overestimated z range).
72216 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
72218 C...Finish if below lower cutoff.
72219 IF(PT2.LT.PT2EMN) THEN
72224 C...Pick z: dz/(1-z).
72225 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
72227 C...Loopback if outside allowed range for given pT2.
72228 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
72229 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
72230 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
72231 PM2=PM2I+PT2/(Z*(1D0-Z))
72232 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
72234 C...Weighting by branching kernel, except if ME weighting later.
72235 IF(IMESYS.EQ.0) THEN
72236 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
72241 C...Save acceptable branching.
72243 IMESAV(IEVOL)=IMESYS
72249 C...Check if branching has highest pT.
72250 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
72252 PT2MX=PT2SAV(IEVOL)
72256 C...Finished if no more branchings to be done.
72257 IF(IMX.EQ.0) GOTO 520
72259 C...Restore info on hardest branching to be processed.
72270 PM2=PM2I+PT2/(Z*(1D0-Z))
72272 C...Special flag for colour octet states.
72274 KC = PYCOMP(K(I,2))
72275 IF(K(I,2).EQ.21) THEN
72277 ELSEIF(KCHG(KC,2).EQ.2) THEN
72281 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
72282 & IABS(K(I,2)).LE.9910555) MOCT=2
72285 C...Restore further info for g->qqbar branching.
72287 IF(IFLG(IMX).GT.10) THEN
72290 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
72293 C...For branching g include azimuthal asymmetries from polarization.
72295 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
72296 C...Trace grandmother via intermediate recoil copies.
72299 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
72300 & K(IM,3).GT.0) THEN
72302 IF(IM.GT.MINT(84)) GOTO 390
72305 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
72306 & KFGM=IABS(K(IGM,2))
72307 C...Define approximate energy sharing by identifying aunt.
72309 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
72310 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
72311 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
72312 C...Coefficient from gluon production.
72314 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
72316 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
72318 C...Coefficient from gluon decay.
72320 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
72322 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
72327 C...Create new slots for branching products and recoil.
72333 C...Set status, flavour and mother of new ones.
72336 IF(KCHA.NE.0) K(IGNEW,1)=1
72341 IF(KCHA.NE.0) K(IGNEW,2)=22
72343 K(INEW,2)=-ISIGN(KFQ,KCOL)
72344 K(IGNEW,2)=-K(INEW,2)
72351 C...Find rest frame and angles of branching+recoil.
72357 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
72358 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
72359 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
72360 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
72361 PHI=PYANGL(P(INEW,1),P(INEW,2))
72362 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
72364 C...Derive kinematics of branching: generics (like g->gg).
72369 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
72370 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
72371 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
72372 PTCOR=SQRT(MAX(0D0,PT2COR))
72373 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
72374 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
72375 C...Specific kinematics reduction for q->qg with m_q > 0.
72377 PTCOR=(1D0-PM2I/PM2)*PTCOR
72378 PZN=PZN+PM2I*PZG/PM2
72379 PZG=(1D0-PM2I/PM2)*PZG
72380 C...Specific kinematics reduction for g->qqbar with m_q > 0.
72381 ELSEIF(KFQ.NE.0) THEN
72385 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
72389 C...Pick phi and construct kinematics of branching.
72390 420 PHIROT=PARU(2)*PYR(0)
72391 P(INEW,1)=PTCOR*COS(PHIROT)
72392 P(INEW,2)=PTCOR*SIN(PHIROT)
72394 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
72395 P(IGNEW,1)=-P(INEW,1)
72396 P(IGNEW,2)=-P(INEW,2)
72398 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
72402 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
72404 C...Boost branching system to lab frame.
72405 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
72407 C...Renew choice of phi angle according to polarization asymmetry.
72408 IF(ABS(ASYPOL).GT.1D-3) THEN
72414 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
72415 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
72416 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
72418 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
72419 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
72421 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
72422 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
72423 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
72424 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
72425 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
72426 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
72431 C...Matrix element corrections for primary partons when requested.
72432 IF(IMESYS.GT.0) THEN
72433 M3JC=MESYS(IMESYS,0)
72435 C...Identify recoiling partner and set up three-body kinematics.
72436 IRP=MESYS(IMESYS,1)
72437 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
72438 IF(IRP.EQ.IR) IRP=IRNEW
72440 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
72442 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
72444 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
72445 & PSUM(3)*P(INEW,3))/PSUM(5)**2
72446 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
72447 & PSUM(3)*P(IRP,3))/PSUM(5)**2
72449 R1ME=P(INEW,5)/PSUM(5)
72450 R2ME=P(IRP,5)/PSUM(5)
72452 C...Matrix elements for gluon emission.
72453 IF(M3JC.LT.100) THEN
72455 C...Call ME, with right order important for two inequivalent showerers.
72456 IF(MESYS(IMESYS,IORD).EQ.I) THEN
72457 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
72459 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
72462 C...Split up total ME when two radiating partons.
72464 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
72465 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
72466 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
72467 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
72468 & MAX(1D-10,2D0-X1-X2)
72470 C...Evaluate shower rate.
72471 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
72472 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
72473 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
72475 C...Matrix elements for photon emission: still rather primitive.
72478 C...For generic charge combination currently only massless expression.
72479 IF(M3JC.EQ.101) THEN
72480 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
72481 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
72482 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
72483 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
72485 C...For flavour neutral system assume vector source and include masses.
72487 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
72488 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
72489 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
72490 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
72494 C...Perform weighting with W_ME/W_PS.
72495 IF(WME.LT.PYR(0)*WPS) THEN
72503 C...Now for sure accepted branching. Save highest pT.
72504 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
72506 C...Update status for obsolete ones. Bookkkep the moved original parton
72507 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
72508 C...Do not bookkeep radiated photon, since it cannot radiate further.
72512 IF(IPART(IP).EQ.I) IPART(IP)=INEW
72513 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
72520 C...Initialize colour flow of branching.
72521 C...Use both old and new style colour tags for flexibility.
72535 C...Trivial colour flow for l->lgamma and q->qgamma.
72536 IF(IABS(KCHA).EQ.3) THEN
72539 ELSEIF(KCHA.NE.0) THEN
72540 IF(K(I,4).NE.0) THEN
72542 K(INEW,4)=MSTU(5)*I
72543 MCT(INEW,1)=MCT(I,1)
72545 IF(K(I,5).NE.0) THEN
72547 K(INEW,5)=MSTU(5)*I
72548 MCT(INEW,2)=MCT(I,2)
72551 C...Set colour flow for q->qg and g->gg.
72552 ELSEIF(KFQ.EQ.0) THEN
72553 K(I,JCOLP)=K(I,JCOLP)+IGNEW
72554 K(IGNEW,JCOLP)=MSTU(5)*I
72555 K(INEW,JCOLP)=MSTU(5)*IGNEW
72556 K(IGNEW,JCOLN)=MSTU(5)*INEW
72557 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
72559 MCT(INEW,JCOLP-3)=NCT
72560 MCT(IGNEW,JCOLN-3)=NCT
72562 K(I,JCOLN)=K(I,JCOLN)+INEW
72563 K(INEW,JCOLN)=MSTU(5)*I
72564 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
72567 C...Set colour flow for g->qqbar.
72569 K(I,JCOLN)=K(I,JCOLN)+INEW
72570 K(INEW,JCOLN)=MSTU(5)*I
72571 K(I,JCOLP)=K(I,JCOLP)+IGNEW
72572 K(IGNEW,JCOLP)=MSTU(5)*I
72573 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
72574 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
72577 C...Daughter info for colourless recoiling parton.
72578 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
72584 C...Colour of recoiling parton sails through unchanged.
72586 IF(K(IR,4).NE.0) THEN
72587 K(IR,4)=K(IR,4)+IRNEW
72588 K(IRNEW,4)=MSTU(5)*IR
72589 MCT(IRNEW,1)=MCT(IR,1)
72591 IF(K(IR,5).NE.0) THEN
72592 K(IR,5)=K(IR,5)+IRNEW
72593 K(IRNEW,5)=MSTU(5)*IR
72594 MCT(IRNEW,2)=MCT(IR,2)
72598 C...Vertex information trivial.
72605 C...Update list of old radiators.
72606 DO 480 IEVOL=1,NEVOL
72607 C... A) radiator-recoiler mother pair for this branching
72608 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
72610 C... A2) QCD branching and color side matches, radiated parton follows recoiler
72611 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
72614 ELSEIF(IPOS(IEVOL).EQ.I) THEN
72615 C... B) other dipoles with I as radiator simply get INEW as new radiator
72618 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
72619 C... C) the "mirror image" of the parent dipole
72622 C... C2) QCD branching and color side matches, radiated parton follows recoiler
72623 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL.AND.ISCOL(IEVOL).NE.0)
72624 & IREC(IEVOL)=IGNEW
72626 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
72627 C... D) other dipoles with IR as radiator simply get IRNEW as new radiator
72631 C... Update links of old connected partons.
72632 IF(IREC(IEVOL).EQ.I) THEN
72635 ELSEIF(IREC(IEVOL).EQ.IR) THEN
72641 C...q->qg or g->gg: create new gluon radiators.
72642 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
72649 PTSCA(NEVOL)=SQRT(PT2)
72656 PTSCA(NEVOL)=PTSCA(NEVOL-1)
72657 C...g->qqbar: create new photon radiators.
72658 ELSEIF(KCOL.EQ.2.AND.KFQ.NE.0) THEN
72664 ISCHG(NEVOL)=PYK(INEW,6)
72665 PTSCA(NEVOL)=SQRT(PT2)
72671 ISCHG(NEVOL)=PYK(IGNEW,6)
72672 PTSCA(NEVOL)=SQRT(PT2)
72674 print*, 'created new QED dipole ',INEW,'<->',IGNEW
72677 C...Check color and charge connections,
72678 C...Rewire if better partners can be found (screening, etc)
72679 DO 500 IEVOL=1,NEVOL
72680 KCOL = ISCOL(IEVOL)
72681 KCHA = ISCHG(IEVOL)
72682 IRTMP = IREC(IEVOL)
72684 C...Do not modify QED dipoles
72685 IF (KCHA.NE.0) THEN
72687 C...Also skip dipole ends that are switched off
72688 ELSEIF (IFLG(IEVOL).LE.-1) THEN
72690 ELSEIF (KCOL.NE.0) THEN
72691 C...QCD dipoles. Check if current recoiler has appropriate color charge
72692 KCOLR = PYK(IRTMP,12)
72693 IF (KCOLR.EQ.2.OR.KCOLR.EQ.-KCOL) GOTO 500
72694 C...If not, look for closest recoiler with appropriate color charge
72695 RM2MIN = PSUM(5)**2
72698 DO 490 JEVOL=1,NEVOL
72700 IF (JEVOL.EQ.IEVOL) GOTO 490
72702 IF (JTMP.EQ.ITMP) GOTO 490
72703 JCOL = ISCOL(JEVOL)
72704 C...Skip dipole ends that are switched off
72705 IF (IFLG(JEVOL).LE.-1) GOTO 490
72706 C...Skip QED dipole ends
72707 IF (ISCHG(JEVOL).NE.0) GOTO 490
72708 C... Skip wrong-color if at least one correct-color partner already found
72709 IF (ISGOOD.NE.0.AND.JCOL.NE.-KCOL.AND.JCOL.NE.2) GOTO 490
72710 C...Accept if smallest m2 so far, or if first with correct color
72711 RM2 = DOTP(ITMP,JTMP)
72713 IF (JCOL.EQ.-KCOL.OR.JCOL.EQ.2) ISGNOW=1
72714 IF (RM2.LT.RM2MIN.OR.ISGNOW.GT.ISGOOD) THEN
72720 C...Update recoiler and reset dipole if new best partner found
72722 IREC(IEVOL) = IPOS(JMX)
72728 C...TMP! print out list of dipoles
72729 C DO 580 IEVOL=1,NEVOL
72730 C KCHA = ISCHG(IEVOL)
72731 C IF (KCHA.NE.0) THEN
72732 C print*, 'qed dip',IPOS(IEVOL),IREC(IEVOL)
72734 C print*, 'qcd dip',IPOS(IEVOL),IREC(IEVOL)
72738 C...Update matrix elements parton list and add new for g/gamma->qqbar.
72739 DO 510 IME=1,NMESYS
72740 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
72741 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
72742 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
72743 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
72748 MESYS(NMESYS,1)=INEW
72749 MESYS(NMESYS,2)=IGNEW
72751 MESYS(NMESYS,0)=102
72752 MESYS(NMESYS,1)=INEW
72753 MESYS(NMESYS,2)=IGNEW
72756 C...Global statistics.
72757 MINT(353)=MINT(353)+1
72758 VINT(353)=VINT(353)+PTCOR
72759 IF (MINT(353).EQ.1) VINT(358)=PTCOR
72761 C...Loopback for more emissions if enough space.
72763 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
72764 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
72767 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
72776 C*********************************************************************
72779 C...Auxiliary to PYSHOW and PYPTFS.
72780 C...Matrix elements for gluon (or photon) emission from
72781 C...a two-body state; to be used by the parton shower routine.
72782 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
72783 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
72784 C... = (alpha-strong/2 pi) * CF * PYMAEL,
72785 C...i.e. normalization is such that one recovers the familiar
72786 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
72787 C...Coupling structure:
72788 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
72789 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
72790 C... = 16-19 : q -> q V
72791 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
72792 C... = 26-29 : q -> q S
72793 C... = 31-34 : V -> ~q ~qbar (~q = squark)
72794 C... = 36-39 : ~q -> ~q V
72795 C... = 41-44 : S -> ~q ~qbar
72796 C... = 46-49 : ~q -> ~q S
72797 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
72798 C... = 56-59 : ~q -> q chi
72799 C... = 61-64 : q -> ~q chi
72800 C... = 66-69 : ~g -> q ~qbar
72801 C... = 71-74 : ~q -> q ~g
72802 C... = 76-79 : q -> ~q ~g
72803 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
72804 C...Note that the order of the decay products is important.
72805 C...In each set of four, the variants are ordered as:
72806 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
72807 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
72808 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
72809 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
72811 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
72813 C...Double precision and integer declarations.
72814 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72815 IMPLICIT INTEGER(I-N)
72817 C...Check input values. Return zero outside allowed phase space.
72819 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
72820 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
72821 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
72822 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
72823 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
72824 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
72826 C...Initial values and flags.
72834 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
72836 C...Eikonal expression; also acts as default.
72837 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
72839 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
72841 ELSEIF(ICOMBI.EQ.2) THEN
72842 ANUM=(2D0-X1-X2)**2
72843 ELSEIF(ICOMBI.EQ.3) THEN
72844 ANUM=ALPCOR*(2D0-X1-X2)**2
72846 ANUM=0.5D0*(2D0-X1-X2)**2
72848 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
72849 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
72850 & R1**2/(1D0+R2**2-R1**2-X2)**2-
72851 & R2**2/(1D0+R1**2-R2**2-X1)**2)
72854 C...V -> q qbar (V = gamma*/Z0/W+-/...).
72855 ELSEIF(ICLASS.EQ.2) THEN
72856 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
72857 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
72858 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
72859 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
72860 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
72861 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
72862 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
72863 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
72864 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
72865 & (-1+R1**2-R2**2+X2)**2
72866 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
72867 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
72868 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
72869 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
72870 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
72871 & -X1-X2)**2+X1*(2-X1-X2)**2)/
72872 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72873 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
72874 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
72875 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
72876 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
72877 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
72881 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
72882 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
72883 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
72884 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
72885 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
72886 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
72887 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
72888 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
72889 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
72890 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
72891 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
72892 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
72893 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
72894 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
72895 & -X1-X2)**2+X1*(2-X1-X2)**2)/
72896 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72897 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
72898 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
72899 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
72900 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
72901 & +X2)/(-1-R1**2+R2**2+X1)**2
72905 IF(ICOMBI.EQ.4) THEN
72906 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
72907 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
72908 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
72909 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
72910 & (-1-R1**2+R2**2+X1)**2
72912 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
72913 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
72914 & -R1**2*X2**2+X1*X2**2)/
72915 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72916 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
72917 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
72918 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
72919 & (-1+R1**2-R2**2+X2)**2
72925 ELSEIF(ICLASS.EQ.3) THEN
72926 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
72927 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
72928 & +R1**2*R2**2-2D0*R2**4)
72929 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
72930 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
72931 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
72932 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
72933 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
72934 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
72935 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
72936 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
72937 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
72938 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
72939 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
72940 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
72941 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
72942 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
72943 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
72944 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
72945 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
72946 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
72947 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
72950 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
72951 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
72952 & +R1**2*R2**2-2D0*R2**4)
72953 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
72954 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
72955 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
72956 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
72957 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
72958 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
72959 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
72960 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
72961 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
72962 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
72963 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
72964 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
72965 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
72966 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
72967 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
72968 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
72969 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
72970 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
72971 & +X1*X2**2)/(-2+X1+X2)**2
72974 IF(ICOMBI.EQ.4) THEN
72975 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
72976 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
72977 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
72978 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
72979 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
72980 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
72981 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
72982 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
72983 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
72984 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
72985 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
72986 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
72987 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
72988 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
72989 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
72990 & +X1*X2**2)/(2-X1-X2)**2
72994 C...S -> q qbar (S = h0/H0/A0/H+-/...).
72995 ELSEIF(ICLASS.EQ.4) THEN
72996 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
72997 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
72998 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
72999 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73000 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73001 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
73002 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
73003 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73004 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73005 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73006 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73009 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73010 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
73011 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73012 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73013 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73014 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73015 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
73016 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73017 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
73018 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
73019 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
73020 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73023 IF(ICOMBI.EQ.4) THEN
73024 RLO4=PS*(1D0-R1**2-R2**2)
73025 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
73026 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73027 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
73028 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
73029 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73030 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
73031 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73036 ELSEIF(ICLASS.EQ.5) THEN
73037 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73038 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73039 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
73040 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73041 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
73042 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73043 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
73044 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
73045 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73046 & (-1+R1**2-R2**2+X2)**2
73049 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73050 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
73051 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
73052 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73053 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
73054 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73055 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
73056 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
73057 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73058 & (-1+R1**2-R2**2+X2)**2
73061 IF(ICOMBI.EQ.4) THEN
73062 RLO4=PS*(1D0+R1**2-R2**2)
73063 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
73064 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73065 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
73066 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
73067 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
73068 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
73072 C...V -> ~q ~qbar (~q = squark).
73073 ELSEIF(ICLASS.EQ.6) THEN
73074 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
73075 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
73076 & (-1-R1**2+R2**2+X1)**2
73077 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
73078 & (-1-R1**2+R2**2+X1)
73079 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
73080 & /(-1+R1**2-R2**2+X2)**2
73081 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
73082 & (-1+R1**2-R2**2+X2)
73083 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
73084 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
73085 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
73086 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73090 ELSEIF(ICLASS.EQ.7) THEN
73091 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
73092 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
73093 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
73094 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
73095 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
73096 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
73097 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
73098 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
73099 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
73100 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
73101 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
73107 ELSEIF(ICLASS.EQ.8) THEN
73109 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
73110 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
73111 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
73112 & -R1**2*X2**2+X1*X2**2)/
73113 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
73118 ELSEIF(ICLASS.EQ.9) THEN
73120 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73121 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73122 & -(X1+X2)/(-2+X1+X2)**2
73125 C...chi -> q ~qbar (chi = neutralino/chargino).
73126 ELSEIF(ICLASS.EQ.10) THEN
73127 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73128 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73129 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
73130 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
73131 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
73132 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73133 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
73134 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73135 & (-1+R1**2-R2**2+X2)**2
73138 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73139 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
73140 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
73141 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
73142 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
73143 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73144 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
73145 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73146 & (-1+R1**2-R2**2+X2)**2
73149 IF(ICOMBI.EQ.4) THEN
73150 RLO4=PS*(1+R1**2-R2**2)
73151 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
73152 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
73153 & +X2+R1**2*X2-X1*X2/2)/
73154 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73155 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
73156 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
73161 ELSEIF(ICLASS.EQ.11) THEN
73162 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73163 RLO1=PS*(1D0-(R1+R2)**2)
73164 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
73165 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73166 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73167 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73168 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
73169 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73170 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73173 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73174 RLO2=PS*(1D0-(R1-R2)**2)
73175 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
73177 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73178 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
73179 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73180 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
73181 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73182 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73185 IF(ICOMBI.EQ.4) THEN
73186 RLO4=PS*(1D0-R1**2-R2**2)
73187 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
73188 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
73189 & +3*R1**2*X2-R2**2*X2-X1*X2)/
73190 & (-1+R1**2-R2**2+X2)**2
73191 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
73192 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
73193 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73198 ELSEIF(ICLASS.EQ.12) THEN
73199 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73200 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
73201 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73202 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
73203 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
73204 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
73205 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73206 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73209 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73210 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
73211 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
73212 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
73213 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
73214 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
73215 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73216 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73219 IF(ICOMBI.EQ.4) THEN
73220 RLO4=PS*(1D0-R1**2+R2**2)
73221 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73222 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
73223 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
73224 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
73225 & +R1**2*X2-X1*X2/2-X2**2/2)/
73226 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73231 ELSEIF(ICLASS.EQ.13) THEN
73232 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73233 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73234 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
73235 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
73236 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
73237 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
73238 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
73239 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
73240 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
73241 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
73242 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
73243 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
73244 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
73245 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73246 & (3*(-1+R1**2-R2**2+X2)**2)
73250 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73251 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
73252 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
73253 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
73254 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73255 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
73256 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
73257 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
73258 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
73259 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
73260 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
73261 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73262 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
73263 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
73264 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73265 & (3*(-1+R1**2-R2**2+X2)**2)
73269 IF(ICOMBI.EQ.4) THEN
73270 RLO4=PS*(1D0+R1**2-R2**2)
73271 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
73272 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
73273 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
73274 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
73275 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
73276 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73277 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
73278 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73279 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
73280 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73281 & (3*(-1+R1**2-R2**2+X2)**2)
73287 ELSEIF(ICLASS.EQ.14) THEN
73288 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73289 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
73290 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
73291 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73292 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73293 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
73294 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
73295 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
73296 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
73297 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73298 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73299 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
73300 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
73301 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
73302 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
73304 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
73305 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73306 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73310 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73311 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
73312 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
73313 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73314 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73315 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
73316 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
73317 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
73318 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
73319 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
73320 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
73321 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
73323 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
73324 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
73325 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
73326 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
73327 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
73328 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73332 IF(ICOMBI.EQ.4) THEN
73333 RLO4=PS*(1-R1**2-R2**2)
73334 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
73335 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
73336 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73337 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
73338 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
73339 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
73340 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
73341 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
73342 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
73343 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
73344 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
73345 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
73346 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
73347 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
73348 RFO4=9D0*RFO4/128D0
73353 ELSEIF(ICLASS.EQ.15) THEN
73354 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73355 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
73356 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
73357 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
73358 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
73359 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
73360 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
73361 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
73362 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
73363 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
73364 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
73365 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
73366 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
73367 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
73368 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
73369 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73373 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73374 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
73375 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
73376 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
73377 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
73378 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
73379 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
73380 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
73381 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
73382 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
73383 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73384 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
73385 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
73386 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
73387 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73388 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73392 IF(ICOMBI.EQ.4) THEN
73393 RLO4=PS*(1D0-R1**2+R2**2)
73394 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
73395 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
73396 & -R2**2*X2/2-X1*X2/2)/
73397 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
73398 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
73399 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73400 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
73401 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
73402 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
73403 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
73404 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
73405 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73410 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
73411 ELSEIF(ICLASS.EQ.16) THEN
73413 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
73415 ELSEIF(ICOMBI.EQ.2) THEN
73416 ANUM=(2D0-X1-X2)**2
73417 ELSEIF(ICOMBI.EQ.3) THEN
73418 ANUM=ALPCOR*(2D0-X1-X2)**2
73420 ANUM=0.5D0*(2D0-X1-X2)**2
73422 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
73423 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
73424 & R1**2/(1D0+R2**2-R1**2-X2)**2-
73425 & R2**2/(1D0+R1**2-R2**2-X1)**2)
73430 C...Find relevant LO and FO expression.
73431 IF(ICOMBI.EQ.0) THEN
73432 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
73435 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
73438 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
73439 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
73440 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
73441 ELSEIF(ISSET4.EQ.1) THEN
73444 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
73445 RLO=0.5D0*(RLO1+RLO2)
73446 RFO=0.5D0*(RFO1+RFO2)
73447 ELSEIF(ISSET1.EQ.1) THEN
73451 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
73462 C*********************************************************************
73465 C...Modifies an event so as to approximately take into account
73466 C...Bose-Einstein effects according to a simple phenomenological
73467 C...parametrization.
73469 SUBROUTINE PYBOEI(NSAV)
73471 C...Double precision and integer declarations.
73472 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73473 IMPLICIT INTEGER(I-N)
73474 INTEGER PYK,PYCHGE,PYCOMP
73475 C...Parameter statement to help give large particle numbers.
73476 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73477 &KEXCIT=4000000,KDIMEN=5000000)
73479 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73480 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73481 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73482 COMMON/PYINT1/MINT(400),VINT(400)
73483 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
73484 C...Local arrays and data.
73485 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
73486 &BEIW(100),BEI3W(100)
73487 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
73488 C...Statement function: squared invariant mass.
73489 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
73490 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
73492 C...Boost event to overall CM frame. Calculate CM energy.
73493 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
73499 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
73500 & .AND.K(I,3).GT.0) THEN
73501 KFMA=IABS(K(K(I,3),2))
73502 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
73504 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
73506 DPS(J)=DPS(J)+P(I,J)
73509 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
73513 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
73516 C...Check if we have separated strings
73518 C...Reserve copy of particles by species at end of record.
73524 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
73525 NBE(IBE)=NBE(IBE-1)
73527 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
73528 DO 140 IIBE=1,IBE-1
73529 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
73532 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
73534 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
73535 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
73536 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
73539 NBE(IBE)=NBE(IBE)+1
73546 P(NBE(IBE),1)=0.0D0
73547 P(NBE(IBE),2)=0.0D0
73548 P(NBE(IBE),3)=0.0D0
73549 P(NBE(IBE),4)=0.0D0
73550 P(NBE(IBE),5)=0.0D0
73551 SMMIN=MIN(SMMIN,P(I,5))
73552 C...Check if particles comes from different W's or Z's
73553 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
73555 150 IF(K(IM,3).GT.0) THEN
73557 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
73559 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
73560 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
73561 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
73562 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
73565 C...Check if particles comes from different strings.
73566 IF(PARJ(94).GT.0.0D0) THEN
73568 160 IF(K(IM,3).GT.0) THEN
73570 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
73578 P(NBE(IBE),5)=-1.0D0
73581 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
73583 C...Calculate separation between W+ and W- or between two Z0's.
73584 C...No separation if there has been re-connections.
73586 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
73587 IF(K(IWP,2).EQ.23) THEN
73596 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
73597 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
73598 TAUP=-TAUPD*LOG(PYR(IDUM))
73599 TAUN=-TAUND*LOG(PYR(IDUM))
73600 DXP=TAUP*PYP(IWP,8)/DMP
73601 DXN=TAUN*PYP(IWN,8)/DMN
73603 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
73604 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
73607 C...Add separation between strings.
73608 IF(PARJ(94).GT.0.0D0) THEN
73609 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
73614 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
73615 DO 220 IBE=1,MIN(9,MSTJ(52))
73616 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
73619 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
73620 IF(I2M.EQ.I1M) GOTO 200
73622 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
73623 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
73624 & (P(I1,5)+P(I2,5))**2
73625 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
73634 C...Tabulate integral for subsequent momentum shift.
73635 DO 400 IBE=1,MIN(9,MSTJ(52))
73636 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
73637 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
73639 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
73640 & NBE(7)-NBE(6)).LE.1) GOTO 270
73641 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
73642 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
73643 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
73644 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
73645 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
73646 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
73647 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
73648 QDELW=0.1D0*MIN(PMHQ,SIGW)
73649 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
73650 IF(MSTJ(51).EQ.1) THEN
73651 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
73652 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
73653 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
73654 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
73655 BEEX=EXP(0.5D0*QDEL/PARJ(93))
73656 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
73657 BEEXW=EXP(0.5D0*QDELW/SIGW)
73658 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
73659 BERT=EXP(-QDEL/PARJ(93))
73660 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
73661 BERTW=EXP(-QDELW/SIGW)
73662 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
73664 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
73665 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
73666 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
73667 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
73670 QBIN=QDEL*(IBIN-0.5D0)
73671 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73672 IF(MSTJ(51).EQ.1) THEN
73674 BEI(IBIN)=BEI(IBIN)*BEEX
73676 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
73678 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
73680 DO 240 IBIN=1,NBIN3
73681 QBIN=QDEL3*(IBIN-0.5D0)
73682 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73683 IF(MSTJ(51).EQ.1) THEN
73685 BEI3(IBIN)=BEI3(IBIN)*BEEX3
73687 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
73689 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
73691 DO 250 IBIN=1,NBINW
73692 QBIN=QDELW*(IBIN-0.5D0)
73693 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73694 IF(MSTJ(51).EQ.1) THEN
73696 BEIW(IBIN)=BEIW(IBIN)*BEEXW
73698 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
73700 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
73702 DO 260 IBIN=1,NBIN3W
73703 QBIN=QDEL3W*(IBIN-0.5D0)
73704 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
73705 & SQRT(QBIN**2+PMHQ**2)
73706 IF(MSTJ(51).EQ.1) THEN
73707 BEEX3W=BEEX3W*BERT3W
73708 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
73710 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
73712 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
73715 C...Loop through particle pairs and find old relative momentum.
73716 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
73718 DO 380 I2M=I1M+1,NBE(IBE)
73719 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
73720 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
73722 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
73723 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
73724 IF(Q2OLD.LE.0.0D0) GOTO 380
73727 C...Calculate new relative momentum.
73732 IF(QOLD.LT.1D-3*QDEL) THEN
73734 ELSEIF(QOLD.LE.QDEL) THEN
73736 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
73739 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
73740 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
73741 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73743 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73745 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
73746 IF(QOLD.LT.1D-3*QDEL3) THEN
73748 ELSEIF(QOLD.LE.QDEL3) THEN
73750 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
73753 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
73754 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
73755 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73757 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73759 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
73762 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
73763 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
73764 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
73766 IF(QOLD.LT.1D-3*QDELW) THEN
73768 ELSEIF(QOLD.LE.QDELW) THEN
73770 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
73773 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
73774 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
73775 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73777 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73779 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
73780 IF(QOLD.LT.1D-3*QDEL3W) THEN
73782 ELSEIF(QOLD.LE.QDEL3W) THEN
73784 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
73787 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
73788 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
73789 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73791 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73793 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
73795 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
73797 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
73799 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
73800 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
73802 IF(MSTJ(54).GE.1) THEN
73803 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
73805 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
73806 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
73808 ELSEIF(MSTJ(54).LE.-1) THEN
73809 EDEL=P(I1,4)+P(I2,4)-
73810 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
73811 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
73812 & (P(I1,3)-P(I2,3))**2
73817 SM1=(P(I1,5)+SMMIN)**2
73818 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73819 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
73820 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
73821 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
73822 & K(I3M,5).NE.K(I1M,5)) GOTO 360
73824 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
73827 SM3=(P(I3,5)+SMMIN)**2
73828 IF(MSTJ(54).EQ.-2) THEN
73829 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
73830 & S23*MIN(SM1,SM3))*SM1)
73832 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
73833 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
73834 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
73835 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
73837 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
73838 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
73841 IF(WMAX*WI.GE.1.0) GOTO 360
73843 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
73844 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
73845 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
73846 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
73847 & K(I4M,5).NE.K(I1M,5)) GOTO 350
73849 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
73851 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
73852 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
73853 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
73855 IF(MSTJ(54).EQ.-2) THEN
73859 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
73860 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
73861 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
73862 W=MIN(W,MIN(S23,S24)*S13*S14)
73865 C...weight=1-cos(theta)/mtot2
73866 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
73867 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
73868 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
73869 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
73871 IF(W.LE.WMAX) GOTO 350
73873 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
73874 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
73875 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
73876 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
73877 IF(W.LE.WMAX) GOTO 350
73883 IF(MI4.EQ.0) GOTO 380
73886 EOLD=P(I3,4)+P(I4,4)
73888 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
73889 & (P(I3,3)+P(I4,3))**2
73890 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
73891 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
73892 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
73894 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
73895 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
73902 C...Shift momenta and recalculate energies.
73906 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73910 P(I,J)=P(I,J)+P(IM,J)
73912 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73915 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
73920 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
73921 440 ALPHA=(ESUMP-ESUM)/PROD
73922 PARJ(96)=PARJ(96)+ALPHA
73925 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73928 P(I,J)=P(I,J)+ALPHA*V(IM,J)
73930 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73933 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
73936 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
73940 C...Rescale all momenta for energy conservation.
73944 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
73946 PQS=PQS+P(I,5)**2/P(I,4)
73949 FAC=(PECM-PQS)/(PES-PQS)
73951 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
73955 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73958 C...Boost back to correct reference frame.
73959 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
73961 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
73967 C*********************************************************************
73970 C...Calculates the momentum shift in a system of two particles assuming
73971 C...the relative momentum squared should be shifted to Q2NEW. NI is the
73972 C...last position occupied in /PYJETS/.
73974 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
73976 C...Double precision and integer declarations.
73977 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73978 IMPLICIT INTEGER(I-N)
73979 INTEGER PYK,PYCHGE,PYCOMP
73980 C...Parameter statement to help give large particle numbers.
73981 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73982 &KEXCIT=4000000,KDIMEN=5000000)
73984 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73985 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73986 SAVE /PYJETS/,/PYDAT1/
73987 C...Local arrays and data.
73991 IF(MSTJ(55).EQ.0) THEN
73993 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
73994 & (P(I1,3)-P(I2,3))**2
73995 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
73996 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
74000 DA=SE*DE*DP12-DP2*DQ2SE
74001 DB=DP2*DQ2SE-DP12**2
74002 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
74004 PD=HA*(P(I1,J)-P(I2,J))
74016 DP(J)=P(I1,J)+P(I2,J)
74019 C...Boost to cms and rotate first particle to z-axis
74020 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
74021 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
74022 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
74023 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
74024 S=Q2NEW+(P(I1,5)+P(I2,5))**2
74025 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
74029 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
74033 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
74034 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
74035 CALL PYROBO(NI+1,NI+2,THE,PHI,
74036 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
74039 P(NI+1,J)=P(NI+1,J)-P(I1,J)
74040 P(NI+2,J)=P(NI+2,J)-P(I2,J)
74046 C*********************************************************************
74049 C...Gives the mass of a particle/parton.
74051 FUNCTION PYMASS(KF)
74053 C...Double precision and integer declarations.
74054 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74055 IMPLICIT INTEGER(I-N)
74056 INTEGER PYK,PYCHGE,PYCOMP
74058 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74059 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74060 SAVE /PYDAT1/,/PYDAT2/
74062 C...Reset variables. Compressed code. Special case for popcorn diquarks.
74071 C...Guarantee use of constituent masses for internal checks.
74072 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
74073 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
74075 PYMASS=PARF(100+KFA)
74076 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
74077 ELSEIF(KFA.LE.10) THEN
74079 ELSEIF(MSTJ(93).EQ.1) THEN
74080 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
74082 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
74085 C...Other masses can be read directly off table.
74090 C...Optional mass broadening according to truncated Breit-Wigner
74091 C...(either in m or in m^2).
74092 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
74093 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
74094 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
74095 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
74098 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
74099 & (PM0*PMAS(KC,2)))
74100 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
74101 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
74102 & (PMUPP-PMLOW)*PYR(0))))
74110 C*********************************************************************
74113 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
74114 C...for Higgs couplings. Everything else sent on to PYMASS.
74116 FUNCTION PYMRUN(KF,Q2)
74118 C...Double precision and integer declarations.
74119 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74120 IMPLICIT INTEGER(I-N)
74121 INTEGER PYK,PYCHGE,PYCOMP
74123 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74124 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74125 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74126 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
74128 C...Most masses not handled here.
74130 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
74133 C...Current-algebra masses, but no Q2 dependence.
74134 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
74135 PYMRUN=PARF(90+KFA)
74137 C...Running current-algebra masses.
74140 PYMRUN=PARF(90+KFA)*
74141 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
74142 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
74148 C*********************************************************************
74151 C...Gives the particle/parton name as a character string.
74153 SUBROUTINE PYNAME(KF,CHAU)
74155 C...Double precision and integer declarations.
74156 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74157 IMPLICIT INTEGER(I-N)
74158 INTEGER PYK,PYCHGE,PYCOMP
74160 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74161 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74162 COMMON/PYDAT4/CHAF(500,2)
74164 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
74165 C...Local character variable.
74168 C...Read out code with distinction particle/antiparticle.
74171 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
74177 C*********************************************************************
74180 C...Gives three times the charge for a particle/parton.
74182 FUNCTION PYCHGE(KF)
74184 C...Double precision and integer declarations.
74185 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74186 IMPLICIT INTEGER(I-N)
74187 INTEGER PYK,PYCHGE,PYCOMP
74189 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74192 C...Read out charge and change sign for antiparticle.
74195 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
74200 C*********************************************************************
74203 C...Compress the standard KF codes for use in mass and decay arrays;
74204 C...also checks whether a given code actually is defined.
74206 FUNCTION PYCOMP(KF)
74208 C...Double precision and integer declarations.
74209 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74210 IMPLICIT INTEGER(I-N)
74211 INTEGER PYK,PYCHGE,PYCOMP
74213 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74214 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74215 SAVE /PYDAT1/,/PYDAT2/
74216 C...Local arrays and saved data.
74217 DIMENSION KFORD(100:500),KCORD(101:500)
74218 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
74220 C...Whenever necessary reorder codes for faster search.
74221 IF(MSTU(20).EQ.0) THEN
74226 IF(KFA.LE.100) GOTO 120
74228 DO 100 I1=NFORD-1,0,-1
74229 IF(KFA.GE.KFORD(I1)) GOTO 110
74230 KFORD(I1+1)=KFORD(I1)
74231 KCORD(I1+1)=KCORD(I1)
74233 110 KFORD(I1+1)=KFA
74241 C...Fast action if same code as in latest call.
74242 IF(KF.EQ.KFLAST) THEN
74247 C...Starting values. Remove internal diquark flags.
74250 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
74251 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
74253 C...Simple cases: direct translation.
74254 IF(KFA.GT.KFORD(NFORD)) THEN
74255 ELSEIF(KFA.LE.100) THEN
74258 C...Else binary search.
74262 130 IAVG=(IMIN+IMAX)/2
74263 IF(KFORD(IAVG).GT.KFA) THEN
74265 IF(IMAX.GT.IMIN+1) GOTO 130
74266 ELSEIF(KFORD(IAVG).LT.KFA) THEN
74268 IF(IMAX.GT.IMIN+1) GOTO 130
74274 C...Check if antiparticle allowed.
74275 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
74276 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
74279 C...Save codes for possible future fast action.
74286 C*********************************************************************
74289 C...Informs user of errors in program execution.
74291 SUBROUTINE PYERRM(MERR,CHMESS)
74293 C...Double precision and integer declarations.
74294 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74295 IMPLICIT INTEGER(I-N)
74296 INTEGER PYK,PYCHGE,PYCOMP
74298 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74299 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74300 SAVE /PYJETS/,/PYDAT1/
74301 C...Local character variable.
74302 CHARACTER CHMESS*(*)
74304 C...Write first few warnings, then be silent.
74305 IF(MERR.LE.10) THEN
74306 MSTU(27)=MSTU(27)+1
74308 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
74309 & MERR,MSTU(31),CHMESS
74311 C...Write first few errors, then be silent or stop program.
74312 ELSEIF(MERR.LE.20) THEN
74313 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
74314 MSTU(30)=MSTU(30)+1
74316 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
74317 & MERR-10,MSTU(31),CHMESS
74318 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
74319 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
74320 WRITE(MSTU(11),5200)
74321 IF(MERR.NE.17) CALL PYLIST(2)
74325 C...Stop program in case of irreparable error.
74327 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
74331 C...Formats for output.
74332 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
74333 &' PYEXEC calls:'/5X,A)
74334 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
74335 &' PYEXEC calls:'/5X,A)
74336 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
74338 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
74339 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
74344 C*********************************************************************
74347 C...Calculates the running alpha_electromagnetic.
74349 FUNCTION PYALEM(Q2)
74351 C...Double precision and integer declarations.
74352 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74353 IMPLICIT INTEGER(I-N)
74354 INTEGER PYK,PYCHGE,PYCOMP
74356 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74359 C...Calculate real part of photon vacuum polarization.
74360 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
74361 C...For hadrons use parametrization of H. Burkhardt et al.
74362 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
74363 AEMPI=PARU(101)/(3D0*PARU(1))
74364 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
74366 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
74368 ELSEIF(MSTU(101).EQ.2) THEN
74369 RPIGG=1D0-PARU(101)/PARU(103)
74370 ELSEIF(Q2.LT.0.09D0) THEN
74371 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
74372 ELSEIF(Q2.LT.9D0) THEN
74373 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
74374 & 0.00238D0*LOG(1D0+3.927D0*Q2)
74375 ELSEIF(Q2.LT.1D4) THEN
74376 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
74377 & 0.00299D0*LOG(1D0+Q2)
74379 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
74380 & 0.00293D0*LOG(1D0+Q2)
74383 C...Calculate running alpha_em.
74384 PYALEM=PARU(101)/(1D0-RPIGG)
74390 C*********************************************************************
74393 C...Gives the value of alpha_strong.
74395 FUNCTION PYALPS(Q2)
74397 C...Double precision and integer declarations.
74398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74399 IMPLICIT INTEGER(I-N)
74400 INTEGER PYK,PYCHGE,PYCOMP
74402 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74403 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74404 SAVE /PYDAT1/,/PYDAT2/
74405 C...Coefficients for second-order threshold matching.
74406 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
74407 DIMENSION STEPDN(6),STEPUP(6)
74408 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
74409 c &(2D0*321D0/3703D0),0D0/
74410 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
74411 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
74412 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
74413 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
74415 C...Constant alpha_strong trivial. Pick artificial Lambda.
74416 IF(MSTU(111).LE.0) THEN
74418 MSTU(118)=MSTU(112)
74420 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
74421 & ((33D0-2D0*MSTU(112))*PARU(111)))
74422 PARU(118)=PARU(111)
74426 C...Find effective Q2, number of flavours and Lambda.
74428 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
74431 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
74432 Q2THR=PARU(113)*PMAS(NF,1)**2
74433 IF(Q2EFF.LT.Q2THR) THEN
74436 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
74437 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
74441 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
74442 Q2THR=PARU(113)*PMAS(NF+1,1)**2
74443 IF(Q2EFF.GT.Q2THR) THEN
74446 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
74447 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
74451 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
74452 PARU(117)=SQRT(ALAM2)
74454 C...Evaluate first or second order alpha_strong.
74455 B0=(33D0-2D0*NF)/6D0
74456 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
74457 IF(MSTU(111).EQ.1) THEN
74458 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
74460 B1=(153D0-19D0*NF)/6D0
74461 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
74470 C*********************************************************************
74473 C...Reconstructs an angle from given x and y coordinates.
74475 FUNCTION PYANGL(X,Y)
74477 C...Double precision and integer declarations.
74478 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74479 IMPLICIT INTEGER(I-N)
74480 INTEGER PYK,PYCHGE,PYCOMP
74482 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74487 IF(R.LT.1D-20) RETURN
74488 IF(ABS(X)/R.LT.0.8D0) THEN
74489 PYANGL=SIGN(ACOS(X/R),Y)
74492 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
74493 PYANGL=PARU(1)-PYANGL
74494 ELSEIF(X.LT.0D0) THEN
74495 PYANGL=-PARU(1)-PYANGL
74502 C*********************************************************************
74503 C*********************************************************************
74506 C...Performs rotations and boosts.
74508 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
74510 C...Double precision and integer declarations.
74511 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74512 IMPLICIT INTEGER(I-N)
74513 INTEGER PYK,PYCHGE,PYCOMP
74515 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74516 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74517 SAVE /PYJETS/,/PYDAT1/
74519 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
74521 C...Find and check range of rotation/boost.
74523 IF(IMIN.LE.0) IMIN=1
74524 IF(MSTU(1).GT.0) IMIN=MSTU(1)
74526 IF(IMAX.LE.0) IMAX=N
74527 IF(MSTU(2).GT.0) IMAX=MSTU(2)
74528 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
74529 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
74533 C...Optional resetting of V (when not set before.)
74534 IF(MSTU(33).NE.0) THEN
74535 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
74543 C...Rotate, typically from z axis to direction (theta,phi).
74544 IF(THE**2+PHI**2.GT.1D-20) THEN
74545 ROT(1,1)=COS(THE)*COS(PHI)
74547 ROT(1,3)=SIN(THE)*COS(PHI)
74548 ROT(2,1)=COS(THE)*SIN(PHI)
74550 ROT(2,3)=SIN(THE)*SIN(PHI)
74555 IF(K(I,1).LE.0) GOTO 140
74561 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
74562 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
74567 C...Boost, typically from rest to momentum/energy=beta.
74568 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
74572 DB=SQRT(DBX**2+DBY**2+DBZ**2)
74574 IF(DB.GT.EPS1) THEN
74575 C...Rescale boost vector if too close to unity.
74576 CALL PYERRM(3,'(PYROBO:) boost vector too large')
74582 DGA=1D0/SQRT(1D0-DB**2)
74584 IF(K(I,1).LE.0) GOTO 160
74589 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
74590 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
74591 P(I,1)=DP(1)+DGABP*DBX
74592 P(I,2)=DP(2)+DGABP*DBY
74593 P(I,3)=DP(3)+DGABP*DBZ
74594 P(I,4)=DGA*(DP(4)+DBP)
74595 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
74596 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
74597 V(I,1)=DV(1)+DGABV*DBX
74598 V(I,2)=DV(2)+DGABV*DBY
74599 V(I,3)=DV(3)+DGABV*DBZ
74600 V(I,4)=DGA*(DV(4)+DBV)
74607 C*********************************************************************
74610 C...Performs global manipulations on the event record, in particular
74611 C...to exclude unstable or undetectable partons/particles.
74613 SUBROUTINE PYEDIT(MEDIT)
74615 C...Double precision and integer declarations.
74616 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74617 IMPLICIT INTEGER(I-N)
74618 INTEGER PYK,PYCHGE,PYCOMP
74619 C...Parameter statement to help give large particle numbers.
74620 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74621 &KEXCIT=4000000,KDIMEN=5000000)
74623 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74624 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74625 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74626 COMMON/PYCTAG/NCT,MCT(4000,2)
74627 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
74629 DIMENSION NS(2),PTS(2),PLS(2)
74631 C...Remove unwanted partons/particles.
74632 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
74634 IF(MSTU(2).GT.0) IMAX=MSTU(2)
74635 I1=MAX(1,MSTU(1))-1
74636 DO 110 I=MAX(1,MSTU(1)),IMAX
74637 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
74638 IF(MEDIT.EQ.1) THEN
74639 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74640 ELSEIF(MEDIT.EQ.2) THEN
74641 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74643 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74644 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74645 & K(I,2).EQ.KSUSY1+39) GOTO 110
74646 ELSEIF(MEDIT.EQ.3) THEN
74647 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74649 IF(KC.EQ.0) GOTO 110
74650 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
74651 ELSEIF(MEDIT.EQ.5) THEN
74652 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
74654 IF(KC.EQ.0) GOTO 110
74655 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
74656 & KCHG(KC,2).EQ.0) GOTO 110
74659 C...Pack remaining partons/particles. Origin no longer known.
74668 IF(I1.LT.N) MSTU(3)=0
74669 IF(I1.LT.N) MSTU(70)=0
74672 C...Selective removal of class of entries. New position of retained.
74673 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
74676 K(I,3)=MOD(K(I,3),MSTU(5))
74677 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
74678 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
74679 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
74680 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
74681 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
74682 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
74683 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
74685 K(I,3)=K(I,3)+MSTU(5)*I1
74688 C...Find new event history information and replace old.
74690 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
74691 & K(I,3)/MSTU(5).EQ.0) GOTO 140
74693 130 IM=MOD(K(ID,3),MSTU(5))
74694 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
74695 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
74696 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
74700 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
74701 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
74702 & K(IM,2).EQ.94) THEN
74707 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
74708 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
74709 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
74710 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
74711 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
74712 & K(K(I,4),3)/MSTU(5)
74713 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
74714 & K(K(I,5),3)/MSTU(5)
74716 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
74717 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
74718 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
74719 KCD=MOD(K(I,4),MSTU(5))
74720 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
74721 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
74722 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
74723 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
74724 KCD=MOD(K(I,5),MSTU(5))
74725 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
74726 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
74730 C...Pack remaining entries.
74735 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
74742 C...Also update LHA1 colour tags
74745 K(I1,3)=MOD(K(I1,3),MSTU(5))
74747 IF(I.EQ.MSTU(90+IZ)) THEN
74748 MSTU(90)=MSTU(90)+1
74749 MSTU(90+MSTU(90))=I1
74750 PARU(90+MSTU(90))=PARU(90+IZ)
74754 IF(I1.LT.N) MSTU(3)=0
74755 IF(I1.LT.N) MSTU(70)=0
74758 C...Fill in some missing daughter pointers (lost in colour flow).
74759 ELSEIF(MEDIT.EQ.16) THEN
74761 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
74762 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
74763 C...Find daughters who point to mother.
74765 IF(K(I1,3).NE.I) THEN
74766 ELSEIF(K(I,4).EQ.0) THEN
74772 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74773 IF(K(I,4).NE.0) GOTO 220
74774 C...Find daughters who point to documentation version of mother.
74776 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
74777 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
74778 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
74780 IF(K(I1,3).NE.IM) THEN
74781 ELSEIF(K(I,4).EQ.0) THEN
74787 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74788 IF(K(I,4).NE.0) GOTO 220
74789 C...Find daughters who point to documentation daughters who,
74790 C...in their turn, point to documentation mother.
74794 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
74796 IF(ID1.EQ.IM) ID1=I1
74800 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
74801 ELSEIF(K(I,4).EQ.0) THEN
74807 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74810 C...Save top entries at bottom of PYJETS commonblock.
74811 ELSEIF(MEDIT.EQ.21) THEN
74812 IF(2*N.GE.MSTU(4)) THEN
74813 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
74818 K(MSTU(4)-I,J)=K(I,J)
74819 P(MSTU(4)-I,J)=P(I,J)
74820 V(MSTU(4)-I,J)=V(I,J)
74825 C...Restore bottom entries of commonblock PYJETS to top.
74826 ELSEIF(MEDIT.EQ.22) THEN
74827 DO 260 I=1,MSTU(32)
74829 K(I,J)=K(MSTU(4)-I,J)
74830 P(I,J)=P(MSTU(4)-I,J)
74831 V(I,J)=V(MSTU(4)-I,J)
74836 C...Mark primary entries at top of commonblock PYJETS as untreated.
74837 ELSEIF(MEDIT.EQ.23) THEN
74842 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
74844 IF(KH.NE.0) GOTO 280
74846 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
74847 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
74851 C...Place largest axis along z axis and second largest in xy plane.
74852 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
74853 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
74854 & P(MSTU(61),2)),0D0,0D0,0D0)
74855 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
74856 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
74857 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
74858 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
74859 IF(MEDIT.EQ.31) RETURN
74861 C...Rotate to put slim jet along +z axis.
74868 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
74869 IF(MSTU(41).GE.2) THEN
74871 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74872 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74873 & K(I,2).EQ.KSUSY1+39) GOTO 300
74874 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
74877 IS=2D0-SIGN(0.5D0,P(I,3))
74879 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
74881 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
74882 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
74884 C...Rotate to put second largest jet into -z,+x quadrant.
74886 IF(P(I,3).GE.0D0) GOTO 310
74887 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
74888 IF(MSTU(41).GE.2) THEN
74890 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74891 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74892 & K(I,2).EQ.KSUSY1+39) GOTO 310
74893 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
74896 IS=2D0-SIGN(0.5D0,P(I,1))
74897 PLS(IS)=PLS(IS)-P(I,3)
74899 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
74906 C*********************************************************************
74909 C...Gives program heading, or lists an event, or particle
74910 C...data, or current parameter values.
74912 SUBROUTINE PYLIST(MLIST)
74914 C...Double precision and integer declarations.
74915 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74916 IMPLICIT INTEGER(I-N)
74917 INTEGER PYK,PYCHGE,PYCOMP
74918 C...Parameter statement to help give large particle numbers.
74919 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74920 &KEXCIT=4000000,KDIMEN=5000000)
74922 C...HEPEVT commonblock.
74923 PARAMETER (NMXHEP=4000)
74924 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
74925 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
74926 DOUBLE PRECISION PHEP,VHEP
74929 C...User process event common block.
74931 PARAMETER (MAXNUP=500)
74932 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
74933 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
74934 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
74935 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
74936 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
74940 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74942 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74943 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
74944 COMMON/PYCTAG/NCT,MCT(4000,2)
74945 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
74946 C...Local arrays, character variables and data.
74947 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
74949 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
74951 C...Initialization printout: version number and date of last change.
74952 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
74955 IF(MLIST.EQ.0) RETURN
74958 C...List event data, including additional lines after N.
74959 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
74960 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
74961 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
74962 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
74963 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
74965 IF(MLIST.GE.2) LMX=16
74968 IF(MSTU(2).GT.0) IMAX=MSTU(2)
74969 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
74970 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
74971 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
74972 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
74974 C...Get particle name, pad it and check it is not too long.
74975 CALL PYNAME(K(I,2),CHAP)
74978 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
74982 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
74984 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
74987 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
74989 CHAC=CHDL(MDL)(1:2*LDL)//' '
74991 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
74992 & CHDL(MDL)(LDL+1:2*LDL)//' '
74993 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
74997 C...Add information on string connection.
74998 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
75002 IF(KC.NE.0) KCC=KCHG(KC,2)
75003 IF(IABS(K(I,2)).EQ.39) THEN
75004 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
75005 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
75007 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
75008 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
75009 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
75010 ELSEIF(KCC.NE.0) THEN
75012 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
75015 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
75016 & CHAC(LMX-1:LMX-1)='I'
75018 C...Write data for particle/jet.
75019 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
75020 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
75022 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
75023 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
75025 ELSEIF(MLIST.EQ.1) THEN
75026 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
75028 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
75029 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
75030 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
75031 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
75032 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
75034 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
75035 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
75036 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
75037 & ,10000),MCT(I,1),MCT(I,2)
75039 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
75041 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
75042 & ,MCT(I,1),MCT(I,2)
75044 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
75046 C...Insert extra separator lines specified by user.
75047 IF(MSTU(70).GE.1) THEN
75049 DO 110 J=1,MIN(10,MSTU(70))
75050 IF(I.EQ.MSTU(70+J)) ISEP=1
75053 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
75054 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
75055 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
75060 C...Sum of charges and momenta.
75064 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
75065 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
75066 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
75067 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
75068 ELSEIF(MLIST.EQ.1) THEN
75069 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
75070 ELSEIF(MLIST.LE.3) THEN
75071 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
75073 WRITE(MSTU(11),7000) PS(6)
75076 C...Simple listing of HEPEVT entries (mainly for test purposes).
75077 ELSEIF(MLIST.EQ.5) THEN
75078 WRITE(MSTU(11),7100)
75080 IF(ISTHEP(I).EQ.0) GOTO 140
75081 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
75082 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
75086 C...Simple listing of user-process entries (mainly for test purposes).
75087 ELSEIF(MLIST.EQ.7) THEN
75088 WRITE(MSTU(11),7300)
75090 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
75091 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
75094 C...Give simple list of KF codes defined in program.
75095 ELSEIF(MLIST.EQ.11) THEN
75096 WRITE(MSTU(11),7500)
75098 CALL PYNAME(KF,CHAP)
75099 CALL PYNAME(-KF,CHAN)
75100 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
75101 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75105 DO 170 KFLB=1,KFLA-(3-KFLS)/2
75106 KF=1000*KFLA+100*KFLB+KFLS
75107 CALL PYNAME(KF,CHAP)
75108 CALL PYNAME(-KF,CHAN)
75109 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75115 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
75116 IF(KMUL.EQ.5) KFLS=5
75118 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
75119 IF(KMUL.EQ.4) KFLR=2
75121 DO 200 KFLC=1,KFLB-1
75122 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
75123 CALL PYNAME(KF,CHAP)
75124 CALL PYNAME(-KF,CHAN)
75125 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75128 CALL PYNAME(KFK,CHAP)
75129 WRITE(MSTU(11),7600) KFK,CHAP
75131 CALL PYNAME(KFK,CHAP)
75132 WRITE(MSTU(11),7600) KFK,CHAP
75135 KF=10000*KFLR+110*KFLB+KFLS
75136 CALL PYNAME(KF,CHAP)
75137 WRITE(MSTU(11),7600) KF,CHAP
75141 CALL PYNAME(KF,CHAP)
75142 WRITE(MSTU(11),7600) KF,CHAP
75144 CALL PYNAME(KF,CHAP)
75145 WRITE(MSTU(11),7600) KF,CHAP
75151 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
75153 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
75154 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
75155 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
75156 CALL PYNAME(KF,CHAP)
75157 CALL PYNAME(-KF,CHAN)
75158 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75165 IF(KF.LT.1000000) GOTO 270
75166 CALL PYNAME(KF,CHAP)
75167 CALL PYNAME(-KF,CHAN)
75168 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
75169 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75172 C...List parton/particle data table. Check whether to be listed.
75173 ELSEIF(MLIST.EQ.12) THEN
75174 WRITE(MSTU(11),7700)
75175 DO 300 KC=1,MSTU(6)
75177 IF(KF.EQ.0) GOTO 300
75178 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
75181 C...Find particle name and mass. Print information.
75182 CALL PYNAME(KF,CHAP)
75183 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
75184 CALL PYNAME(-KF,CHAN)
75185 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
75186 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
75188 C...Particle decay: channel number, branching ratios, matrix element,
75189 C...decay products.
75190 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75192 CALL PYNAME(KFDP(IDC,J),CHAD(J))
75194 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
75199 C...List parameter value table.
75200 ELSEIF(MLIST.EQ.13) THEN
75201 WRITE(MSTU(11),8000)
75203 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
75207 C...Format statements for output on unit MSTU(11) (by default 6).
75208 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
75209 &5X,'KF orig p_x p_y p_z E m'/)
75210 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
75211 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
75212 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
75213 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
75214 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
75215 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
75216 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
75217 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
75218 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
75219 & ,' C tag AC tag'/)
75220 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
75221 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
75222 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
75223 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
75224 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
75225 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
75226 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
75227 6200 FORMAT(66X,5(1X,F12.3))
75228 6300 FORMAT(1X,78('='))
75229 6400 FORMAT(1X,130('='))
75230 6500 FORMAT(1X,65('='))
75231 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
75232 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
75233 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
75234 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
75236 7000 FORMAT(19X,'sum charge:',F6.2)
75237 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
75238 &//' I IST ID Mothers Daughters p_x p_y p_z',
75240 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
75241 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
75242 &//' I IST ID Mothers Colours p_x p_y p_z',
75244 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
75245 7500 FORMAT(///20X,'List of KF codes in program'/)
75246 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
75247 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
75248 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
75249 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
75250 &1X,'ME',3X,'Br.rat.',4X,'decay products')
75251 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
75252 &1X,1P,E13.5,3X,I2)
75253 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
75254 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
75255 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
75256 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
75261 C*********************************************************************
75264 C...Writes a logo for the program.
75268 C...Double precision and integer declarations.
75269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75270 IMPLICIT INTEGER(I-N)
75271 INTEGER PYK,PYCHGE,PYCOMP
75272 C...Parameter for length of information block.
75273 PARAMETER (IREFER=19)
75275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75276 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75277 SAVE /PYDAT1/,/PYPARS/
75278 C...Local arrays and character variables.
75280 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
75281 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
75283 C...Data on months, logo, titles, and references.
75284 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
75285 &'Oct','Nov','Dec'/
75286 DATA (LOGO(J),J=1,19)/
75288 &' *:::!!:::::::::::* ',
75289 &' *::::::!!::::::::::::::* ',
75290 &' *::::::::!!::::::::::::::::* ',
75291 &' *:::::::::!!:::::::::::::::::* ',
75292 &' *:::::::::!!:::::::::::::::::* ',
75293 &' *::::::::!!::::::::::::::::*! ',
75294 &' *::::::!!::::::::::::::* !! ',
75295 &' !! *:::!!:::::::::::* !! ',
75296 &' !! !* -><- * !! ',
75306 DATA (LOGO(J),J=20,38)/
75307 &'Welcome to the Lund Monte Carlo!',
75309 &'PPP Y Y TTTTT H H III A ',
75310 &'P P Y Y T H H I A A ',
75311 &'PPP Y T HHHHH I AAAAA',
75312 &'P Y T H H I A A',
75313 &'P Y T H H III A A',
75315 &'This is PYTHIA version x.xxx ',
75316 &'Last date of change: xx xxx 201x',
75318 &'Now is xx xxx 201x at xx:xx:xx ',
75320 &'Disclaimer: this program comes ',
75321 &'without any guarantees. Beware ',
75322 &'of errors and use common sense ',
75323 &'when interpreting results. ',
75325 &'Copyright T. Sjostrand (2011) '/
75326 DATA (REFER(J),J=1,14)/
75327 &'An archive of program versions and d',
75328 &'ocumentation is found on the web: ',
75329 &'http://www.thep.lu.se/~torbjorn/Pyth',
75333 &'When you cite this program, the offi',
75334 &'cial reference is to the 6.4 manual:',
75335 &'T. Sjostrand, S. Mrenna and P. Skand',
75336 &'s, JHEP05 (2006) 026 ',
75337 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
75338 &'-T) [hep-ph/0603175]. ',
75341 DATA (REFER(J),J=15,32)/
75342 &'Also remember that the program, to a',
75343 &' large extent, represents original ',
75344 &'physics research. Other publications',
75345 &' of special relevance to your ',
75346 &'studies may therefore deserve separa',
75350 &'Main author: Torbjorn Sjostrand; Dep',
75351 &'artment of Theoretical Physics, ',
75352 &' Lund University, Solvegatan 14A, S',
75353 &'-223 62 Lund, Sweden; ',
75354 &' phone: + 46 - 46 - 222 48 16; e-ma',
75355 &'il: torbjorn@thep.lu.se ',
75356 &'Author: Stephen Mrenna; Computing Di',
75357 &'vision, GDS Group, ',
75358 &' Fermi National Accelerator Laborat',
75359 &'ory, MS 234, Batavia, IL 60510, USA;'/
75360 DATA (REFER(J),J=33,2*IREFER)/
75361 &' phone: + 1 - 630 - 840 - 2556; e-m',
75362 &'ail: mrenna@fnal.gov ',
75363 &'Author: Peter Skands; CERN/PH-TH, CH',
75364 &'-1211 Geneva, Switzerland ',
75365 &' phone: + 41 - 22 - 767 24 47; e-ma',
75366 &'il: peter.skands@cern.ch '/
75368 C...Check that PYDATA linked (check we are in the year 20xx)
75369 IF(MSTP(183)/100.NE.20) THEN
75371 & 'Error: PYDATA has not been linked.'
75372 WRITE(*,'(1X,A)') 'Execution stopped!'
75375 C...Write current version number and current date+time.
75377 WRITE(VERS,'(I1)') MSTP(181)
75378 LOGO(28)(24:24)=VERS
75379 WRITE(SUBV,'(I3)') MSTP(182)
75380 LOGO(28)(26:28)=SUBV
75381 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
75382 WRITE(DATE,'(I2)') MSTP(185)
75383 LOGO(29)(22:23)=DATE
75384 LOGO(29)(25:27)=MONTH(MSTP(184))
75385 WRITE(YEAR,'(I4)') MSTP(183)
75386 LOGO(29)(29:32)=YEAR
75388 IF(IDATI(1).LE.0) THEN
75391 WRITE(DATE,'(I2)') IDATI(3)
75393 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
75394 WRITE(YEAR,'(I4)') IDATI(1)
75395 LOGO(31)(15:18)=YEAR
75396 WRITE(HOUR,'(I2)') IDATI(4)
75397 LOGO(31)(23:24)=HOUR
75398 WRITE(MINU,'(I2)') IDATI(5)
75399 LOGO(31)(26:27)=MINU
75400 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
75401 WRITE(SECO,'(I2)') IDATI(6)
75402 LOGO(31)(29:30)=SECO
75403 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
75407 C...Loop over lines in header. Define page feed and side borders.
75408 DO 100 ILIN=1,29+IREFER
75417 C...Separator lines and logos.
75418 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
75419 LINE(4:77)='***********************************************'//
75420 & '***************************'
75421 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
75422 LINE(6:37)=LOGO(ILIN-5)
75423 LINE(44:75)=LOGO(ILIN+14)
75424 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
75425 LINE(5:40)=REFER(2*ILIN-51)
75426 LINE(41:76)=REFER(2*ILIN-50)
75429 C...Write lines to appropriate unit.
75430 WRITE(MSTU(11),'(A79)') LINE
75436 C*********************************************************************
75439 C...Facilitates the updating of particle and decay data
75440 C...by allowing it to be done in an external file.
75442 SUBROUTINE PYUPDA(MUPDA,LFN)
75444 C...Double precision and integer declarations.
75445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75446 IMPLICIT INTEGER(I-N)
75447 INTEGER PYK,PYCHGE,PYCOMP
75449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75450 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75451 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75452 COMMON/PYDAT4/CHAF(500,2)
75454 COMMON/PYINT4/MWID(500),WIDS(500,5)
75455 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
75456 C...Local arrays, character variables and data.
75457 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
75458 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
75459 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
75460 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
75461 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
75462 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
75463 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
75465 C...Write header if not yet done.
75466 IF(MSTU(12).NE.12345) CALL PYLIST(0)
75468 C...Write information on file for editing.
75469 IF(MUPDA.EQ.1) THEN
75471 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
75472 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
75473 & MWID(KC),MDCY(KC,1)
75474 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75475 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
75476 & (KFDP(IDC,J),J=1,5)
75480 C...Read complete set of information from edited file or
75481 C...read partial set of new or updated information from edited file.
75482 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
75484 C...Reset counters.
75488 IF(MUPDA.EQ.2) THEN
75493 DO 130 KC=1,MSTU(6)
75494 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
75495 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
75499 C...Begin of loop: read new line; unknown whether particle or
75501 140 READ(LFN,5200,END=190) CHINL
75503 C...Identify particle code and whether already defined (for MUPDA=3).
75504 IF(CHINL(2:10).NE.' ') THEN
75507 IF(MUPDA.EQ.2) THEN
75520 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
75523 C...Remove duplicate old decay data.
75524 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
75525 IDCREP=MDCY(KCREP,2)
75526 NDCREP=MDCY(KCREP,3)
75528 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
75530 DO 180 I=IDCREP,NDC-NDCREP
75531 MDME(I,1)=MDME(I+NDCREP,1)
75532 MDME(I,2)=MDME(I+NDCREP,2)
75533 BRAT(I)=BRAT(I+NDCREP)
75535 KFDP(I,J)=KFDP(I+NDCREP,J)
75540 ELSEIF(KCREP.NE.0) THEN
75548 C...Study line with particle data.
75549 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
75550 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
75551 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
75552 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
75553 & MWID(KC),MDCY(KC,1)
75557 C...Study line with decay data.
75560 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
75561 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
75562 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
75563 MDCY(KC,3)=MDCY(KC,3)+1
75564 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
75565 & (KFDP(NDC,J),J=1,5)
75568 C...End of loop; ensure that PYCOMP tables are updated.
75573 C...Perform possible tests that new information is consistent.
75574 DO 220 KC=1,MSTU(6)
75576 IF(KF.EQ.0) GOTO 220
75577 WRITE(CHKF,5300) KF
75578 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
75579 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
75580 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
75582 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75583 IF(MDME(IDC,2).GT.80) GOTO 210
75585 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
75589 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
75591 ELSEIF(PYCOMP(KP).EQ.0) THEN
75596 PMS=PMS-PMAS(KPC,1)
75597 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
75601 IF(KQ.NE.0) MERR=MAX(2,MERR)
75602 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
75604 IF(MERR.EQ.3) CALL PYERRM(17,
75605 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
75606 IF(MERR.EQ.2) CALL PYERRM(17,
75607 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
75608 IF(MERR.EQ.1) CALL PYERRM(7,
75609 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
75610 BRSUM=BRSUM+BRAT(IDC)
75612 WRITE(CHTMP,5500) BRSUM
75613 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
75614 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
75615 & CHTMP(9:16)//' for KF ='//CHKF)
75618 C...Write DATA statements for inclusion in program.
75619 ELSEIF(MUPDA.EQ.4) THEN
75621 C...Find out how many codes and decay channels are actually used.
75625 IF(KCHG(I,4).NE.0) THEN
75627 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
75631 C...Initialize writing of DATA statements for inclusion in program.
75634 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
75637 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
75641 C...Loop through variables for conversion to characters.
75643 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
75644 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
75645 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
75646 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
75647 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
75648 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
75649 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
75650 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
75651 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
75652 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
75653 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
75654 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
75655 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
75656 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
75657 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
75658 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
75659 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
75660 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
75661 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
75662 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
75663 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
75664 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
75666 C...Replace variables beyond what is properly defined.
75668 IF(IDIM.GT.KCC) CHTMP=' 0'
75669 ELSEIF(IVAR.LE.8) THEN
75670 IF(IDIM.GT.KCC) CHTMP=' 0.0'
75671 ELSEIF(IVAR.LE.11) THEN
75672 IF(IDIM.GT.KCC) CHTMP=' 0'
75673 ELSEIF(IVAR.LE.13) THEN
75674 IF(IDIM.GT.NDC) CHTMP=' 0'
75675 ELSEIF(IVAR.LE.14) THEN
75676 IF(IDIM.GT.NDC) CHTMP=' 0.0'
75677 ELSEIF(IVAR.LE.19) THEN
75678 IF(IDIM.GT.NDC) CHTMP=' 0'
75679 ELSEIF(IVAR.LE.21) THEN
75680 IF(IDIM.GT.KCC) CHTMP=' '
75682 IF(IDIM.GT.KCC) CHTMP=' 0'
75685 C...Length of variable, trailing decimal zeros, quotation marks.
75689 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
75690 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
75692 CHNEW=CHTMP(LLOW:LHIG)//' '
75694 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
75697 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
75698 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
75703 CHNEW(LNEW+1:LNEW+2)='D0'
75706 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
75707 DO 260 LL=LNEW,1,-1
75708 IF(CHNEW(LL:LL).EQ.'''') THEN
75710 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
75716 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
75720 C...Form composite character string, often including repetition counter.
75721 IF(CHNEW.NE.CHOLD) THEN
75728 IF(NRPT.GE.2) LRPT=LNEW+3
75729 IF(NRPT.GE.10) LRPT=LNEW+4
75730 IF(NRPT.GE.100) LRPT=LNEW+5
75731 IF(NRPT.GE.1000) LRPT=LNEW+6
75734 WRITE(CHTMP,5400) NRPT
75736 IF(NRPT.GE.10) LRPT=2
75737 IF(NRPT.GE.100) LRPT=3
75738 IF(NRPT.GE.1000) LRPT=4
75739 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
75743 C...Add characters to end of line, to new line (after storing old line),
75744 C...or to new block of lines (after writing old block).
75745 IF(LLIN+LCOM.LE.70) THEN
75746 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
75748 ELSEIF(NLIN.LE.19) THEN
75749 CHLIN(LLIN+1:72)=' '
75752 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
75755 CHLIN(LLIN:72)='/'//' '
75757 WRITE(CHTMP,5400) IDIM-NRPT
75758 CHBLK(1)(30:33)=CHTMP(13:16)
75760 WRITE(LFN,5700) CHBLK(ILIN)
75764 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
75765 & ',I= , )/'//CHCOM(1:LCOM)//','
75766 WRITE(CHTMP,5400) IDIM-NRPT+1
75767 CHLIN(25:28)=CHTMP(13:16)
75772 C...Write final block of lines.
75773 CHLIN(LLIN:72)='/'//' '
75775 WRITE(CHTMP,5400) NDIM
75776 CHBLK(1)(30:33)=CHTMP(13:16)
75778 WRITE(LFN,5700) CHBLK(ILIN)
75783 C...Formats for reading and writing particle data.
75784 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
75785 5100 FORMAT(10X,2I5,F12.6,5I10)
75796 C*********************************************************************
75799 C...Provides various integer-valued event related data.
75803 C...Double precision and integer declarations.
75804 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75805 IMPLICIT INTEGER(I-N)
75806 INTEGER PYK,PYCHGE,PYCOMP
75808 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75809 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75810 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75811 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75813 C...Default value. For I=0 number of entries, number of stable entries
75814 C...or 3 times total charge.
75816 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
75817 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
75819 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
75821 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
75822 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
75825 ELSEIF(I.EQ.0) THEN
75827 C...For I > 0 direct readout of K matrix or charge.
75828 ELSEIF(J.LE.5) THEN
75830 ELSEIF(J.EQ.6) THEN
75833 C...Status (existing/fragmented/decayed), parton/hadron separation.
75834 ELSEIF(J.LE.8) THEN
75835 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
75836 IF(J.EQ.8) PYK=PYK*K(I,2)
75837 ELSEIF(J.LE.12) THEN
75841 IF(KC.NE.0) KQ=KCHG(KC,2)
75842 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
75843 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
75845 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
75847 C...Heaviest flavour in hadron/diquark.
75848 ELSEIF(J.EQ.13) THEN
75850 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
75851 IF(KFA.LT.10) PYK=KFA
75852 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
75853 PYK=PYK*ISIGN(1,K(I,2))
75855 C...Particle history: generation, ancestor, rank.
75856 ELSEIF(J.LE.15) THEN
75863 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
75866 ELSEIF(J.EQ.16) THEN
75868 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
75869 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
75876 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
75877 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
75879 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
75880 IF(ILP.EQ.1) GOTO 120
75882 IF(K(I1,1).EQ.12) THEN
75884 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
75885 & .AND.K(I3,2).NE.93) PYK=PYK+1
75891 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
75895 C...Particle coming from collapsing jet system or not.
75896 ELSEIF(J.EQ.17) THEN
75903 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
75904 IF(PYK.EQ.1) PYK=-1
75908 IF(KCHG(KC,2).EQ.0) GOTO 150
75909 IF(K(I1,1).NE.12) PYK=0
75910 IF(K(I1,1).NE.12) RETURN
75913 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
75915 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
75917 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
75919 C...Number of decay products. Colour flow.
75920 ELSEIF(J.EQ.18) THEN
75921 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
75922 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
75923 ELSEIF(J.LE.22) THEN
75924 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
75925 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
75926 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
75927 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
75928 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
75935 C*********************************************************************
75938 C...Provides various real-valued event related data.
75942 C...Double precision and integer declarations.
75943 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75944 IMPLICIT INTEGER(I-N)
75945 INTEGER PYK,PYCHGE,PYCOMP
75947 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75948 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75949 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75950 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75954 C...Set default value. For I = 0 sum of momenta or charges,
75955 C...or invariant mass of system.
75957 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
75958 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
75960 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
75962 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
75966 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
75970 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
75971 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
75973 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
75975 ELSEIF(I.EQ.0) THEN
75977 C...Direct readout of P matrix.
75978 ELSEIF(J.LE.5) THEN
75981 C...Charge, total momentum, transverse momentum, transverse mass.
75982 ELSEIF(J.LE.12) THEN
75983 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
75984 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
75985 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
75986 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
75987 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
75989 C...Theta and phi angle in radians or degrees.
75990 ELSEIF(J.LE.16) THEN
75991 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
75992 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
75993 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
75995 C...True rapidity, rapidity with pion mass, pseudorapidity.
75996 ELSEIF(J.LE.19) THEN
75998 IF(J.EQ.17) PMR=P(I,5)
75999 IF(J.EQ.18) PMR=PYMASS(211)
76000 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
76001 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
76004 C...Energy and momentum fractions (only to be used in CM frame).
76005 ELSEIF(J.LE.25) THEN
76006 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
76007 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
76008 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
76009 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
76010 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
76011 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
76017 C*********************************************************************
76020 C...Performs sphericity tensor analysis to give sphericity,
76021 C...aplanarity and the related event axes.
76023 SUBROUTINE PYSPHE(SPH,APL)
76025 C...Double precision and integer declarations.
76026 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76027 IMPLICIT INTEGER(I-N)
76028 INTEGER PYK,PYCHGE,PYCOMP
76029 C...Parameter statement to help give large particle numbers.
76030 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76031 &KEXCIT=4000000,KDIMEN=5000000)
76033 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76034 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76035 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76036 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76038 DIMENSION SM(3,3),SV(3,3)
76040 C...Calculate matrix to be diagonalized.
76049 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
76050 IF(MSTU(41).GE.2) THEN
76052 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76053 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76054 & K(I,2).EQ.KSUSY1+39) GOTO 140
76055 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76059 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76061 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
76062 & MAX(1D-10,PA)**(PARU(41)-2D0)
76065 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
76071 C...Very low multiplicities (0 or 1) not considered.
76073 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
76080 SM(J1,J2)=SM(J1,J2)/PS
76084 C...Find eigenvalues to matrix (third degree equation).
76085 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
76086 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
76087 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
76088 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
76089 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
76090 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
76091 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
76092 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
76093 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
76094 IF(P(N+2,4).LT.1D-5) THEN
76095 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
76101 C...Find first and last eigenvector by solving equation system.
76104 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
76106 SV(J1,J2)=SM(J1,J2)
76107 SV(J2,J1)=SM(J1,J2)
76113 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
76116 SMAX=ABS(SV(J1,J2))
76120 DO 220 J3=JA+1,JA+2
76122 RL=SV(J1,JB)/SV(JA,JB)
76124 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
76125 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
76127 SMAX=ABS(SV(J1,J2))
76131 JB2=JB+2-3*((JB+1)/3)
76132 P(N+I,JB1)=-SV(JC,JB2)
76133 P(N+I,JB2)=SV(JC,JB1)
76134 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
76136 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
76137 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76139 P(N+I,J)=SGN*P(N+I,J)/PA
76143 C...Middle axis orthogonal to other two. Fill other codes.
76144 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76145 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
76146 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
76147 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
76160 C...Calculate sphericity and aplanarity. Select storing option.
76161 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
76165 IF(MSTU(43).LE.1) MSTU(3)=3
76166 IF(MSTU(43).GE.2) N=N+3
76171 C*********************************************************************
76174 C...Performs thrust analysis to give thrust, oblateness
76175 C...and the related event axes.
76177 SUBROUTINE PYTHRU(THR,OBL)
76179 C...Double precision and integer declarations.
76180 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76181 IMPLICIT INTEGER(I-N)
76182 INTEGER PYK,PYCHGE,PYCOMP
76183 C...Parameter statement to help give large particle numbers.
76184 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76185 &KEXCIT=4000000,KDIMEN=5000000)
76187 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76188 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76189 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76190 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76192 DIMENSION TDI(3),TPR(3)
76194 C...Take copy of particles that are to be considered in thrust analysis.
76198 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
76199 IF(MSTU(41).GE.2) THEN
76201 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76202 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76203 & K(I,2).EQ.KSUSY1+39) GOTO 100
76204 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76207 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
76208 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
76218 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76220 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
76221 & P(N+NP,4)**(PARU(42)-1D0)
76222 PS=PS+P(N+NP,4)*P(N+NP,5)
76225 C...Very low multiplicities (0 or 1) not considered.
76227 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
76233 C...Loop over thrust and major. T axis along z direction in latter case.
76237 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
76239 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
76240 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
76241 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
76244 C...Find and order particles with highest p (pT for major).
76245 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
76249 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
76250 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
76251 IF(P(I,4).LE.P(ILF,4)) GOTO 140
76253 P(ILF+1,J)=P(ILF,J)
76262 C...Find and order initial axes with highest thrust (major).
76263 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
76266 NC=2**(MIN(MSTU(44),NP)-1)
76271 DO 200 ILF=1,MIN(MSTU(44),NP)
76272 SGN=P(N+NP+ILF+3,5)
76273 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
76275 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
76278 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
76279 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
76280 IF(TDS.LE.P(ILG,4)) GOTO 230
76282 P(ILG+1,J)=P(ILG,J)
76285 ILG=N+NP+MSTU(44)+4
76292 C...Iterate direction of axis until stable maximum.
76299 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
76300 IF(THP.GT.1D-10) TDI(J)=TPR(J)
76304 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
76306 TPR(J)=TPR(J)+SGN*P(I,J)
76309 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
76310 IF(THP.GE.THPS+PARU(48)) GOTO 270
76312 C...Save good axis. Try new initial axis until a number of tries agree.
76313 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
76314 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
76316 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76318 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
76324 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
76327 C...Find minor axis and value by orthogonality.
76328 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76329 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
76330 P(N+NP+3,2)=SGN*P(N+NP+2,1)
76334 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
76339 C...Fill axis information. Rotate back to original coordinate system.
76347 P(N+ILD,J)=P(N+NP+ILD,J)
76351 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
76353 C...Calculate thrust and oblateness. Select storing option.
76355 OBL=P(N+2,4)-P(N+3,4)
76358 IF(MSTU(43).LE.1) MSTU(3)=3
76359 IF(MSTU(43).GE.2) N=N+3
76364 C*********************************************************************
76367 C...Subdivides the particle content of an event into jets/clusters.
76369 SUBROUTINE PYCLUS(NJET)
76371 C...Double precision and integer declarations.
76372 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76373 IMPLICIT INTEGER(I-N)
76374 INTEGER PYK,PYCHGE,PYCOMP
76375 C...Parameter statement to help give large particle numbers.
76376 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76377 &KEXCIT=4000000,KDIMEN=5000000)
76379 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76380 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76381 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76382 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76383 C...Local arrays and saved variables.
76385 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
76387 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
76388 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
76389 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
76390 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
76391 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
76392 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
76393 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
76395 C...If first time, reset. If reentering, skip preliminaries.
76396 IF(MSTU(48).LE.0) THEN
76402 PIMASS=PMAS(PYCOMP(211),1)
76405 IF(MSTU(43).GE.2) N=N-NJET
76406 DO 110 I=N+1,N+NJET
76407 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76409 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
76412 R2ACC=PARU(45)*PS(5)**2
76418 C...Find which particles are to be considered in cluster search.
76420 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
76421 IF(MSTU(41).GE.2) THEN
76423 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76424 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76425 & K(I,2).EQ.KSUSY1+39) GOTO 140
76426 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76429 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
76430 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
76435 C...Take copy of these particles, with space left for jets later on.
76441 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
76442 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
76443 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76444 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76446 PS(J)=PS(J)+P(N+NP,J)
76456 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
76458 C...Very low multiplicities not considered.
76459 IF(NP.LT.MSTU(47)) THEN
76460 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
76465 C...Find precluster configuration. If too few jets, make harder cuts.
76467 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
76470 R2ACC=PARU(45)*PS(5)**2
76472 RINIT=1.25D0*PARU(43)
76473 IF(NP.LE.MSTU(47)+2) RINIT=0D0
76474 170 RINIT=0.8D0*RINIT
76477 DO 180 I=N+NP+1,N+2*NP
76481 C...Sum up small momentum region. Jet if enough absolute momentum.
76482 IF(MSTU(46).LE.2) THEN
76486 DO 210 I=N+NP+1,N+2*NP
76487 IF(P(I,5).GT.2D0*RINIT) GOTO 210
76491 P(N+1,J)=P(N+1,J)+P(I,J)
76494 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
76495 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
76496 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
76497 IF(NREM.EQ.0) GOTO 170
76500 C...Find fastest remaining particle.
76503 DO 230 I=N+NP+1,N+2*NP
76504 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
76509 P(N+NPRE,J)=P(IMAX,J)
76514 C...Sum up precluster around it according to pT separation.
76515 IF(MSTU(46).LE.2) THEN
76516 DO 260 I=N+NP+1,N+2*NP
76517 IF(K(I,4).NE.0) GOTO 260
76519 IF(R2.GT.RINIT**2) GOTO 260
76523 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
76526 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
76528 C...Sum up precluster around it according to mass or
76529 C...Durham pT separation.
76533 DO 280 I=N+NP+1,N+2*NP
76534 IF(K(I,4).NE.0) GOTO 280
76535 IF(MSTU(46).LE.4) THEN
76540 IF(R2.GE.R2MIN) GOTO 280
76546 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
76548 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
76555 C...Check if more preclusters to be found. Start over if too few.
76556 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
76557 IF(NREM.GT.0) GOTO 220
76560 C...Reassign all particles to nearest jet. Sum up new jet momenta.
76563 310 IF(MSTU(46).LE.1) THEN
76564 DO 330 I=N+1,N+NJET
76569 DO 360 I=N+NP+1,N+2*NP
76571 DO 340 IJET=N+1,N+NJET
76572 IF(P(IJET,5).LT.RINIT) GOTO 340
76574 IF(R2.GE.R2MIN) GOTO 340
76580 V(IMIN,J)=V(IMIN,J)+P(I,J)
76584 DO 380 I=N+1,N+NJET
76588 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76593 C...Find two closest jets.
76594 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
76595 DO 400 ITRY1=N+1,N+NJET-1
76596 DO 390 ITRY2=ITRY1+1,N+NJET
76597 IF(MSTU(46).LE.2) THEN
76598 R2=R2T(ITRY1,ITRY2)
76599 ELSEIF(MSTU(46).LE.4) THEN
76600 R2=R2M(ITRY1,ITRY2)
76602 R2=R2D(ITRY1,ITRY2)
76604 IF(R2.GE.R2MIN) GOTO 390
76611 C...If allowed, join two closest jets and start over.
76612 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
76613 IREC=MIN(IMIN1,IMIN2)
76614 IDEL=MAX(IMIN1,IMIN2)
76616 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
76618 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
76619 DO 430 I=IDEL+1,N+NJET
76624 IF(MSTU(46).GE.2) THEN
76625 DO 440 I=N+NP+1,N+2*NP
76627 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
76628 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
76634 C...Divide up broad jet if empty cluster in list of final ones.
76635 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
76636 DO 450 I=N+1,N+NJET
76639 DO 460 I=N+NP+1,N+2*NP
76640 K(N+K(I,4),5)=K(N+K(I,4),5)+1
76643 DO 470 I=N+1,N+NJET
76644 IF(K(I,5).EQ.0) IEMP=I
76650 DO 480 I=N+NP+1,N+2*NP
76651 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
76654 IF(R2.LE.R2MAX) GOTO 480
76661 P(IEMP,J)=P(ISPL,J)
76662 P(IJET,J)=P(IJET,J)-P(ISPL,J)
76664 P(IEMP,5)=P(ISPL,5)
76665 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
76666 IF(NLOOP.LE.2) GOTO 300
76671 C...If generalized thrust has not yet converged, continue iteration.
76672 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
76678 C...Reorder jets according to energy.
76679 DO 510 I=N+1,N+NJET
76684 DO 540 INEW=N+1,N+NJET
76686 DO 520 ITRY=N+1,N+NJET
76687 IF(V(ITRY,4).LE.PEMAX) GOTO 520
76696 P(INEW,J)=V(IMAX,J)
76702 C...Clean up particle-jet assignments and jet information.
76703 DO 550 I=N+NP+1,N+2*NP
76706 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
76707 K(IORI,4)=K(IORI,4)+1
76711 DO 570 I=N+1,N+NJET
76714 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
76718 IF(K(I,4).EQ.0) IEMP=I
76721 C...Select storing option. Output variables. Check for failure.
76727 PARU(63)=SQRT(R2MIN)
76728 IF(NJET.LE.1) PARU(63)=0D0
76730 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
76734 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
76735 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
76741 C*********************************************************************
76744 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
76745 C...as used for calorimeters at hadron colliders.
76747 SUBROUTINE PYCELL(NJET)
76749 C...Double precision and integer declarations.
76750 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76751 IMPLICIT INTEGER(I-N)
76752 INTEGER PYK,PYCHGE,PYCOMP
76753 C...Parameter statement to help give large particle numbers.
76754 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76755 &KEXCIT=4000000,KDIMEN=5000000)
76757 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76758 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76759 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76760 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76762 C...Loop over all particles. Find cell that was hit by given particle.
76763 PTLRAT=1D0/SINH(PARU(51))**2
76767 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
76768 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
76769 IF(MSTU(41).GE.2) THEN
76771 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76772 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76773 & K(I,2).EQ.KSUSY1+39) GOTO 110
76774 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76778 PT=SQRT(P(I,1)**2+P(I,2)**2)
76779 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
76780 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
76781 & (ETA/PARU(51)+1D0))))
76782 PHI=PYANGL(P(I,1),P(I,2))
76783 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
76784 & (PHI/PARU(1)+1D0))))
76785 IETPH=MSTU(52)*IETA+IPHI
76787 C...Add to cell already hit, or book new cell.
76789 IF(IETPH.EQ.K(IC,3)) THEN
76795 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
76796 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
76804 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
76805 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
76809 C...Smear true bin content by calorimeter resolution.
76810 IF(MSTU(53).GE.1) THEN
76813 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
76814 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
76815 & COS(PARU(2)*PYR(0))
76816 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
76818 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
76822 C...Remove cells below threshold.
76823 IF(PARU(58).GT.0D0) THEN
76827 IF(P(IC,5).GT.PARU(58)) THEN
76839 C...Find initiator cell: the one with highest pT of not yet used ones.
76843 IF(K(IC,5).NE.2) GOTO 160
76844 IF(P(IC,5).LE.ETMAX) GOTO 160
76850 IF(ETMAX.LT.PARU(52)) GOTO 220
76851 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
76852 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
76866 C...Sum up unused cells within required distance of initiator.
76868 IF(K(IC,5).EQ.0) GOTO 170
76869 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
76870 DPHIA=ABS(P(IC,2)-PHI)
76871 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
76873 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
76874 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
76876 K(NJ,4)=K(NJ,4)+K(IC,4)
76877 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
76878 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
76879 P(NJ,5)=P(NJ,5)+P(IC,5)
76882 C...Reject cluster below minimum ET, else accept.
76883 IF(P(NJ,5).LT.PARU(53)) THEN
76886 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
76888 ELSEIF(MSTU(54).LE.2) THEN
76889 P(NJ,3)=P(NJ,3)/P(NJ,5)
76890 P(NJ,4)=P(NJ,4)/P(NJ,5)
76891 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
76894 IF(K(IC,5).LT.0) K(IC,5)=0
76901 IF(K(IC,5).GE.0) GOTO 210
76902 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
76903 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
76904 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
76905 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
76911 C...Arrange clusters in falling ET sequence.
76912 220 DO 250 I=1,NJ-NC
76915 IF(K(IJ,5).EQ.0) GOTO 230
76916 IF(P(IJ,5).LT.ETMAX) GOTO 230
76924 K(N+I,4)=K(IJMAX,4)
76927 P(N+I,J)=P(IJMAX,J)
76933 C...Convert to massless or massive four-vectors.
76934 IF(MSTU(54).EQ.2) THEN
76935 DO 260 I=N+1,N+NJET
76937 P(I,1)=P(I,5)*COS(P(I,4))
76938 P(I,2)=P(I,5)*SIN(P(I,4))
76939 P(I,3)=P(I,5)*SINH(ETA)
76940 P(I,4)=P(I,5)*COSH(ETA)
76943 ELSEIF(MSTU(54).GE.3) THEN
76944 DO 270 I=N+1,N+NJET
76945 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
76949 C...Information about storage.
76953 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
76954 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
76959 C*********************************************************************
76962 C...Determines, approximately, the two jet masses that minimize
76963 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
76965 SUBROUTINE PYJMAS(PMH,PML)
76967 C...Double precision and integer declarations.
76968 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76969 IMPLICIT INTEGER(I-N)
76970 INTEGER PYK,PYCHGE,PYCOMP
76971 C...Parameter statement to help give large particle numbers.
76972 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76973 &KEXCIT=4000000,KDIMEN=5000000)
76975 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76976 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76977 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76978 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76980 DIMENSION SM(3,3),SAX(3),PS(3,5)
76993 PIMASS=PMAS(PYCOMP(211),1)
76995 C...Take copy of particles that are to be considered in mass analysis.
76997 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
76998 IF(MSTU(41).GE.2) THEN
77000 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77001 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77002 & K(I,2).EQ.KSUSY1+39) GOTO 170
77003 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77006 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
77007 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
77016 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
77017 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
77018 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
77020 C...Fill information in sphericity tensor and total momentum vector.
77023 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
77026 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77028 PS(3,J)=PS(3,J)+P(N+NP,J)
77032 C...Very low multiplicities (0 or 1) not considered.
77034 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
77039 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
77042 C...Find largest eigenvalue to matrix (third degree equation).
77045 SM(J1,J2)=SM(J1,J2)/PSS
77048 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
77049 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
77050 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
77051 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
77052 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
77053 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
77054 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
77056 C...Find largest eigenvector by solving equation system.
77058 SM(J1,J1)=SM(J1,J1)-SMA
77060 SM(J2,J1)=SM(J1,J2)
77066 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
77069 SMAX=ABS(SM(J1,J2))
77073 DO 250 J3=JA+1,JA+2
77075 RL=SM(J1,JB)/SM(JA,JB)
77077 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
77078 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
77080 SMAX=ABS(SM(J1,J2))
77084 JB2=JB+2-3*((JB+1)/3)
77085 SAX(JB1)=-SM(JC,JB2)
77086 SAX(JB2)=SM(JC,JB1)
77087 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
77089 C...Divide particles into two initial clusters by hemisphere.
77091 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
77093 IF(PSAX.LT.0D0) IS=2
77096 PS(IS,J)=PS(IS,J)+P(I,J)
77099 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
77100 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
77102 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
77106 PS(3,J)=PS(1,J)-PS(2,J)
77109 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)
77110 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
77111 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
77112 IF(PMDI.LT.PMD) THEN
77118 C...Loop back if significant reduction in sum of m^2.
77119 IF(PMD.LT.-PARU(48)*PMS) THEN
77123 PS(IS,J)=PS(IS,J)-P(IM,J)
77124 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
77130 C...Final masses and output.
77133 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
77134 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
77135 PMH=MAX(PS(1,5),PS(2,5))
77136 PML=MIN(PS(1,5),PS(2,5))
77141 C*********************************************************************
77144 C...Calculates the first few Fox-Wolfram moments.
77146 SUBROUTINE PYFOWO(H10,H20,H30,H40)
77148 C...Double precision and integer declarations.
77149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77150 IMPLICIT INTEGER(I-N)
77151 INTEGER PYK,PYCHGE,PYCOMP
77152 C...Parameter statement to help give large particle numbers.
77153 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77154 &KEXCIT=4000000,KDIMEN=5000000)
77156 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77157 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77158 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77159 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77161 C...Copy momenta for particles and calculate H0.
77166 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
77167 IF(MSTU(41).GE.2) THEN
77169 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77170 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77171 & K(I,2).EQ.KSUSY1+39) GOTO 110
77172 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77175 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
77176 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
77187 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77193 C...Very low multiplicities (0 or 1) not considered.
77195 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
77203 C...Calculate H1 - H4.
77209 DO 120 I2=I1+1,N+NP
77210 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
77211 & (P(I1,4)*P(I2,4))
77212 H10=H10+P(I1,4)*P(I2,4)*CTHE
77213 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
77214 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
77215 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
77220 C...Calculate H1/H0 - H4/H0. Output.
77223 H10=(HD+2D0*H10)/H0
77224 H20=(HD+2D0*H20)/H0
77225 H30=(HD+2D0*H30)/H0
77226 H40=(HD+2D0*H40)/H0
77231 C*********************************************************************
77234 C...Evaluates various properties of an event, with statistics
77235 C...accumulated during the course of the run and
77236 C...printed at the end.
77238 SUBROUTINE PYTABU(MTABU)
77240 C...Double precision and integer declarations.
77241 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77242 IMPLICIT INTEGER(I-N)
77243 INTEGER PYK,PYCHGE,PYCOMP
77244 C...Parameter statement to help give large particle numbers.
77245 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77246 &KEXCIT=4000000,KDIMEN=5000000)
77248 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77249 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77250 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77251 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
77252 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
77253 C...Local arrays, character variables, saved variables and data.
77254 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
77255 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
77256 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
77257 &KFDM(8),KFDC(200,0:8),NPDC(200)
77258 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
77259 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
77260 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
77261 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
77262 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
77263 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
77264 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
77265 &NEVDC/0/,NKFDC/0/,NREDC/0/
77267 C...Reset statistics on initial parton state.
77268 IF(MTABU.EQ.10) THEN
77272 C...Identify and order flavour content of initial state.
77273 ELSEIF(MTABU.EQ.11) THEN
77275 KFM1=2*IABS(MSTU(161))
77276 IF(MSTU(161).GT.0) KFM1=KFM1-1
77277 KFM2=2*IABS(MSTU(162))
77278 IF(MSTU(162).GT.0) KFM2=KFM2-1
77279 KFMN=MIN(KFM1,KFM2)
77280 KFMX=MAX(KFM1,KFM2)
77282 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
77285 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
77286 & KFMX.LT.KFIS(I,2))) THEN
77292 110 IF(IKFIS.LT.0) THEN
77295 IF(NKFIS.GE.100) RETURN
77296 DO 130 I=NKFIS,IKFIS,-1
77297 KFIS(I+1,1)=KFIS(I,1)
77298 KFIS(I+1,2)=KFIS(I,2)
77300 NPIS(I+1,J)=NPIS(I,J)
77310 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
77312 C...Count number of partons in initial state.
77315 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
77316 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
77317 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
77322 IF(IM.LE.0.OR.IM.GT.N) THEN
77324 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
77326 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
77327 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
77337 IF(NP.GE.11) NPCO=8
77338 IF(NP.GE.16) NPCO=9
77339 IF(NP.GE.26) NPCO=10
77340 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
77343 C...Write statistics on initial parton state.
77344 ELSEIF(MTABU.EQ.12) THEN
77345 FAC=1D0/MAX(1,NEVIS)
77346 WRITE(MSTU(11),5000) NEVIS
77349 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
77351 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
77352 CALL PYNAME(KFM1,CHAU)
77354 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
77356 IF(KFIS(I,1).EQ.0) KFMX=0
77358 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
77359 CALL PYNAME(KFM2,CHAU)
77361 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
77362 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
77363 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
77366 C...Copy statistics on initial parton state into /PYJETS/.
77367 ELSEIF(MTABU.EQ.13) THEN
77368 FAC=1D0/MAX(1,NEVIS)
77371 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
77373 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
77375 IF(KFIS(I,1).EQ.0) KFMX=0
77377 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
77384 P(I,J)=FAC*NPIS(I,J)
77385 V(I,J)=FAC*NPIS(I,J+5)
77399 C...Reset statistics on number of particles/partons.
77400 ELSEIF(MTABU.EQ.20) THEN
77407 C...Identify whether particle/parton is primary or not.
77408 ELSEIF(MTABU.EQ.21) THEN
77412 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
77413 MSTU(62)=MSTU(62)+1
77416 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
77418 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
77420 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
77422 ELSEIF(KC.EQ.0) THEN
77423 ELSEIF(K(K(I,3),1).EQ.13) THEN
77425 IF(IM.LE.0.OR.IM.GT.N) THEN
77427 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
77430 ELSEIF(KCHG(KC,2).EQ.0) THEN
77431 KCM=PYCOMP(K(K(I,3),2))
77433 IF(KCHG(KCM,2).NE.0) MPRI=1
77436 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
77437 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
77439 IF(K(I,1).LE.10) THEN
77441 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
77444 C...Fill statistics on number of particles/partons in event.
77446 KFS=3-ISIGN(1,K(I,2))-MPRI
77448 IF(KFA.EQ.KFFS(IP)) THEN
77451 ELSEIF(KFA.LT.KFFS(IP)) THEN
77457 220 IF(IKFFS.LT.0) THEN
77460 IF(NKFFS.GE.400) RETURN
77461 DO 240 IP=NKFFS,IKFFS,-1
77462 KFFS(IP+1)=KFFS(IP)
77464 NPFS(IP+1,J)=NPFS(IP,J)
77473 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
77476 C...Write statistics on particle/parton composition of events.
77477 ELSEIF(MTABU.EQ.22) THEN
77478 FAC=1D0/MAX(1,NEVFS)
77479 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
77481 CALL PYNAME(KFFS(I),CHAU)
77484 IF(KC.NE.0) MDCYF=MDCY(KC,1)
77485 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
77486 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
77489 C...Copy particle/parton composition information into /PYJETS/.
77490 ELSEIF(MTABU.EQ.23) THEN
77491 FAC=1D0/MAX(1,NEVFS)
77497 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
77499 P(I,J)=FAC*NPFS(I,J)
77519 C...Reset factorial moments statistics.
77520 ELSEIF(MTABU.EQ.30) THEN
77526 FM1FM(IM,IB,IP)=0D0
77527 FM2FM(IM,IB,IP)=0D0
77532 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
77533 ELSEIF(MTABU.EQ.31) THEN
77538 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
77539 IF(MSTU(41).GE.2) THEN
77541 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77542 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77543 & K(I,2).EQ.KSUSY1+39) GOTO 410
77544 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
77545 & PYCHGE(K(I,2)).EQ.0) GOTO 410
77548 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
77549 IF(MSTU(42).GE.2) PMR=P(I,5)
77550 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
77551 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
77553 IF(ABS(YETA).GT.PARU(57)) GOTO 410
77554 PHI=PYANGL(P(I,1),P(I,2))
77555 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
77556 IYETA=MAX(0,MIN(511,IYETA))
77557 IPHI=512D0*(PHI+PARU(1))/PARU(2)
77558 IPHI=MAX(0,MIN(511,IPHI))
77561 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
77564 C...Order particles in (pseudo)rapidity and/or azimuth.
77565 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
77566 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
77570 IF(NUPP.EQ.NLOW+1) THEN
77575 DO 350 I1=NUPP-1,NLOW+1,-1
77576 IF(IYETA.GE.K(I1,1)) GOTO 360
77579 360 K(I1+1,1)=IYETA
77580 DO 370 I1=NUPP-1,NLOW+1,-1
77581 IF(IPHI.GE.K(I1,2)) GOTO 380
77585 DO 390 I1=NUPP-1,NLOW+1,-1
77586 IF(IYEP.GE.K(I1,3)) GOTO 400
77596 C...Calculate sum of factorial moments in event.
77604 IF(IM.LE.2) IBIN=2**(10-IB)
77605 IF(IM.EQ.3) IBIN=4**(10-IB)
77606 IAGR=K(NLOW+1,IM)/IBIN
77608 DO 440 I=NLOW+2,NUPP+1
77610 IF(ICUT.EQ.IAGR) THEN
77614 ELSEIF(NAGR.EQ.2) THEN
77615 FEVFM(IB,1)=FEVFM(IB,1)+2D0
77616 ELSEIF(NAGR.EQ.3) THEN
77617 FEVFM(IB,1)=FEVFM(IB,1)+6D0
77618 FEVFM(IB,2)=FEVFM(IB,2)+6D0
77619 ELSEIF(NAGR.EQ.4) THEN
77620 FEVFM(IB,1)=FEVFM(IB,1)+12D0
77621 FEVFM(IB,2)=FEVFM(IB,2)+24D0
77622 FEVFM(IB,3)=FEVFM(IB,3)+24D0
77624 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
77625 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
77626 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
77628 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
77629 & (NAGR-3D0)*(NAGR-4D0)
77637 C...Add results to total statistics.
77640 IF(FEVFM(1,IP).LT.0.5D0) THEN
77642 ELSEIF(IM.LE.2) THEN
77643 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
77645 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
77647 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
77648 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
77652 NMUFM=NMUFM+(NUPP-NLOW)
77655 C...Write accumulated statistics on factorial moments.
77656 ELSEIF(MTABU.EQ.32) THEN
77657 FAC=1D0/MAX(1,NEVFM)
77658 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
77659 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
77660 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
77662 WRITE(MSTU(11),5500)
77665 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
77667 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
77668 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
77669 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
77671 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
77672 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
77675 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
77680 C...Copy statistics on factorial moments into /PYJETS/.
77681 ELSEIF(MTABU.EQ.33) THEN
77682 FAC=1D0/MAX(1,NEVFM)
77689 IF(IM.NE.2) K(I,3)=2**(IB-1)
77691 IF(IM.NE.1) K(I,4)=2**(IB-1)
77693 P(I,1)=2D0*PARU(57)/K(I,3)
77694 V(I,1)=PARU(2)/K(I,4)
77696 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
77697 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
77713 C...Reset statistics on Energy-Energy Correlation.
77714 ELSEIF(MTABU.EQ.40) THEN
77725 C...Find particles to include, with proper assumed mass.
77726 ELSEIF(MTABU.EQ.41) THEN
77732 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
77733 IF(MSTU(41).GE.2) THEN
77735 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77736 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77737 & K(I,2).EQ.KSUSY1+39) GOTO 570
77738 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
77739 & PYCHGE(K(I,2)).EQ.0) GOTO 570
77742 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
77743 IF(MSTU(42).GE.2) PMR=P(I,5)
77744 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
77745 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
77752 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
77753 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
77756 IF(NUPP.EQ.NLOW) RETURN
77758 C...Analyze Energy-Energy Correlation in event.
77759 FAC=(2D0/ECM**2)*50D0/PARU(1)
77763 DO 600 I1=NLOW+2,NUPP
77764 DO 590 I2=NLOW+1,I1-1
77765 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
77766 & (P(I1,5)*P(I2,5))
77767 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
77768 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
77769 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
77773 FE1EC(J)=FE1EC(J)+FEVEE(J)
77774 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
77775 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
77776 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
77777 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
77778 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
77782 C...Write statistics on Energy-Energy Correlation.
77783 ELSEIF(MTABU.EQ.42) THEN
77784 FAC=1D0/MAX(1,NEVEE)
77785 WRITE(MSTU(11),5700) NEVEE
77788 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
77789 FEEC2=FAC*FE1EC(51-J)
77790 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
77792 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
77793 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
77794 & FEEC2,FEES2,FEECA,FEESA
77797 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
77798 ELSEIF(MTABU.EQ.43) THEN
77799 FAC=1D0/MAX(1,NEVEE)
77806 P(I,1)=FAC*FE1EC(I)
77807 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
77808 P(I,2)=FAC*FE1EC(51-I)
77809 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
77810 P(I,3)=FAC*FE1EA(I)
77811 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
77812 P(I,4)=PARU(1)*(I-1)/50D0
77813 P(I,5)=PARU(1)*I/50D0
77828 C...Reset statistics on decay channels.
77829 ELSEIF(MTABU.EQ.50) THEN
77834 C...Identify and order flavour content of final state.
77835 ELSEIF(MTABU.EQ.51) THEN
77839 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
77846 IF(K(I,2).LT.0) KFM=KFM-1
77847 DO 650 IDS=NDS-1,1,-1
77849 IF(KFM.LT.KFDM(IDS)) GOTO 660
77850 KFDM(IDS+1)=KFDM(IDS)
77856 C...Find whether old or new final state.
77858 IF(NDS.LT.KFDC(IDC,0)) THEN
77861 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
77863 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
77866 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
77875 700 IF(IKFDC.LT.0) THEN
77877 ELSEIF(NKFDC.GE.200) THEN
77881 DO 720 IDC=NKFDC,IKFDC,-1
77882 NPDC(IDC+1)=NPDC(IDC)
77884 KFDC(IDC+1,I)=KFDC(IDC,I)
77890 KFDC(IKFDC,I)=KFDM(I)
77894 NPDC(IKFDC)=NPDC(IKFDC)+1
77896 C...Write statistics on decay channels.
77897 ELSEIF(MTABU.EQ.52) THEN
77898 FAC=1D0/MAX(1,NEVDC)
77899 WRITE(MSTU(11),5900) NEVDC
77901 DO 740 I=1,KFDC(IDC,0)
77904 IF(2*KF.NE.KFM) KF=-KF
77905 CALL PYNAME(KF,CHAU)
77907 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
77909 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
77911 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
77913 C...Copy statistics on decay channels into /PYJETS/.
77914 ELSEIF(MTABU.EQ.53) THEN
77915 FAC=1D0/MAX(1,NEVDC)
77921 K(IDC,5)=KFDC(IDC,0)
77926 DO 770 I=1,KFDC(IDC,0)
77929 IF(2*KF.NE.KFM) KF=-KF
77930 IF(I.LE.5) P(IDC,I)=KF
77931 IF(I.GE.6) V(IDC,I-5)=KF
77933 V(IDC,5)=FAC*NPDC(IDC)
77948 C...Format statements for output on unit MSTU(11) (default 6).
77949 5000 FORMAT(///20X,'Event statistics - initial state'/
77950 &20X,'based on an analysis of ',I6,' events'//
77951 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
77952 &'according to fragmenting system multiplicity'/
77953 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
77954 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
77955 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
77956 5200 FORMAT(///20X,'Event statistics - final state'/
77957 &20X,'based on an analysis of ',I7,' events'//
77958 &5X,'Mean primary multiplicity =',F10.4/
77959 &5X,'Mean final multiplicity =',F10.4/
77960 &5X,'Mean charged multiplicity =',F10.4//
77961 &5X,'Number of particles produced per event (directly and via ',
77962 &'decays/branchings)'/
77963 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
77964 &8X,'Total'/35X,'prim seco prim seco'/)
77965 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
77966 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
77967 &20X,'based on an analysis of ',I6,' events'//
77968 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
77969 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
77971 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
77972 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
77973 &20X,'based on an analysis of ',I6,' events'//
77974 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
77975 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
77976 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
77977 5900 FORMAT(///20X,'Decay channel analysis - final state'/
77978 &20X,'based on an analysis of ',I6,' events'//
77979 &2X,'Probability',10X,'Complete final state'/)
77980 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
77981 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
77982 &'or table overflow)')
77987 C*********************************************************************
77990 C...Handles the generation of an e+e- annihilation jet event.
77992 SUBROUTINE PYEEVT(KFL,ECM)
77994 C...Double precision and integer declarations.
77995 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77996 IMPLICIT INTEGER(I-N)
77997 INTEGER PYK,PYCHGE,PYCOMP
77999 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78000 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78001 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78002 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
78004 C...Check input parameters.
78005 IF(MSTU(12).NE.12345) CALL PYLIST(0)
78006 IF(KFL.LT.0.OR.KFL.GT.8) THEN
78007 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
78008 IF(MSTU(21).GE.1) RETURN
78010 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
78011 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
78012 IF(ECM.LT.ECMMIN) THEN
78013 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
78014 IF(MSTU(21).GE.1) RETURN
78017 C...Check consistency of MSTJ options set.
78018 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
78020 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
78023 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
78025 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
78029 C...Initialize alpha_strong and total cross-section.
78030 MSTU(111)=MSTJ(108)
78031 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
78033 PARU(112)=PARJ(121)
78034 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
78035 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
78036 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
78038 IF(MSTJ(116).GE.3) MSTJ(116)=1
78041 C...Add initial e+e- to event record (documentation only).
78044 IF(NTRY.GT.100) THEN
78045 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
78050 IF(MSTJ(115).GE.2) THEN
78052 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
78054 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
78058 C...Radiative photon (in initial state).
78061 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
78063 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
78064 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
78066 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
78067 K(NC,3)=MIN(MSTJ(115)/2,1)
78070 C...Virtual exchange boson (gamma or Z0).
78071 IF(MSTJ(115).GE.3) THEN
78074 IF(MSTJ(102).EQ.2) KF=23
78078 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
78084 C...Choice of flavour and jet configuration.
78085 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
78086 IF(KFLC.EQ.0) GOTO 100
78087 CALL PYXJET(ECMC,NJET,CUT)
78089 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
78091 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
78092 IF(NJET.EQ.2) MSTJ(120)=1
78094 C...Fill jet configuration and origin.
78095 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
78096 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
78098 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
78099 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
78100 &-KFLC,ECMC,X1,X2,X4,X12,X14)
78101 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
78102 &-KFLC,ECMC,X1,X2,X4,X12,X14)
78103 IF(MSTU(24).NE.0) GOTO 100
78105 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
78108 C...Angular orientation according to matrix element.
78109 IF(MSTJ(106).EQ.1) THEN
78110 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
78111 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
78112 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
78115 C...Rotation and boost from radiative photon.
78117 DBEK=-PAK/(ECM-PAK)
78118 NMIN=NC+1-MSTJ(115)/3
78119 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
78120 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
78121 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
78124 C...Generate parton shower. Rearrange along strings and check.
78125 IF(MSTJ(101).EQ.5) THEN
78126 CALL PYSHOW(N-1,N,ECMC)
78128 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
78129 IF(MSTJ(105).GE.0) MSTU(28)=0
78132 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
78135 C...Fragmentation/decay generation. Information for PYTABU.
78136 IF(MSTJ(105).EQ.1) CALL PYEXEC
78143 C*********************************************************************
78146 C...Calculates total cross-section, including initial state
78147 C...radiation effects.
78149 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
78151 C...Double precision and integer declarations.
78152 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78153 IMPLICIT INTEGER(I-N)
78154 INTEGER PYK,PYCHGE,PYCOMP
78156 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78157 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78158 SAVE /PYDAT1/,/PYDAT2/
78160 C...Status, (optimized) Q^2 scale, alpha_strong.
78162 MSTJ(119)=10*MSTJ(102)+KFL
78163 IF(MSTJ(111).EQ.0) THEN
78165 ELSEIF(MSTU(111).EQ.0) THEN
78166 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
78167 & ((33D0-2D0*MSTU(112))*PARU(111)))))
78168 Q2R=PARJ(168)*ECM**2
78170 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
78171 & (2D0*PARU(112)/ECM)**2))
78172 Q2R=PARJ(168)*ECM**2
78174 ALSPI=PYALPS(Q2R)/PARU(1)
78176 C...QCD corrections factor in R.
78177 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
78179 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
78181 ELSEIF(MSTJ(109).EQ.0) THEN
78182 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
78183 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
78184 & LOG(PARJ(168))*ALSPI**2)
78185 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
78186 RQCD=1D0+(3D0/4D0)*ALSPI
78188 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
78191 C...Calculate Z0 width if default value not acceptable.
78192 IF(MSTJ(102).GE.3) THEN
78193 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
78194 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
78197 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
78198 & (2D0*PYMASS(KFLC)/ ECM)**2))
78199 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
78200 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
78201 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
78203 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
78207 C...Calculate propagator and related constants for QFD case.
78208 POLL=1D0-PARJ(131)*PARJ(132)
78209 IF(MSTJ(102).GE.2) THEN
78210 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
78211 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
78212 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
78213 VE=4D0*PARU(102)-1D0
78214 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
78215 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
78220 C...Loop over different flavours: charge, velocity.
78225 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
78226 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
78229 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
78230 QF=KCHG(KFLC,1)/3D0
78232 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
78234 C...Calculate R and sum of charges for QED or QFD case.
78235 RQQ=RQQ+3D0*QF**2*POLL
78236 IF(MSTJ(102).LE.1) THEN
78237 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
78239 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
78240 RQV=RQV-6D0*QF*VF*SF1I
78241 RVA=RVA+3D0*(VF**2+1D0)*SF1W
78242 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
78243 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
78247 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
78249 C...Calculate cross-section, including QCD corrections.
78252 PARJ(143)=RTOT*RQCD
78253 PARJ(144)=PARJ(143)
78254 PARJ(145)=PARJ(141)*86.8D0/ECM**2
78255 PARJ(146)=PARJ(142)*86.8D0/ECM**2
78256 PARJ(147)=PARJ(143)*86.8D0/ECM**2
78257 PARJ(148)=PARJ(147)
78258 PARJ(157)=RSUM*RQCD
78262 IF(MSTJ(107).LE.0) RETURN
78264 C...Virtual cross-section.
78266 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
78267 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
78268 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
78269 &1.526D0*LOG(ECM**2/0.932D0)
78271 C...Soft and hard radiative cross-section in QED case.
78272 IF(MSTJ(102).LE.1) THEN
78273 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
78274 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
78275 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
78277 C...Soft and hard radiative cross-section in QFD case.
78279 SZM=1D0-(PARJ(123)/ECM)**2
78280 SZW=PARJ(123)*PARJ(124)/ECM**2
78281 PARJ(161)=-RQQ/RSUM
78282 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
78283 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
78284 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
78285 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
78286 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
78287 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
78288 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
78289 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
78290 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
78291 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
78292 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
78293 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
78294 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
78297 C...Total cross-section and fraction of hard photon events.
78298 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
78299 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
78300 PARJ(144)=PARJ(157)
78301 PARJ(148)=PARJ(144)*86.8D0/ECM**2
78307 C*********************************************************************
78310 C...Generates initial state photon radiation.
78312 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
78314 C...Double precision and integer declarations.
78315 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78316 IMPLICIT INTEGER(I-N)
78317 INTEGER PYK,PYCHGE,PYCOMP
78319 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78322 C...Function: cumulative hard photon spectrum in QFD case.
78323 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
78324 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
78326 C...Determine whether radiative photon or not.
78329 IF(PARJ(160).LT.PYR(0)) RETURN
78332 C...Photon energy range. Find photon momentum in QED case.
78334 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
78335 IF(MSTJ(102).LE.1) THEN
78336 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
78337 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
78339 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
78341 SZM=1D0-(PARJ(123)/ECM)**2
78342 SZW=PARJ(123)*PARJ(124)/ECM**2
78345 FXKD=1D-4*(FXKU-FXKL)
78346 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
78351 IF(FXKV.GT.FXKR) THEN
78358 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
78359 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
78363 C...Photon polar and azimuthal angle.
78364 PME=2D0*(PYMASS(11)/ECM)**2
78365 120 CTHM=PME*(2D0/PME)**PYR(0)
78366 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
78367 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
78369 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
78370 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
78371 THEK=PYANGL(CTHE,STHE)
78372 PHIK=PARU(2)*PYR(0)
78374 C...Rotation angle for hadronic system.
78376 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
78378 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
78379 &(2D0-XK*(1D0-SGN*CTHE)))
78384 C*********************************************************************
78387 C...Selects flavour for produced qqbar pair.
78389 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
78391 C...Double precision and integer declarations.
78392 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78393 IMPLICIT INTEGER(I-N)
78394 INTEGER PYK,PYCHGE,PYCOMP
78396 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78397 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78398 SAVE /PYDAT1/,/PYDAT2/
78400 C...Calculate maximum weight in QED or QFD case.
78401 IF(MSTJ(102).LE.1) THEN
78404 POLL=1D0-PARJ(131)*PARJ(132)
78405 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
78406 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
78407 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
78408 VE=4D0*PARU(102)-1D0
78409 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
78410 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
78411 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
78412 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
78413 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
78417 C...Choose flavour. Gives charge and velocity.
78420 IF(NTRY.GT.100) THEN
78421 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
78426 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
78429 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
78430 QF=KCHG(KFLC,1)/3D0
78432 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
78434 C...Calculate weight in QED or QFD case.
78435 IF(MSTJ(102).LE.1) THEN
78437 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
78439 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
78440 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
78441 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
78443 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
78446 C...Weighting or new event (radiative photon). Cross-section update.
78447 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
78448 PARJ(158)=PARJ(158)+1D0
78449 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
78450 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
78451 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
78452 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
78453 PARJ(148)=PARJ(144)*86.8D0/ECM**2
78458 C*********************************************************************
78461 C...Selects number of jets in matrix element approach.
78463 SUBROUTINE PYXJET(ECM,NJET,CUT)
78465 C...Double precision and integer declarations.
78466 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78467 IMPLICIT INTEGER(I-N)
78468 INTEGER PYK,PYCHGE,PYCOMP
78470 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78472 C...Local array and data.
78474 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
78476 C...Trivial result for two-jets only, including parton shower.
78477 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
78480 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
78481 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
78483 IF(MSTJ(109).EQ.2) CF=1D0
78484 IF(MSTJ(111).EQ.0) THEN
78487 ELSEIF(MSTU(111).EQ.0) THEN
78488 PARJ(169)=MIN(1D0,PARJ(129))
78489 Q2=PARJ(169)*ECM**2
78490 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
78491 & ((33D0-2D0*MSTU(112))*PARU(111)))))
78492 Q2R=PARJ(168)*ECM**2
78494 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
78495 Q2=PARJ(169)*ECM**2
78496 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
78497 & (2D0*PARU(112)/ECM)**2))
78498 Q2R=PARJ(168)*ECM**2
78501 C...alpha_strong for R and R itself.
78502 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
78503 IF(IABS(MSTJ(101)).EQ.1) THEN
78505 ELSEIF(MSTJ(109).EQ.0) THEN
78506 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
78507 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
78508 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
78510 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
78513 C...alpha_strong for jet rate. Initial value for y cut.
78514 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78515 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
78516 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
78517 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
78518 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
78520 C...Parametrization of first order three-jet cross-section.
78521 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
78524 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
78525 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
78526 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
78527 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
78528 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
78532 C...Parametrization of second order three-jet cross-section.
78533 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
78534 & CUT.GE.0.25D0) THEN
78536 ELSEIF(MSTJ(110).LE.1) THEN
78537 CT=LOG(1D0/CUT-2D0)
78538 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
78539 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
78541 C...Interpolation in second/first order ratio for Zhu parametrization.
78542 ELSEIF(MSTJ(110).EQ.2) THEN
78545 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
78551 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
78553 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
78556 C...Shift in second order three-jet cross-section with optimized Q^2.
78557 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
78558 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
78559 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
78561 C...Parametrization of second order four-jet cross-section.
78562 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
78565 CT=LOG(1D0/CUT-5D0)
78566 IF(CUT.LE.0.018D0) THEN
78567 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
78568 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
78570 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
78571 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
78573 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
78574 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
78575 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
78576 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
78577 & 0.002093D0*CT**3)
78578 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
78580 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
78581 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
78584 C...If negative three-jet rate, change y' optimization parameter.
78585 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
78586 & PARJ(169).LT.0.99D0) THEN
78587 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
78588 Q2=PARJ(169)*ECM**2
78589 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78593 C...If too high cross-section, use harder cuts, or fail.
78594 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
78595 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
78596 & PARJ(169).LT.0.99D0) THEN
78597 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
78598 Q2=PARJ(169)*ECM**2
78599 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78601 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
78603 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
78605 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
78606 & PARJ(154))**(-1D0/3D0)
78607 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
78611 C...Scalar gluon (first order only).
78613 ALSPI=PYALPS(ECM**2)/PARU(1)
78614 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
78616 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
78617 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
78622 C...Select number of jets.
78624 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
78626 ELSEIF(MSTJ(101).LE.0) THEN
78627 NJET=MIN(4,2-MSTJ(101))
78631 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
78632 IF(PARJ(154).GT.RNJ) NJET=4
78638 C*********************************************************************
78641 C...Selects the kinematical variables of three-jet events.
78643 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
78645 C...Double precision and integer declarations.
78646 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78647 IMPLICIT INTEGER(I-N)
78648 INTEGER PYK,PYCHGE,PYCOMP
78650 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78653 DIMENSION ZHUP(5,12)
78655 C...Coefficients of Zhu second order parametrization.
78656 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
78657 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
78658 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
78659 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
78660 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
78661 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
78662 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
78663 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
78664 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
78665 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
78666 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
78668 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
78669 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
78672 C...Event type. Mass effect factors and other common constants.
78676 QME=(2D0*PMQ/ECM)**2
78677 IF(MSTJ(109).NE.1) THEN
78679 CUTD=LOG(1D0/CUT-2D0)
78680 IF(MSTJ(109).EQ.0) THEN
78684 WTMX=MIN(20D0,37D0-6D0*CUTD)
78685 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
78693 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
78694 ALS2PI=PARU(118)/PARU(2)
78696 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
78697 & LOG(PARJ(169))*ALS2PI
78698 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
78700 C...Choose three-jet events in allowed region.
78702 110 Y13L=CUTL+CUTD*PYR(0)
78703 Y23L=CUTL+CUTD*PYR(0)
78707 IF(Y12.LE.CUT) GOTO 110
78708 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
78710 C...Second order corrections.
78711 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
78716 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
78717 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
78718 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
78719 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
78720 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
78721 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
78722 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
78723 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
78724 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
78725 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
78726 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
78727 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
78728 & TR*(2D0*CUTL/3D0-10D0/9D0)+
78729 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
78730 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
78731 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
78732 & Y13*Y23)/(Y12+Y13)**2)/WT1+
78733 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
78734 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
78735 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
78736 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
78737 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
78738 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
78739 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
78740 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
78741 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
78742 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
78744 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
78745 C...Second order corrections; Zhu parametrization of ERT.
78750 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
78754 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78755 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78756 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78757 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78760 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78761 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78762 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78763 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78765 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78766 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78767 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78768 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78769 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
78771 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
78772 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
78773 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
78776 C...Impose mass cuts (gives two jets). For fixed jet number new try.
78780 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
78781 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
78782 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
78783 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
78784 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
78786 C...Scalar gluon model (first order only, no mass effects).
78789 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
78790 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
78791 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
78792 X1=1D0-0.5D0*(X3+YD)
78793 X2=1D0-0.5D0*(X3-YD)
78794 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
78795 IF(MSTJ(102).GE.2) THEN
78796 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
78797 & X3**2*PYR(0)) NJET=2
78799 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
78805 C*********************************************************************
78808 C...Selects the kinematical variables of four-jet events.
78810 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
78812 C...Double precision and integer declarations.
78813 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78814 IMPLICIT INTEGER(I-N)
78815 INTEGER PYK,PYCHGE,PYCOMP
78817 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78820 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
78822 C...Common constants. Colour factors for QCD and Abelian gluon theory.
78824 QME=(2D0*PMQ/ECM)**2
78825 CT=LOG(1D0/CUT-5D0)
78826 IF(MSTJ(109).EQ.0) THEN
78836 C...Choice of process (qqbargg or qqbarqqbar).
78839 IF(PARJ(155).GT.PYR(0)) IT=2
78840 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
78841 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
78842 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
78843 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
78846 C...Sample the five kinematical variables (for qqgg preweighted in y34).
78847 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
78848 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
78849 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
78850 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
78851 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
78853 CP=COS(PARU(1)*PYR(0))
78856 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
78857 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
78858 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
78860 Y12=1D0-Y134-Y23-Y24
78861 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
78865 C...Calculate matrix elements for qqgg or qqqq process.
78870 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
78871 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
78872 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
78873 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
78874 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
78875 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
78876 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
78877 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
78878 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
78879 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
78880 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
78881 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
78882 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
78883 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
78884 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
78885 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
78886 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
78887 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
78888 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
78889 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
78890 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
78891 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
78892 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
78893 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
78894 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
78895 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
78896 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
78897 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
78898 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
78899 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
78900 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
78901 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
78902 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
78903 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
78904 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
78905 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
78906 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
78907 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
78908 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
78909 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
78910 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
78913 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
78914 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
78915 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
78916 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
78917 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
78918 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
78919 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
78920 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
78921 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
78922 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
78923 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
78924 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
78925 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
78926 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
78927 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
78928 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
78929 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
78930 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
78933 C...Permutations of momenta in matrix element. Weighting.
78934 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
78945 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
78956 IF(IC.LE.3) GOTO 120
78957 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
78960 C...qqgg events: string configuration and event type.
78962 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
78963 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
78964 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
78965 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
78966 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
78967 IF(ID.EQ.2) GOTO 130
78968 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
78969 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
78970 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
78971 IF(ID.EQ.2) GOTO 130
78974 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
78975 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
78978 C...Mass cuts. Kinematical variables out.
78979 IF(Y12.LE.CUT+QME) NJET=2
78980 IF(NJET.EQ.2) GOTO 150
78981 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
78982 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
78983 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
78985 X12=(1D0-Q12)*Y13+Q12*Y23
78987 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
78989 C...qqbarqqbar events: string configuration, choose new flavour.
78992 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
78993 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
78994 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
78995 IF(WTR.LT.WTD(4)) ID=4
78996 IF(ID.GE.2) GOTO 130
78999 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
79000 140 KFLN=1+INT(5D0*PYR(0))
79001 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
79002 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
79003 IF(KFLN.GT.MSTJ(104)) NJET=2
79005 QMEN=(2D0*PMQN/ECM)**2
79007 C...Mass cuts. Kinematical variables out.
79008 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
79009 IF(NJET.EQ.2) GOTO 150
79010 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
79011 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
79012 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
79013 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
79014 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
79015 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
79018 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
79020 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
79021 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
79022 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
79024 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
79029 C*********************************************************************
79032 C...Gives the angular orientation of events.
79034 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
79036 C...Double precision and integer declarations.
79037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79038 IMPLICIT INTEGER(I-N)
79039 INTEGER PYK,PYCHGE,PYCOMP
79041 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
79042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79043 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
79044 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
79046 C...Charge. Factors depending on polarization for QED case.
79048 POLL=1D0-PARJ(131)*PARJ(132)
79049 POLD=PARJ(132)-PARJ(131)
79050 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
79056 C...Factors depending on flavour, energy and polarization for QFD case.
79058 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
79059 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
79060 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
79062 VE=4D0*PARU(102)-1D0
79064 VF=AF-4D0*QF*PARU(102)
79065 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
79066 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
79067 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
79068 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
79069 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
79070 & SFW*SFF**2*(VE**2-AE**2))
79071 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
79075 C...Mass factor. Differential cross-sections for two-jet events.
79078 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
79079 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
79081 SIGU=4D0*SQRT(1D0-QME)
79082 SIGL=2D0*QME*SQRT(1D0-QME)
79088 C...Kinematical variables. Reduce four-jet event to three-jet one.
79091 X1=2D0*P(NC+1,4)/ECM
79092 X2=2D0*P(NC+3,4)/ECM
79094 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
79095 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
79096 X1=2D0*P(NC+1,4)/ECMR
79097 X2=2D0*P(NC+4,4)/ECMR
79100 C...Differential cross-sections for three-jet (or reduced four-jet).
79101 XQ=(1D0-X1)/(1D0-X2)
79102 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
79103 ST12=SQRT(1D0-CT12**2)
79104 IF(MSTJ(109).NE.1) THEN
79105 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
79106 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
79107 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
79108 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
79110 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
79111 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
79112 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
79113 SIGA=X2**2*ST12/SQ2
79114 SIGP=2D0*(X1**2-X2**2*CT12)
79116 C...Differential cross-sect for scalar gluons (no mass effects).
79120 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
79121 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
79122 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
79123 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
79124 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
79125 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
79126 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
79127 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
79128 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
79129 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
79130 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
79134 C...Upper bounds for differential cross-section.
79139 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
79140 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
79141 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
79142 &2D0*HF2A*ABS(SIGP)
79144 C...Generate angular orientation according to differential cross-sect.
79145 100 CHI=PARU(2)*PYR(0)
79146 CTHE=2D0*PYR(0)-1D0
79154 C2PHI=COS(2D0*(PHI-PARJ(134)))
79155 S2PHI=SIN(2D0*(PHI-PARJ(134)))
79156 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
79157 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
79158 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
79159 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
79160 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
79161 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
79162 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
79163 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
79168 C*********************************************************************
79171 C...Generates Upsilon and toponium decays into three gluons
79172 C...or two gluons and a photon.
79174 SUBROUTINE PYONIA(KFL,ECM)
79176 C...Double precision and integer declarations.
79177 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79178 IMPLICIT INTEGER(I-N)
79179 INTEGER PYK,PYCHGE,PYCOMP
79181 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
79182 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79183 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
79184 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
79186 C...Printout. Check input parameters.
79187 IF(MSTU(12).NE.12345) CALL PYLIST(0)
79188 IF(KFL.LT.0.OR.KFL.GT.8) THEN
79189 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
79190 IF(MSTU(21).GE.1) RETURN
79192 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
79193 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
79194 IF(MSTU(21).GE.1) RETURN
79197 C...Initial e+e- and onium state (optional).
79199 IF(MSTJ(115).GE.2) THEN
79201 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
79203 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
79207 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
79213 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
79219 C...Choose x1 and x2 according to matrix element.
79224 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
79225 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
79228 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
79229 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
79231 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
79232 MSTU(111)=MSTJ(108)
79233 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
79235 PARU(112)=PARJ(121)
79236 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
79238 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
79239 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
79242 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
79243 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
79245 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
79246 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
79249 ECMC=SQRT(1D0-X1)*ECM
79250 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
79255 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
79256 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
79257 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
79258 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
79260 IF(ECMC.LT.4D0*PARJ(127)) THEN
79264 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
79270 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
79273 C...Differential cross-sections. Upper limit for cross-section.
79274 IF(MSTJ(106).EQ.1) THEN
79276 HF1=1D0-PARJ(131)*PARJ(132)
79278 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
79279 ST13=SQRT(1D0-CT13**2)
79280 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
79281 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
79283 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
79284 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
79285 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
79287 C...Angular orientation of event.
79288 120 CHI=PARU(2)*PYR(0)
79289 CTHE=2D0*PYR(0)-1D0
79297 C2PHI=COS(2D0*(PHI-PARJ(134)))
79298 S2PHI=SIN(2D0*(PHI-PARJ(134)))
79299 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
79300 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
79301 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
79302 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
79303 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
79304 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
79305 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
79306 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
79309 C...Generate parton shower. Rearrange along strings and check.
79310 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
79311 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
79313 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
79314 IF(MSTJ(105).GE.0) MSTU(28)=0
79317 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
79320 C...Generate fragmentation. Information for PYTABU:
79321 IF(MSTJ(105).EQ.1) CALL PYEXEC
79322 MSTU(161)=110*KFLC+3
79328 C*********************************************************************
79331 C...Books a histogram.
79333 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
79335 C...Double precision declaration.
79336 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79337 IMPLICIT INTEGER(I-N)
79339 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79341 C...Local character variables.
79342 CHARACTER TITLE*(*), TITFX*60
79344 C...Check that input is sensible. Find initial address in memory.
79345 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79346 &'(PYBOOK:) not allowed histogram number')
79347 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
79348 &'(PYBOOK:) not allowed number of bins')
79349 IF(XL.GE.XU) CALL PYERRM(28,
79350 &'(PYBOOK:) x limits in wrong order')
79352 IHIST(4)=IHIST(4)+28+NX
79353 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
79354 &'(PYBOOK:) out of histogram space')
79357 C...Store histogram size and reset contents.
79361 BIN(IS+4)=(XU-XL)/NX
79364 C...Store title by conversion to integer to double precision.
79367 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
79368 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
79374 C*********************************************************************
79377 C...Fills entry in histogram.
79379 SUBROUTINE PYFILL(ID,X,W)
79381 C...Double precision declaration.
79382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79383 IMPLICIT INTEGER(I-N)
79385 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79388 C...Find initial address in memory. Increase number of entries.
79389 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79390 &'(PYFILL:) not allowed histogram number')
79392 IF(IS.EQ.0) CALL PYERRM(28,
79393 &'(PYFILL:) filling unbooked histogram')
79394 BIN(IS+5)=BIN(IS+5)+1D0
79396 C...Find bin in x, including under/overflow, and fill.
79397 IF(X.LT.BIN(IS+2)) THEN
79398 BIN(IS+6)=BIN(IS+6)+W
79399 ELSEIF(X.GE.BIN(IS+3)) THEN
79400 BIN(IS+8)=BIN(IS+8)+W
79402 BIN(IS+7)=BIN(IS+7)+W
79403 IX=(X-BIN(IS+2))/BIN(IS+4)
79404 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
79405 BIN(IS+9+IX)=BIN(IS+9+IX)+W
79411 C*********************************************************************
79414 C...Multiplies histogram contents by factor.
79416 SUBROUTINE PYFACT(ID,F)
79418 C...Double precision declaration.
79419 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79420 IMPLICIT INTEGER(I-N)
79422 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79425 C...Find initial address in memory. Multiply all contents bins.
79426 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79427 &'(PYFACT:) not allowed histogram number')
79429 IF(IS.EQ.0) CALL PYERRM(28,
79430 &'(PYFACT:) scaling unbooked histogram')
79431 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
79438 C*********************************************************************
79441 C...Performs operations between histograms.
79443 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
79445 C...Double precision declaration.
79446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79447 IMPLICIT INTEGER(I-N)
79449 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79451 C...Character variable.
79454 C...Find initial addresses in memory, and histogram size.
79455 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
79456 &'(PYFACT:) not allowed histogram number')
79458 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
79459 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
79460 NX=NINT(BIN(IS3+1))
79461 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
79463 C...Update info on number of histogram entries.
79464 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
79465 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
79466 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
79467 BIN(IS3+5)=BIN(IS1+5)
79470 C...Operations on pair of histograms: addition, subtraction,
79471 C...multiplication, division.
79472 IF(OPER.EQ.'+') THEN
79474 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
79476 ELSEIF(OPER.EQ.'-') THEN
79478 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
79480 ELSEIF(OPER.EQ.'*') THEN
79482 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
79484 ELSEIF(OPER.EQ.'/') THEN
79487 IF(ABS(FA2).LE.1D-20) THEN
79490 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
79494 C...Operations on single histogram: multiplication+addition,
79495 C...square root+addition, logarithm+addition.
79496 ELSEIF(OPER.EQ.'A') THEN
79498 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
79500 ELSEIF(OPER.EQ.'S') THEN
79502 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
79504 ELSEIF(OPER.EQ.'L') THEN
79507 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
79508 & ZMIN=0.8D0*BIN(IS1+IX)
79511 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
79514 C...Operation on two or three histograms: average and
79515 C...standard deviation.
79516 ELSEIF(OPER.EQ.'M') THEN
79518 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
79521 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
79524 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
79527 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
79531 BIN(IS1+IX)=F1*BIN(IS1+IX)
79538 C*********************************************************************
79541 C...Prints and resets all histograms.
79545 C...Double precision declaration.
79546 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79547 IMPLICIT INTEGER(I-N)
79549 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79552 C...Loop over histograms, print and reset used ones.
79553 DO 100 ID=1,IHIST(1)
79555 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
79564 C*********************************************************************
79567 C...Prints a histogram (but does not reset it).
79569 SUBROUTINE PYPLOT(ID)
79571 C...Double precision declaration.
79572 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79573 IMPLICIT INTEGER(I-N)
79575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79576 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79577 SAVE /PYDAT1/,/PYBINS/
79578 C...Local arrays and character variables.
79579 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
79580 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
79582 C...Steps in histogram scale. Character sequence.
79583 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
79584 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
79586 C...Find initial address in memory; skip if empty histogram.
79587 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
79590 IF(NINT(BIN(IS+5)).LE.0) THEN
79591 WRITE(MSTU(11),5000) ID
79595 C...Number of histogram lines and x bins.
79599 C...Extract title by conversion from double precision via integer.
79601 IEQ=NINT(BIN(IS+8+NX+IT))
79602 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
79603 & //CHAR(MOD(IEQ,256))
79606 C...Find time; print title.
79608 IF(IDATI(1).GT.0) THEN
79609 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
79611 WRITE(MSTU(11),5200) ID, TITLE
79614 C...Find minimum and maximum bin content.
79617 DO 110 IX=IS+10,IS+8+NX
79618 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
79619 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
79622 C...Determine scale and step size for y axis.
79623 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
79624 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
79625 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
79626 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
79627 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
79628 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
79631 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
79635 C...Convert bin contents to integer form; fractional fill in top row.
79637 CTA=ABS(BIN(IS+8+IX))/DY
79638 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
79639 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
79641 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
79642 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
79644 C...Print histogram row by row.
79645 DO 150 IR=IRMA,IRMI,-1
79646 IF(IR.EQ.0) GOTO 150
79649 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
79650 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
79652 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
79655 C...Print sign and value of bin contents.
79656 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
79659 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
79660 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
79662 WRITE(MSTU(11),5400) OUT
79665 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
79667 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
79670 C...Print sign and value of lower bin edge.
79671 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
79675 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
79676 & OUT(IX:IX)=CHA(11)
79677 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
79679 WRITE(MSTU(11),5600) OUT
79682 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
79684 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
79688 C...Calculate and print statistics.
79693 CTA=ABS(BIN(IS+8+IX))
79694 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
79697 CXXSUM=CXXSUM+CTA*X**2
79699 XMEAN=CXSUM/MAX(CSUM,1D-20)
79700 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
79701 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
79702 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
79704 C...Formats for output.
79705 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
79706 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
79708 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
79709 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
79710 5400 FORMAT(/8X,'Contents',3X,A100)
79711 5500 FORMAT(9X,'*10**',I2,3X,A100)
79712 5600 FORMAT(/8X,'Low edge',3X,A100)
79713 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
79714 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
79715 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
79720 C*********************************************************************
79723 C...Resets bin contents of a histogram.
79725 SUBROUTINE PYNULL(ID)
79727 C...Double precision declaration.
79728 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79729 IMPLICIT INTEGER(I-N)
79731 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79734 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
79737 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
79744 C*********************************************************************
79747 C...Dumps histogram contents on file for reading by other program.
79748 C...Can also read back own dump.
79750 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
79752 C...Double precision declaration.
79753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79754 IMPLICIT INTEGER(I-N)
79756 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79758 C...Local arrays and character variables.
79759 DIMENSION IHI(*),ISS(100),VAL(5)
79760 CHARACTER TITLE*60,FORMAT*13
79762 C...Dump all histograms that have been booked,
79763 C...including titles and ranges, one after the other.
79764 IF(MDUMP.EQ.1) THEN
79766 C...Loop over histograms and find which are wanted and booked.
79781 C...Write title, histogram size, filling statistics.
79784 IEQ=NINT(BIN(IS+8+NX+IT))
79785 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
79786 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
79788 WRITE(LFN,5100) ID,TITLE
79789 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
79790 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
79794 C...Write histogram contents, in groups of five.
79795 DO 120 IXG=1,(NX+4)/5
79799 VAL(IXV)=BIN(IS+8+IX)
79804 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
79807 C...Go to next histogram; finish.
79808 ELSEIF(NHI.GT.0) THEN
79809 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
79813 C...Read back in histograms dumped MDUMP=1.
79814 ELSEIF(MDUMP.EQ.2) THEN
79816 C...Read histogram number, title and range, and book.
79817 140 READ(LFN,5100,END=170) ID,TITLE
79818 READ(LFN,5200) NX,XL,XU
79819 CALL PYBOOK(ID,TITLE,NX,XL,XU)
79822 C...Read filling statistics.
79823 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
79824 BIN(IS+5)=DBLE(NENTRY)
79826 C...Read histogram contents, in groups of five.
79827 DO 160 IXG=1,(NX+4)/5
79828 READ(LFN,5400) (VAL(IXV),IXV=1,5)
79831 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
79835 C...Go to next histogram; finish.
79839 C...Write histogram contents in column format,
79840 C...convenient e.g. for GNUPLOT input.
79841 ELSEIF(MDUMP.EQ.3) THEN
79843 C...Find addresses to wanted histograms.
79857 IF(IS.NE.0.AND.NSS.LT.100) THEN
79860 ELSEIF(NSS.GE.100) THEN
79861 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
79862 ELSEIF(NHI.GT.0) THEN
79863 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
79867 C...Check that they have common number of x bins. Fix format.
79868 NX=NINT(BIN(ISS(1)+1))
79870 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
79871 CALL PYERRM(8,'(PYDUMP:) different number of bins')
79875 FORMAT='(1P,000E12.4)'
79876 WRITE(FORMAT(5:7),'(I3)') NSS+1
79878 C...Write histogram contents; first column x values.
79880 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
79881 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
79886 C...Formats for output.
79887 5100 FORMAT(I5,5X,A60)
79888 5200 FORMAT(I5,1P,2D12.4)
79889 5300 FORMAT(I12,1P,3D12.4)
79890 5400 FORMAT(1P,5D12.4)
79895 C*********************************************************************
79898 C...Allows users to handle STOP statemens
79900 SUBROUTINE PYSTOP(MCOD)
79902 C...Double precision and integer declarations.
79903 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79904 IMPLICIT INTEGER(I-N)
79905 INTEGER PYK,PYCHGE,PYCOMP
79907 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79911 C...Write message, then stop
79912 WRITE(MSTU(11),5000) MCOD
79916 C...Formats for output.
79917 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
79920 C*********************************************************************
79923 C...Dummy routine, which the user can replace in order to make cuts on
79924 C...the kinematics on the parton level before the matrix elements are
79925 C...evaluated and the event is generated. The cross-section estimates
79926 C...will automatically take these cuts into account, so the given
79927 C...values are for the allowed phase space region only. MCUT=0 means
79928 C...that the event has passed the cuts, MCUT=1 that it has failed.
79930 SUBROUTINE PYKCUT(MCUT)
79932 C...Double precision and integer declarations.
79933 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79934 IMPLICIT INTEGER(I-N)
79935 INTEGER PYK,PYCHGE,PYCOMP
79937 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79938 COMMON/PYINT1/MINT(400),VINT(400)
79939 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
79940 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
79942 C...Set default value (accepting event) for MCUT.
79945 C...Read out subprocess number.
79949 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
79953 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
79955 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
79957 C...Calculate x_1, x_2, x_F.
79958 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
79959 X1=SQRT(TAU)*EXP(YST)
79960 X2=SQRT(TAU)*EXP(-YST)
79962 X1=SQRT(TAUP)*EXP(YST)
79963 X2=SQRT(TAUP)*EXP(-YST)
79967 C...Calculate shat, that, uhat, p_T^2.
79973 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
79974 RPTS=4D0*VINT(71)**2/SHAT
79975 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
79978 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
79979 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
79980 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
79981 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
79983 C...Decisions by user to be put here.
79985 C...Stop program if this routine is ever called.
79986 C...You should not copy these lines to your own routine.
79987 WRITE(MSTU(11),5000)
79990 C...Format for error printout.
79991 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
79992 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
79993 &1X,'Execution stopped!')
79998 C*********************************************************************
80001 C...Dummy routine, which the user can replace in order to multiply the
80002 C...standard PYTHIA differential cross-section by a process- and
80003 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
80004 C...to generation of weighted events, with weight 1/WTXS, while for
80005 C...MSTP(142)=2 it corresponds to a modification of the underlying
80008 SUBROUTINE PYEVWT(WTXS)
80010 C...Double precision and integer declarations.
80011 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80012 IMPLICIT INTEGER(I-N)
80013 INTEGER PYK,PYCHGE,PYCOMP
80015 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80016 COMMON/PYINT1/MINT(400),VINT(400)
80017 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
80018 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
80020 C...Set default weight for WTXS.
80023 C...Read out subprocess number.
80027 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
80031 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
80033 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
80035 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
80044 C...Modifications by user to be put here.
80046 C...Stop program if this routine is ever called.
80047 C...You should not copy these lines to your own routine.
80048 WRITE(MSTU(11),5000)
80051 C...Format for error printout.
80052 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
80053 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80054 &1X,'Execution stopped!')
80059 C*********************************************************************
80062 C...Dummy routine, to be replaced by a user implementing external
80063 C...processes. Is supposed to fill the HEPRUP commonblock with info
80064 C...on incoming beams and allowed processes.
80066 C...New example: handles a standard Les Houches Events File.
80070 C...Double precision and integer declarations.
80071 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80072 IMPLICIT INTEGER(I-N)
80074 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
80075 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80078 C...User process initialization commonblock.
80080 PARAMETER (MAXPUP=100)
80081 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
80082 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
80083 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
80084 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
80088 C...Lines to read in assumed never longer than 200 characters.
80089 PARAMETER (MAXLEN=200)
80090 CHARACTER*(MAXLEN) STRING
80092 C...Format for reading lines.
80095 WRITE(STRFMT(3:5),'(I3)') MAXLEN
80097 C...Loop until finds line beginning with "<init>" or "<init ".
80098 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
80101 C...Allow indentation.
80102 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
80103 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
80104 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
80106 C...Read first line of initialization info.
80107 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
80108 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
80110 C...Read NPRUP subsequent lines with information on each process.
80112 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
80113 & XMAXUP(IPR),LPRUP(IPR)
80117 C...Error exit: give up if initalization does not work.
80118 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
80119 WRITE(*,*) ' Event generation will be stopped.'
80125 C...Old example: handles a simple Pythia 6.4 initialization file.
80127 c SUBROUTINE UPINIT
80129 C...Double precision and integer declarations.
80130 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80131 c IMPLICIT INTEGER(I-N)
80134 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80135 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80136 c SAVE /PYDAT1/,/PYPARS/
80138 C...User process initialization commonblock.
80140 c PARAMETER (MAXPUP=100)
80141 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
80142 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
80143 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
80144 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
80148 C...Read info from file.
80149 c IF(MSTP(161).GT.0) THEN
80150 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
80151 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
80152 c DO 100 IPR=1,NPRUP
80153 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
80154 c & XMAXUP(IPR),LPRUP(IPR)
80157 C...Error or prematurely reached end of file.
80158 c 110 WRITE(MSTU(11),5000)
80161 C...Else not implemented.
80163 c WRITE(MSTU(11),5100)
80167 C...Format for error printout.
80168 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
80169 c &1X,'Execution stopped!')
80170 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
80171 c &1X,'Dummy routine in PYTHIA file called instead.'/
80172 c &1X,'Execution stopped!')
80177 C*********************************************************************
80180 C...Dummy routine, to be replaced by a user implementing external
80181 C...processes. Depending on cross section model chosen, it either has
80182 C...to generate a process of the type IDPRUP requested, or pick a type
80183 C...itself and generate this event. The event is to be stored in the
80184 C...HEPEUP commonblock, including (often) an event weight.
80186 C...New example: handles a standard Les Houches Events File.
80190 C...Double precision and integer declarations.
80191 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80192 IMPLICIT INTEGER(I-N)
80194 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
80195 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80198 C...User process event common block.
80200 PARAMETER (MAXNUP=500)
80201 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
80202 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
80203 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
80204 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
80205 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
80208 C...Lines to read in assumed never longer than 200 characters.
80209 PARAMETER (MAXLEN=200)
80210 CHARACTER*(MAXLEN) STRING
80212 C...Format for reading lines.
80215 WRITE(STRFMT(3:5),'(I3)') MAXLEN
80217 C...Loop until finds line beginning with "<event>" or "<event ".
80218 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
80221 C...Allow indentation.
80222 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
80223 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
80224 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
80226 C...Read first line of event info.
80227 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
80230 C...Read NUP subsequent lines with information on each particle.
80232 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
80233 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
80234 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
80238 C...Error exit, typically when no more events.
80239 130 WRITE(*,*) ' Failed to read LHEF event information.'
80240 WRITE(*,*) ' Will assume end of file has been reached.'
80247 C...Old example: handles a simple Pythia 6.4 event file.
80249 c SUBROUTINE UPEVNT
80251 C...Double precision and integer declarations.
80252 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80253 c IMPLICIT INTEGER(I-N)
80256 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80257 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80258 c SAVE /PYDAT1/,/PYPARS/
80260 C...User process event common block.
80262 c PARAMETER (MAXNUP=500)
80263 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
80264 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
80265 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
80266 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
80267 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
80270 C...Read info from file.
80271 c IF(MSTP(162).GT.0) THEN
80272 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
80275 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
80276 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
80277 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
80280 C...Special when reached end of file or other error.
80283 C...Else not implemented.
80285 c WRITE(MSTU(11),5000)
80289 C...Format for error printout.
80290 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
80291 c &1X,'Dummy routine in PYTHIA file called instead.'/
80292 c &1X,'Execution stopped!')
80297 C*********************************************************************
80300 C...Dummy routine, to be replaced by user, to veto event generation
80301 C...on the parton level, after parton showers but before multiple
80302 C...interactions, beam remnants and hadronization is added.
80303 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
80304 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
80305 C...be undecayed at this stage; if decayed their decay products will
80306 C...have been allowed to shower.
80308 C...All partons at the end of the shower phase are stored in the
80309 C...HEPEVT commonblock. The interesting information is
80310 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
80311 C...IDHEP(I) = the particle ID code according to PDG conventions,
80312 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
80313 C...All ISTHEP entries are 1, while the rest is zeroed.
80315 C...The user decision is to be conveyed by the IVETO value.
80316 C...IVETO = 0 : retain current event and generate in full;
80317 C... = 1 : abort generation of current event and move to next.
80319 SUBROUTINE UPVETO(IVETO)
80321 C...HEPEVT commonblock.
80322 PARAMETER (NMXHEP=4000)
80323 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
80324 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
80325 DOUBLE PRECISION PHEP,VHEP
80328 C...Next few lines allow you to see what info PYVETO extracted from
80329 C...the full event record for the first two events.
80330 C...Delete if you don't want it.
80333 IF(NLIST.LE.2) THEN
80334 WRITE(*,*) ' Full event record at time of UPVETO call:'
80336 WRITE(*,*) ' Part of event record made available to UPVETO:'
80341 C...Make decision here.
80347 C*********************************************************************
80349 C*********************************************************************
80350 C... ALICE INTERFACE TO PDFLIB WITH POSSIBILITY TO SELECT NUCLEAR STRUCTURE
80353 C... THE MSTP ARRAY IN THE PYPARS COMMON BLOCK IS USED TO ENABLE AND
80354 C... SELECT THE NUCLEAR STRUCTURE FUNCTIONS.
80355 C... MSTP(52) : (D=1) CHOICE OF PROTON AND NUCLEAR STRUCTURE-FUNCTION LIBRARY
80356 C... =1: INTERNAL PYTHIA ACORDING TO MSTP(51)
80357 C... =2: PDFLIB PROTON S.F., WITH MSTP(51) = 1000XNGROUP+NSET
80358 C... MSTP( 51) = 1000XNPGROUP+NPSET
80359 C... MSTP(151) = 1000XNAGROUP+NASET
80360 C... MSTP(192) : MASS NUMBER OF NUCLEUS SIDE 1
80361 C... MSTP(193) : MASS NUMBER OF NUCLEUS SIDE 2
80364 C... MINT(124) : SIDE (1 OR 2)
80367 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
80369 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80370 IMPLICIT INTEGER(I-N)
80371 C...INTERFACE TO PDFLIB.
80372 COMMON/LW50512/QCDL4,QCDL5
80374 DOUBLE PRECISION QCDL4,QCDL5
80375 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
80377 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
80379 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80380 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80381 DOUBLE PRECISION VALUE(20)
80382 CHARACTER*20 PARM(20)
80383 WRITE(6,*) MSTP(52)
80387 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
80391 VALUE(6)=MSTP(191)/1000
80393 VALUE(7)=MOD(MSTP(191),1000)
80394 CALL PDFSET(PARM,VALUE,
80395 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
80397 > XMIN,XMAX,Q2MIN,Q2MAX)
80398 IF (MSTP(194) .EQ. 0) THEN
80399 CALL SETLHAPARM("EKS98")
80401 CALL SETLHAPARM("EPS08")
80404 WRITE(6,*) "-> PDFSET"
80405 CALL PDFSET(PARM,VALUE,
80406 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
80408 > XMIN,XMAX,Q2MIN,Q2MAX)
80415 SUBROUTINE STRUCTM_ALICE
80416 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80418 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80419 IMPLICIT INTEGER(I-N)
80420 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80421 COMMON/PYINT1/MINT(400),VINT(400)
80422 WRITE(6,*) "STRUCTM_ALICE->"
80423 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
80424 A=MSTP(191+MINT(124))
80425 WRITE(6,*) MINT(124), "-> STRUCTA ", A
80426 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80428 WRITE(6,*) MINT(124), "-> STRUCTM "
80429 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80433 C*********************************************************************
80436 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
80438 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
80439 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80440 IMPLICIT INTEGER(I-N)
80441 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
80444 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80447 C...Stop program if this routine is ever called.
80448 WRITE(MSTU(11),5000)
80451 C...Format for error printout.
80452 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80453 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
80454 &1X,'Execution stopped!')
80459 C*********************************************************************
80462 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
80465 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80466 IMPLICIT INTEGER(I-N)
80467 CHARACTER*40 VISAJE
80470 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80473 C...Assign default value.
80476 C...Stop program if this routine is ever called.
80477 WRITE(MSTU(11),5000)
80480 C...Format for error printout.
80481 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80482 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
80483 &1X,'Execution stopped!')
80488 C*********************************************************************
80491 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
80493 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
80494 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
80495 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
80497 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80498 IMPLICIT INTEGER(I-N)
80499 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
80500 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
80501 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
80503 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80506 C...Stop program if this routine is ever called.
80507 WRITE(MSTU(11),5000)
80510 C...Format for error printout.
80511 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80512 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
80513 &1X,'Execution stopped!')
80517 C*********************************************************************
80520 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80522 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
80523 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80524 IMPLICIT INTEGER(I-N)
80525 Cmssmpart = 4 # full MSSM [recommended]
80526 Cfieldren = 0 # MSbar field ren. [strongly recommended]
80527 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
80528 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
80529 Cp2approx = 0 # no approximation [recommended]
80530 Clooplevel= 2 # include 2-loop corrections
80531 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
80532 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
80535 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80538 C...Stop program if this routine is ever called.
80539 WRITE(MSTU(11),5000)
80542 C...Format for error printout.
80543 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80544 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
80545 &1X,'Execution stopped!')
80549 C*********************************************************************
80552 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80554 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
80555 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
80556 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
80557 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
80558 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80559 IMPLICIT INTEGER(I-N)
80561 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
80562 DOUBLE COMPLEX DMU,
80563 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
80567 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80570 C...Stop program if this routine is ever called.
80571 WRITE(MSTU(11),5000)
80574 C...Format for error printout.
80575 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80576 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
80577 &1X,'Execution stopped!')
80581 C*********************************************************************
80584 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80586 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
80587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80588 IMPLICIT INTEGER(I-N)
80590 C...FeynHiggs variables
80591 DOUBLE PRECISION RMHIGG(4)
80592 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
80593 DOUBLE COMPLEX DMU,
80594 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
80598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80601 C...Stop program if this routine is ever called.
80602 WRITE(MSTU(11),5000)
80605 C...Format for error printout.
80606 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80607 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
80608 &1X,'Execution stopped!')
80612 C*********************************************************************
80615 C...Dummy routine, to be replaced by user, to handle the decay of a
80616 C...polarized tau lepton.
80618 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
80619 C...IORIG is the position where the mother of the tau is stored;
80620 C... is 0 when the mother is not stored.
80621 C...KFORIG is the flavour of the mother of the tau;
80622 C... is 0 when the mother is not known.
80623 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
80624 C... e.g. in B hadron semileptonic decays the W propagator
80625 C... is not explicitly stored but the W code is still unambiguous.
80627 C...NDECAY is the number of decay products in the current tau decay.
80628 C...These decay products should be added to the /PYJETS/ common block,
80629 C...in positions N+1 through N+NDECAY. For each product I you must
80630 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
80631 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
80633 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
80635 C...Double precision and integer declarations.
80636 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80637 IMPLICIT INTEGER(I-N)
80638 INTEGER PYK,PYCHGE,PYCOMP
80640 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
80641 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80642 SAVE /PYJETS/,/PYDAT1/
80644 C...Stop program if this routine is ever called.
80645 C...You should not copy these lines to your own routine.
80646 NDECAY=ITAU+IORIG+KFORIG
80647 WRITE(MSTU(11),5000)
80650 C...Format for error printout.
80651 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
80652 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80653 &1X,'Execution stopped!')
80658 C*********************************************************************
80661 C...Finds current date and time.
80662 C...Since this task is not standardized in Fortran 77, the routine
80663 C...is dummy, to be replaced by the user. Examples are given for
80664 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
80665 C...you do not have access to suitable routines.
80667 SUBROUTINE PYTIME(IDATI)
80669 C...Double precision and integer declarations.
80670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80671 IMPLICIT INTEGER(I-N)
80672 INTEGER PYK,PYCHGE,PYCOMP
80675 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
80677 C...Example 0: if you do not have suitable routines.
80682 C...Example 1: Fortran 90 routine.
80683 C CALL DATE_AND_TIME(VALUES=IVAL)
80691 C...Example 2: DEC Fortran 77. AIX.
80692 C CALL IDATE(IMON,IDAY,IYEAR)
80696 C CALL ITIME(IHOUR,IMIN,ISEC)
80701 C...Example 3: DEC Fortran, IRIX, IRIX64.
80702 C CALL IDATE(IMON,IDAY,IYEAR)
80710 C READ(ATIME(1:2),'(I2)') IHOUR
80711 C READ(ATIME(4:5),'(I2)') IMIN
80712 C READ(ATIME(7:8),'(I2)') ISEC
80717 C...Example 4: GNU LINUX libU77, SunOS.
80718 C CALL IDATE(IDTEMP)
80719 C IDATI(1)=IDTEMP(3)
80720 C IDATI(2)=IDTEMP(2)
80721 C IDATI(3)=IDTEMP(1)
80722 C CALL ITIME(IDTEMP)
80723 C IDATI(4)=IDTEMP(1)
80724 C IDATI(5)=IDTEMP(2)
80725 C IDATI(6)=IDTEMP(3)
80727 C...Common code to ensure right century.
80728 IDATI(1)=2000+MOD(IDATI(1),100)
git://git.uio.no / u / mrichter / AliRoot.git / blob