1 C*********************************************************************
2 C*********************************************************************
6 C* The Lund Monte Carlo for Hadronic Processes **
8 C* PYTHIA version 6.1 **
10 C* Torbjorn Sjostrand **
11 C* Department of Theoretical Physics 2 **
13 C* Solvegatan 14A, S-223 62 Lund, Sweden **
14 C* phone +46 - 46 - 222 48 16 **
15 C* E-mail torbjorn@thep.lu.se **
19 C* Physics Department, UC Davis **
20 C* One Shields Avenue, Davis, CA 95616, USA **
21 C* phone + 1 - 530 - 752 - 2661 **
22 C* E-mail mrenna@physics.ucdavis.edu **
24 C* Several parts are written by Hans-Uno Bengtsson **
25 C* PYSHOW is written together with Mats Bengtsson **
26 C* advanced popcorn baryon production written by Patrik Eden **
27 C* code for virtual photons mainly written by Christer Friberg **
28 C* code for low-mass strings mainly written by Emanuel Norrbin **
29 C* Bose-Einstein code mainly written by Leif Lonnblad **
30 C* CTEQ parton distributions are by the CTEQ collaboration **
31 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
32 C* SaS photon parton distributions together with Gerhard Schuler **
33 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
34 C* MSSM Higgs mass calculation code by M. Carena, **
35 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
36 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
38 C* The latest program version and documentation is found on WWW **
39 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
41 C* Copyright Torbjorn Sjostrand, Lund 1997 **
43 C*********************************************************************
44 C*********************************************************************
46 C List of subprograms in order of appearance, with main purpose *
47 C (S = subroutine, F = function, B = block data) *
49 C B PYDATA to contain all default values *
50 C S PYTEST to test the proper functioning of the package *
51 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
53 C S PYINIT to administer the initialization procedure *
54 C S PYEVNT to administer the generation of an event *
55 C S PYSTAT to print cross-section and other information *
56 C S PYINRE to initialize treatment of resonances *
57 C S PYINBM to read in beam, target and frame choices *
58 C S PYINKI to initialize kinematics of incoming particles *
59 C S PYINPR to set up the selection of included processes *
60 C S PYXTOT to give total, elastic and diffractive cross-sect. *
61 C S PYMAXI to find differential cross-section maxima *
62 C S PYPILE to select multiplicity of pileup events *
63 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
64 C S PYGAGA to handle lepton -> lepton + gamma branchings *
65 C S PYRAND to select subprocess and kinematics for event *
66 C S PYSCAT to set up kinematics and colour flow of event *
67 C S PYSSPA to simulate initial state spacelike showers *
68 C S PYRESD to perform resonance decays *
69 C S PYMULT to generate multiple interactions *
70 C S PYREMN to add on target remnants *
71 C S PYDIFF to set up kinematics for diffractive events *
72 C S PYDISG to set up kinematics, remnant and showers for DIS *
73 C S PYDOCU to compute cross-sections and handle documentation *
74 C S PYFRAM to perform boosts between different frames *
75 C S PYWIDT to calculate full and partial widths of resonances *
76 C S PYOFSH to calculate partial width into off-shell channels *
77 C S PYRECO to handle colour reconnection in W+W- events *
78 C S PYKLIM to calculate borders of allowed kinematical region *
79 C S PYKMAP to construct value of kinematical variable *
80 C S PYSIGH to calculate differential cross-sections *
81 C S PYPDFU to evaluate parton distributions *
82 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
83 C S PYPDEL to evaluate electron parton distributions *
84 C S PYPDGA to evaluate photon parton distributions (generic) *
85 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
86 C S PYGVMD to evaluate VMD part of photon parton distributions *
87 C S PYGANO to evaluate anomalous part of photon pdf's *
88 C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
89 C S PYGDIR to evaluate direct contribution to photon pdf's *
90 C S PYPDPI to evaluate pion parton distributions *
91 C S PYPDPR to evaluate proton parton distributions *
92 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
93 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
94 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
95 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
96 C F PYGRVV auxiliary to the PYGRV* routines *
97 C F PYGRVW auxiliary to the PYGRV* routines *
98 C F PYGRVS auxiliary to the PYGRV* routines *
99 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
100 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
101 C S PYPDPO to evaluate old proton parton distributions *
102 C F PYHFTH to evaluate threshold factor for heavy flavour *
103 C S PYSPLI to find flavours left in hadron when one removed *
104 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
105 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
106 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
107 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
108 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
110 C S PYMSIN to initialize the supersymmetry simulation *
111 C S PYAPPS to determine MSSM parameters from SUGRA input *
112 C F PYRNMQ to determine running quark masses *
113 C F PYRNMT to determine running top mass *
114 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
115 C S PYINOM to calculate neutralino/chargino mass eigenstates *
116 C F PYRNM3 to determine running M3, gluino mass *
117 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
118 C S PYHGGM to determine Higgs mass spectrum *
119 C S PYSUBH to determine Higgs masses in the MSSM *
120 C S PYPOLE to determine Higgs masses in the MSSM *
121 C S PYVACU to determine Higgs masses in the MSSM *
122 C S PYRGHM auxiliary to PYVACU *
123 C S PYGFXX auxiliary to PYRGHM *
124 C F PYFINT auxiliary to PYVACU *
125 C F PYFISB auxiliary to PYFINT *
126 C S PYSFDC to calculate sfermion decay partial widths *
127 C S PYGLUI to calculate gluino decay partial widths *
128 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
129 C S PYTBBC to calculate 3-body decay of gluino to chargino *
130 C S PYNJDC to calculate neutralino decay partial widths *
131 C S PYCJDC to calculate chargino decay partial widths *
132 C F PYXXZ5 auxiliary for neutralino 3-body decay *
133 C F PYXXW5 auxiliary for ino charge change 3-body decay *
134 C F PYXXGA auxiliary for ino -> ino + gamma decay *
135 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
136 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
137 C F PYXXZ2 auxiliary for chargino 3-body decay *
138 C S PYHEXT to calculate non-SM Higgs decay partial widths *
139 C F PYH2XX auxiliary for H -> ino + ino decay *
140 C F PYGAUS to perform Gaussian integration *
141 C F PYSIMP to perform Simpson integration *
142 C F PYLAMF to evaluate the lambda kinematics function *
143 C S PYTBDY to perform 3-body decay of gauginos *
144 C S PYTECM to calculate techni_rho/omega masses *
145 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
147 C S PY1ENT to fill one entry (= parton or particle) *
148 C S PY2ENT to fill two entries *
149 C S PY3ENT to fill three entries *
150 C S PY4ENT to fill four entries *
151 C S PY2FRM to interface to generic two-fermion generator *
152 C S PY4FRM to interface to generic four-fermion generator *
153 C S PY6FRM to interface to generic six-fermion generator *
154 C S PY4JET to generate a shower from a given 4-parton config *
155 C S PY4JTW to evaluate the weight od a shower history for above *
156 C S PY4JTS to set up the parton configuration for above *
157 C S PYJOIN to connect entries with colour flow information *
158 C S PYGIVE to fill (or query) commonblock variables *
159 C S PYEXEC to administrate fragmentation and decay chain *
160 C S PYPREP to rearrange showered partons along strings *
161 C S PYSTRF to do string fragmentation of jet system *
162 C S PYINDF to do independent fragmentation of one or many jets *
163 C S PYDECY to do the decay of a particle *
164 C S PYDCYK to select parton and hadron flavours in decays *
165 C S PYKFDI to select parton and hadron flavours in fragm *
166 C S PYNMES to select number of popcorn mesons *
167 C S PYKFIN to calculate falvour prod. ratios from input params. *
168 C S PYPTDI to select transverse momenta in fragm *
169 C S PYZDIS to select longitudinal scaling variable in fragm *
170 C S PYSHOW to do timelike parton shower evolution *
171 C S PYBOEI to include Bose-Einstein effects (crudely) *
172 C S PYBESQ auxiliary to PYBOEI *
173 C F PYMASS to give the mass of a particle or parton *
174 C F PYMRUN to give the running MSbar mass of a quark *
175 C S PYNAME to give the name of a particle or parton *
176 C F PYCHGE to give three times the electric charge *
177 C F PYCOMP to compress standard KF flavour code to internal KC *
178 C S PYERRM to write error messages and abort faulty run *
179 C F PYALEM to give the alpha_electromagnetic value *
180 C F PYALPS to give the alpha_strong value *
181 C F PYANGL to give the angle from known x and y components *
182 C F PYR to provide a random number generator *
183 C S PYRGET to save the state of the random number generator *
184 C S PYRSET to set the state of the random number generator *
185 C S PYROBO to rotate and/or boost an event *
186 C S PYEDIT to remove unwanted entries from record *
187 C S PYLIST to list event record or particle data *
188 C S PYLOGO to write a logo *
189 C S PYUPDA to update particle data *
190 C F PYK to provide integer-valued event information *
191 C F PYP to provide real-valued event information *
192 C S PYSPHE to perform sphericity analysis *
193 C S PYTHRU to perform thrust analysis *
194 C S PYCLUS to perform three-dimensional cluster analysis *
195 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
196 C S PYJMAS to give high and low jet mass of event *
197 C S PYFOWO to give Fox-Wolfram moments *
198 C S PYTABU to analyze events, with tabular output *
200 C S PYEEVT to administrate the generation of an e+e- event *
201 C S PYXTEE to give the total cross-section at given CM energy *
202 C S PYRADK to generate initial state photon radiation *
203 C S PYXKFL to select flavour of primary qqbar pair *
204 C S PYXJET to select (matrix element) jet multiplicity *
205 C S PYX3JT to select kinematics of three-jet event *
206 C S PYX4JT to select kinematics of four-jet event *
207 C S PYXDIF to select angular orientation of event *
208 C S PYONIA to perform generation of onium decay to gluons *
210 C S PYBOOK to book a histogram *
211 C S PYFILL to fill an entry in a histogram *
212 C S PYFACT to multiply histogram contents by a factor *
213 C S PYOPER to perform operations between histograms *
214 C S PYHIST to print and reset all histograms *
215 C S PYPLOT to print a single histogram *
216 C S PYNULL to reset contents of a single histogram *
217 C S PYDUMP to dump histogram contents onto a file *
219 C S PYKCUT dummy routine for user kinematical cuts *
220 C S PYEVWT dummy routine for weighting events *
221 C S PYUPIN dummy routine to initialize a user process *
222 C S PYUPEV dummy routine to generate a user process event *
223 C S PDFSET dummy routine to be removed when using PDFLIB *
224 C S STRUCTM dummy routine to be removed when using PDFLIB *
225 C S STRUCTP dummy routine to be removed when using PDFLIB *
226 C S PYTAUD dummy routine for interface to tau decay libraries *
227 C S PYTIME dummy routine for giving date and time *
229 C*********************************************************************
231 C*********************************************************************
234 C...Default values for switches and parameters,
235 C...and particle, decay and process data.
239 C...Double precision and integer declarations.
240 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
241 IMPLICIT INTEGER(I-N)
242 INTEGER PYK,PYCHGE,PYCOMP
244 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
245 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
246 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
247 COMMON/PYDAT4/CHAF(500,2)
249 COMMON/PYDATR/MRPY(6),RRPY(100)
250 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
251 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
252 COMMON/PYINT1/MINT(400),VINT(400)
253 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
254 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
255 COMMON/PYINT4/MWID(500),WIDS(500,5)
256 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
257 COMMON/PYINT6/PROC(0:500)
259 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
260 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
261 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
263 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
264 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
265 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
266 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYBINS/
268 C...PYDAT1, containing status codes and most parameters.
270 & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
271 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
272 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
273 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
274 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
275 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
276 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
278 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
279 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
281 DATA (PARU(I),I=1,100)/
282 & 3.141592653589793D0, 6.283185307179586D0,
283 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
284 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
285 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
286 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
287 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
288 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
289 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
291 DATA (PARU(I),I=101,200)/
292 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
293 & 0D0, 0D0, 0D0, 0D0, 0D0,
294 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
295 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
296 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
297 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
298 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
299 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
300 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
301 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
302 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
303 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
305 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
306 1 4, 2, 0, 1, 0, 2, 2, 0, 0, 0,
307 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
308 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
309 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
310 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
312 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
313 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
316 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
317 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
318 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
319 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
320 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,0D0,
321 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0,
322 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
323 5 -0.00001D0, -0.00001D0, -0.00001D0, 1.0D0, 0D0,
324 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
325 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0, 0D0, 0D0,
326 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
327 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
328 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
329 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
330 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
331 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
332 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
336 7 0D0, 200D0, 200D0, .333D0, .05D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
337 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
338 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
339 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
342 C...PYDAT2, with particle data and flavour treatment parameters.
343 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
344 &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,5*0,2*6,3,20*0,2,-1,
345 &20*0,4*3,8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,
346 &3*0,4,3*3,6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,
347 &2*4,2*3,2*6,3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,
348 &2*1,2*0,2*3,0,3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,
349 &2*0,2*-3,2*0,-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,
350 &3*0,3,2*0,3,0,3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,
351 &4*0,3,2*0,3,0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
352 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
353 &3*0,-1,4*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
354 &-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,
356 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
357 &11*0,1,2*0,1,5*0,6*1,15*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,
358 &12*1,3*0,102*1,2*0,2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,
359 &0,4*1,3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
360 DATA (KCHG(I,4),I= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
361 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
362 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
363 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
364 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
365 &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
366 &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
367 &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
368 &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
369 &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
370 &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
371 &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
372 &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
373 &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
374 &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
375 &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
376 &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
377 &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
378 &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
379 &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
380 DATA (KCHG(I,4),I= 294, 500)/20443,20513,20523,20533,20543,20553,
381 &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
382 &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
383 &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
384 &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
385 &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
386 DATA (PMAS(I,1),I= 1, 211)/0.33D0,0.33D0,0.50D0,1.50D0,
387 &4.80D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,
388 &0D0,400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0,
389 &3*300D0,350D0,200D0,5000D0,10*0D0,3*110D0,3*210D0,4*0D0,2*200D0,
390 &4*750D0,16*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,
391 &0.49767D0,0D0,0.13957D0,0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,
392 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
393 &0D0,0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
394 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,0D0,2.9798D0,
395 &3.09688D0,3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,
396 &5.83D0,5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,
397 &9.4603D0,9.9132D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,
398 &0.93957D0,1.233D0,0.77133D0,0D0,0.93827D0,1.232D0,1.231D0,
399 &0.80473D0,0.92953D0,1.19744D0,1.3872D0,1.11568D0,0.80473D0,
400 &0.92953D0,1.19255D0,1.3837D0,1.18937D0,1.3828D0,1.09361D0,
401 &1.3213D0,1.535D0,1.3149D0,1.5318D0,1.67245D0,1.96908D0,2.00808D0,
402 &2.4521D0,2.5D0,2.2849D0,2.4703D0,1.96908D0,2.00808D0,2.4535D0,
403 &2.5D0,2.4529D0,2.5D0,2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,
404 &2.55D0,2.63D0,2.704D0,2.8D0,3.27531D0,3.59798D0,3.65648D0,
405 &3.59798D0,3.65648D0,3.78663D0,3.82466D0,4.91594D0,5.38897D0/
406 DATA (PMAS(I,1),I= 212, 500)/5.40145D0,5.8D0,5.81D0,5.641D0,
407 &5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0,5.81D0,
408 &5.84D0,7.00575D0,5.56725D0,5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,
409 &6.12D0,6.13D0,7.19099D0,6.67143D0,6.67397D0,7.03724D0,7.0485D0,
410 &7.03724D0,7.0485D0,7.21101D0,7.219D0,8.30945D0,8.31325D0,
411 &10.07354D0,10.42272D0,10.44144D0,10.42272D0,10.44144D0,
412 &10.60209D0,10.61426D0,11.70767D0,11.71147D0,15.11061D0,0.9835D0,
413 &1.231D0,0.9835D0,1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,
414 &1.29D0,2*1.4D0,2.272D0,2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,
415 &3.4151D0,3.46D0,5.68D0,5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,
416 &7.3D0,9.8598D0,9.875D0,2*1.23D0,1.282D0,2*1.402D0,1.427D0,
417 &2*2.372D0,2.56D0,3.5106D0,2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,
418 &10.0233D0,32*500D0,4*400D0,163*0D0/
419 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39883D0,16*0D0,2.48009D0,
420 &2.07002D0,0.00237D0,6*0D0,14.54848D0,0D0,16.6708D0,8.42842D0,
421 &4.92026D0,5.75967D0,0.10158D0,0.39162D0,417.4648D0,10*0D0,
422 &0.04104D0,0.0105D0,0.02807D0,0.82101D0,0.64973D0,0.1575D0,4*0D0,
423 &0.88161D0,0.88001D0,19.33905D0,39*0D0,0.151D0,0.107D0,3*0D0,
424 &0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0,2*0D0,0.0505D0,0.109D0,
425 &0D0,0.0498D0,0.098D0,0D0,0.0002D0,0.00443D0,0.076D0,2*0D0,
426 &0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0,0.0013D0,0D0,0.002D0,
427 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,4*0D0,0.12D0,
428 &4*0D0,0.12D0,3*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
429 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
430 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
431 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
432 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
433 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
434 &2.65171D0,2.65499D0,0.42901D0,0.41917D0,163*0D0/
435 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98835D0,16*0D0,24.8009D0,
436 &20.70015D0,0.02369D0,6*0D0,145.48484D0,0D0,166.70801D0,
437 &84.28416D0,49.20256D0,57.59671D0,1.0158D0,3.91624D0,4174.64797D0,
438 &10*0D0,0.41042D0,0.10504D0,0.28068D0,8.21005D0,6.49728D0,
439 &1.57496D0,4*0D0,8.81606D0,8.80013D0,193.39048D0,39*0D0,0.4D0,
440 &0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0,0.12D0,
441 &0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,2*0D0,
442 &0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
443 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0,3*0D0,
444 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
445 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
446 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
447 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
448 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
449 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
450 &26.51715D0,26.54994D0,4.29011D0,4.19173D0,163*0D0/
451 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
452 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,0D0,7804.5D0,6*0D0,
453 &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
454 &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*0D0,
455 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
456 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
457 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
458 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,83*0D0,163*0D0/
460 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
461 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
462 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
463 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
464 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
465 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
466 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
467 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
468 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
469 9 0.0099D0, 0.0056D0, 0.199D0, 1.35D0, 4.5D0, 5*0D0,
470 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
471 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
472 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
474 4 0.2D0, 0.5D0, 8*0D0,
476 DATA ((VCKM(I,J),J=1,4),I=1,4)/
477 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
478 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
479 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
480 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
482 C...PYDAT3, with particle decay parameters and data.
483 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
484 &7*1,10*0,6*1,4*0,3*1,19*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,
485 &12*1,0,18*1,0,1,4*0,1,3*0,2*1,2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,
486 &5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,
488 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,56,66,2*0,76,80,82,
489 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,416,
490 &496,523,526,527,10*0,536,544,550,558,582,608,4*0,632,639,646,
491 &19*0,658,659,663,16*0,672,674,679,688,0,697,699,701,0,708,716,
492 &722,731,733,735,738,748,754,757,0,768,774,785,791,854,857,865,
493 &926,928,936,969,971,0,975,976,979,981,1017,1018,1026,1062,1063,
494 &1071,1110,1111,1115,1146,1147,1151,1152,1161,0,1163,4*0,1164,3*0,
495 &1167,1170,2*0,1171,1173,1176,2*0,1180,1181,1184,1187,0,1190,1195,
496 &1197,1200,1202,2*0,1206,1207,1208,1284,2*0,1288,1289,1290,1291,
497 &1292,2*0,1296,1297,1299,1300,1302,1306,0,1307,1311,1315,1319,
498 &1323,1327,1331,2*0,1335,1336,1337,1354,1363,2*0,1372,1373,1374,
499 &1375,1376,1385,2*0,1394,1395,1396,1397,1398,1407,1408,2*0,1417,
500 &1426,1435,1444,1453,1462,1471,1480,0,1489,1498,1507,1516,1525,
501 &1534,1543,1552,1561,1570,1571,1572,1573,1574,1579,1582,1584,1589,
502 &1591,1596,1603,1607,1609,1611,1613,1615,1617,1619,1621,1622,1624,
503 &1626,1628,1630,1632,1634,1636,1638,1640,1641,1643,1645,1659,1661,
504 &1663,1667,1669,1671,1673,1675,1677,1679,1681,1683,1685,1696,1710,
505 &1722,1734,1746,1758,1770,1785,1796,1807,1818,1829,1840,1851,1912,
506 &1919,2021,2077,2195,2329,0,2400,2416,2432,2448,2464,2480,2496,0,
507 &2511,0,2526,0,2541,2545,2549,2552,163*0/
508 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
509 &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,8,6,8,24,26,24,
510 &4*0,2*7,12,19*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,
511 &11,0,6,11,6,63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,
512 &1,4,1,9,2,0,1,4*0,3,3*0,3,1,2*0,2,3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,
513 &2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,
514 &2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,
515 &2*2,14,2*2,4,9*2,11,14,5*12,15,6*11,61,7,102,56,118,134,71,0,
516 &6*16,15,0,15,0,15,0,2*4,3,2,163*0/
517 DATA (MDME(I,1),I= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
518 &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,
519 &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,
520 &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,3*1,
521 &4*-1,6*1,2*-1,3*1,-1,8*1,62*1,6*1,2*-1,3*1,-1,6*1,62*1,3*1,-1,
522 &3*1,-1,1,18*1,8*1,2*-1,2*1,-1,36*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,
523 &3*1,5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,1151*1,2*-1,132*1,2*-1,635*1,
525 DATA (MDME(I,2),I= 1,4000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
526 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
527 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
528 &8*32,14*0,16*32,7*0,8*32,12*0,62*53,8*32,10*0,62*53,4*32,5*0,
529 &18*53,3*32,0,6*32,3*0,4*32,3*0,4*32,3*0,4*32,3*0,32,8*0,8*32,
530 &14*0,16*32,12*0,8*32,22*0,9*32,3*0,12,2*42,2*11,9*42,0,2,3,15*0,
531 &4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,
532 &1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,
533 &12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,
534 &2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,
535 &2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,
536 &2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,
537 &2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,
538 &162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,
540 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
541 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
542 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
543 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
544 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
545 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
546 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
547 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
548 &0.00025D0,35*0D0,0.154075D0,0.119483D0,0.154072D0,0.119346D0,
549 &0.152196D0,3*0D0,0.033549D0,0.066752D0,0.033549D0,0.066752D0,
550 &0.033473D0,0.066752D0,2*0D0,0.321502D0,0.016502D0,2*0D0,
551 &0.016509D0,0.320778D0,2*0D0,0.00001D0,0.000591D0,6*0D0,
552 &2*0.108062D0,0.107983D0,0D0,0.000001D0,0D0,0.000327D0,0.053489D0,
553 &0.852249D0,4*0D0,0.000244D0,0.06883D0,0D0,0.023981D0,0.000879D0,
554 &65*0D0,0.145869D0,0.113303D0,0.145869D0,0.113298D0,0.14581D0,
555 &0.049013D0,2*0D0,0.032007D0,0.063606D0,0.032007D0,0.063606D0,
556 &0.032004D0,0.063606D0,8*0D0,0.251276D0,0.012903D0,0.000006D0,0D0,
557 &0.012903D0,0.250816D0,0.00038D0,0D0,0.000008D0,0.000465D0,
558 &0.215459D0,5*0D0,2*0.085262D0,0.08526D0,7*0D0,0.000046D0,
559 &0.000754D0,5*0D0,0.000074D0,0D0,0.000439D0,0.000015D0,0.000061D0/
560 DATA (BRAT(I) ,I= 349, 642)/0.306171D0,0.68864D0,0D0,0.003799D0,
561 &66*0D0,0.000079D0,0.001292D0,5*0D0,0.000126D0,0D0,0.002256D0,
562 &0.00001D0,0.000002D0,2*0D0,0.996233D0,63*0D0,0.000013D0,
563 &0.067484D0,2*0D0,0.00001D0,0.002701D0,0D0,0.929792D0,18*0D0,
564 &0.452899D0,0D0,0.547101D0,1D0,2*0.215134D0,0.215133D0,0.214738D0,
565 &2*0D0,2*0.06993D0,0D0,0.000225D0,0.036777D0,0.596654D0,2*0D0,
566 &0.000177D0,0.050055D0,0.316112D0,0.041762D0,0.90916D0,2*0D0,
567 &0.000173D0,0.048905D0,0.000328D0,0.053776D0,0.872444D0,2*0D0,
568 &0.000259D0,0.073192D0,0D0,0.153373D0,2*0.342801D0,0D0,0.086867D0,
569 &0.03128D0,0.001598D0,0.000768D0,0.004789D0,0.006911D0,0.004789D0,
570 &0.006911D0,0.004789D0,3*0D0,0.003077D0,0.00103D0,0.003077D0,
571 &0.00103D0,0.003077D0,0.00103D0,2*0D0,0.138845D0,0.474102D0,
572 &0.176299D0,0D0,0.109767D0,0.008161D0,0.028584D0,0.001468D0,2*0D0,
573 &0.001468D0,0.02853D0,0.000007D0,0D0,0.000001D0,0.000053D0,
574 &0.003735D0,5*0D0,2*0.009661D0,0.00966D0,0D0,0.163019D0,
575 &0.004003D0,0.45294D0,0.008334D0,2*0.038042D0,0.001999D0,0D0,
576 &0.017733D0,0.045908D0,0.017733D0,0.045908D0,0.017733D0,3*0D0,
577 &0.038354D0,0.011181D0,0.038354D0,0.011181D0,0.038354D0,
578 &0.011181D0,2*0D0,0.090264D0,2*0.001805D0,0.090264D0,0.001805D0,
579 &0.81225D0,0.001806D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0/
580 DATA (BRAT(I) ,I= 643, 803)/0.001808D0,0.81372D0,0D0,0.325914D0,
581 &0.016735D0,0.000009D0,0.016736D0,0.32532D0,0.000554D0,0.00001D0,
582 &0.000603D0,0.314118D0,3*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,
583 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,
584 &0.012D0,0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,
585 &2*0.34725D0,0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,
586 &0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,
587 &0.0006D0,0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,
588 &0.144D0,0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,
589 &0.2317D0,0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,
590 &0.08693D0,0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,
591 &0.028D0,0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,
592 &2*0.5D0,0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,
593 &0.087D0,0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,
594 &0.0559D0,0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,
595 &0.332D0,0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,
596 &2*0.029D0,2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,
597 &0.0016D0,0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,
598 &0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,
599 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0/
600 DATA (BRAT(I) ,I= 804, 977)/2*0.005D0,2*0.011D0,5*0.001D0,
601 &0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,
602 &2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,
603 &2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,
604 &0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,
605 &0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,
606 &0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,
607 &0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,
608 &2*0.002D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,
609 &0.045D0,0.073D0,0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,
610 &0.0088D0,0.074D0,0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,
611 &0.001D0,0.0027D0,2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,
612 &0.018D0,0.016D0,0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,
613 &0.0923D0,0.018D0,0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,
614 &0.0085D0,0.067D0,0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,
615 &0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
616 &0.01D0,2*0.02D0,0.03D0,2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,
617 &0.015D0,0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,
618 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
619 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0/
620 DATA (BRAT(I) ,I= 978,1136)/0.8797D0,0.135D0,0.865D0,0.02D0,
621 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,
622 &0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,
623 &0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,
624 &0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,
625 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,
626 &0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
627 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
628 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
629 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
630 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
631 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
632 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
633 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
634 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
635 &0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,0.0009D0,
636 &0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,
637 &2*0.3D0,2*0.2D0,0.047D0,0.122D0,0.006D0,0.012D0,0.035D0,0.012D0,
638 &0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,0.05D0,
639 &0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,0.24D0/
640 DATA (BRAT(I) ,I=1137,1341)/0.065D0,0.012D0,0.003D0,0.001D0,
641 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
642 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
643 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
644 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
645 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
646 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
647 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
648 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
649 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
650 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
651 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
652 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
653 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
654 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
655 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
656 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,
657 &2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,0.76D0,3*0.08D0,0.76D0,
658 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
659 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0/
660 DATA (BRAT(I) ,I=1342,1522)/0.0235D0,0.0285D0,0.0435D0,0.0011D0,
661 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
662 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
663 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
664 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
665 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
666 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
667 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
668 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
669 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
670 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
671 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
672 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
673 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
674 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
675 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
676 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
677 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
678 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
679 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
680 DATA (BRAT(I) ,I=1523,2548)/0.015D0,0.005D0,2*0.105D0,0.04D0,
681 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
682 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
683 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
684 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
685 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
686 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
687 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
688 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
689 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
690 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
691 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
692 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
693 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
694 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
695 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
696 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,
697 &0.008D0,0.024D0,0.008D0,0.024D0,0.425D0,0.02D0,0.185D0,0.088D0,
698 &0.043D0,0.067D0,0.066D0,831*0D0,0.85422D0,0.005292D0,0.044039D0,
699 &0.096449D0,0.853165D0,0.021144D0,0.029361D0,0.096329D0/
700 DATA (BRAT(I) ,I=2549,4000)/0.294414D0,0.109437D0,0.596149D0,
701 &0.389861D0,0.610139D0,1447*0D0/
702 DATA (KFDP(I,1),I= 1, 374)/21,22,23,4*-24,25,21,22,23,4*24,25,
703 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
704 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
705 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
706 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
707 &-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,
708 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
709 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
710 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
711 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
712 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
713 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
714 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
715 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
716 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
717 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
718 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
719 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,
720 &1000022,2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,
721 &1000001,2000001,1000001,-1000001,1000002,2000002,1000002/
722 DATA (KFDP(I,1),I= 375, 587)/-1000002,1000003,2000003,1000003,
723 &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
724 &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
725 &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
726 &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
727 &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
728 &1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,
729 &1000022,2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,
730 &1000001,2000001,1000001,-1000001,1000002,2000002,1000002,
731 &-1000002,1000003,2000003,1000003,-1000003,1000004,2000004,
732 &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
733 &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
734 &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
735 &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
736 &1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,-5,-7,
737 &-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
738 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
739 &-1000013,-1000015,-2000015,5,6,21,2,1,2,3,4,5,6,11,13,15,3,4,5,6,
740 &11,13,15,21,2*4,24,-11,-13,-15,3,4,5,6,11,13,15,21,2*24,2*52,
741 &2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,3*52,24/
742 DATA (KFDP(I,1),I= 588, 979)/4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,
743 &22,23,22,23,24,52,24,52,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
744 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,63,3*-1,3*-3,3*-5,-11,-13,-15,
745 &82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,
746 &11,213,-213,221,223,321,130,310,111,331,111,211,-12,12,-14,14,
747 &211,111,22,-13,-11,2*211,213,113,221,223,321,211,331,22,111,211,
748 &2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,321,130,310,
749 &221,111,211,111,130,310,321,2*311,321,311,323,313,323,313,321,
750 &3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,323,311,
751 &4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,11,13,211,
752 &321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,-313,-20313,
753 &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
754 &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
755 &-321,211,113,421,2*411,421,411,423,413,423,413,421,411,8*-11,
756 &8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,-321,
757 &-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,-313,
758 &-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,211,
759 &113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,5*-13,
760 &221,331,333,221,331,333,10221,211,213,211,213,321,323,321,323,
761 &2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,443/
762 DATA (KFDP(I,1),I= 980,1419)/82,6*12,6*14,2*16,3*-411,3*-413,
763 &2*-411,2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,
764 &513,523,513,521,511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,
765 &2*441,2*443,2*20443,2*2,2*4,2,4,521,511,521,513,523,513,523,511,
766 &521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,
767 &3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,2*14,2*16,
768 &4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,513,
769 &523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,2112,
770 &2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,3112,
771 &2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,3312,
772 &2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
773 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
774 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
775 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
776 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
777 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
778 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
779 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
780 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
781 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16/
782 DATA (KFDP(I,1),I=1420,1739)/2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
783 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
784 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
785 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
786 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
787 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
788 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
789 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
790 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
791 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
792 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
793 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
794 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
795 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
796 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
797 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
798 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
799 &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
800 &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
801 &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025/
802 DATA (KFDP(I,1),I=1740,1907)/1000035,1000004,2000004,1000004,
803 &2000004,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
804 &1000035,1000003,2000003,1000003,2000003,1000021,1000039,-1000024,
805 &-1000037,1000022,1000023,1000025,1000035,1000006,2000006,1000006,
806 &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
807 &1000035,1000005,2000005,1000005,2000005,1000021,1000022,1000016,
808 &-1000015,1000039,-1000024,-1000037,1000022,1000023,1000025,
809 &1000035,1000012,2000012,1000012,2000012,1000039,1000024,1000037,
810 &1000022,1000023,1000025,1000035,1000011,2000011,1000011,2000011,
811 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
812 &1000014,2000014,1000014,2000014,1000039,1000024,1000037,1000022,
813 &1000023,1000025,1000035,1000013,2000013,1000013,2000013,1000039,
814 &-1000024,-1000037,1000022,1000023,1000025,1000035,1000016,
815 &2000016,1000016,2000016,1000039,1000024,1000037,1000022,1000023,
816 &1000025,1000035,1000015,2000015,1000015,2000015,1000039,1000001,
817 &-1000001,2000001,-2000001,1000002,-1000002,2000002,-2000002,
818 &1000003,-1000003,2000003,-2000003,1000004,-1000004,2000004,
819 &-2000004,1000005,-1000005,2000005,-2000005,1000006,-1000006,
820 &2000006,-2000006,6*1000022,6*1000023,6*1000025,6*1000035,1000024,
821 &-1000024,1000024,-1000024,1000024,-1000024,1000037,-1000037/
822 DATA (KFDP(I,1),I=1908,2126)/1000037,-1000037,1000037,-1000037,
823 &5*1000039,4,1,5*1000039,16*1000022,1000024,-1000024,1000024,
824 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
825 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
826 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
827 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
828 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
829 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
830 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
831 &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
832 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
833 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
834 &-1000016,2000016,-2000016,5*1000021,2*1000039,6*1000022,
835 &6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,1000035,
836 &1000002,2000002,-1000001,-2000001,1000004,2000004,-1000003,
837 &-2000003,1000006,2000006,-1000005,-2000005,1000012,2000012,
838 &-1000011,-2000011,1000014,2000014,-1000013,-2000013,1000016,
839 &2000016,-1000015,-2000015,2*1000021,5*1000039,16*1000022,
840 &16*1000023,1000024,-1000024,1000024,-1000024,1000024,-1000024,
841 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037/
842 DATA (KFDP(I,1),I=2127,2315)/-1000037,1000037,-1000037,1000037,
843 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
844 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
845 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
846 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
847 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
848 &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
849 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
850 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
851 &-1000016,2000016,-2000016,5*1000021,5*1000039,16*1000022,
852 &16*1000023,16*1000025,1000024,-1000024,1000024,-1000024,1000024,
853 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
854 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
855 &-1000037,1000037,-1000037,1000037,-1000037,1000024,-1000024,
856 &1000037,-1000037,1000001,-1000001,2000001,-2000001,1000002,
857 &-1000002,2000002,-2000002,1000003,-1000003,2000003,-2000003,
858 &1000004,-1000004,2000004,-2000004,1000005,-1000005,2000005,
859 &-2000005,1000006,-1000006,2000006,-2000006,1000011,-1000011,
860 &2000011,-2000011,1000012,-1000012,2000012,-2000012,1000013,
861 &-1000013,2000013,-2000013,1000014,-1000014,2000014,-2000014/
862 DATA (KFDP(I,1),I=2316,2516)/1000015,-1000015,2000015,-2000015,
863 &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
864 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
865 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
866 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012,
867 &2000012,-1000011,-2000011,1000014,2000014,-1000013,-2000013,
868 &1000016,2000016,-1000015,-2000015,2*1000021,1000039,-1000024,
869 &-1000037,1000022,1000023,1000025,1000035,4*1000001,1000002,
870 &2000002,1000002,2000002,1000021,1000039,1000024,1000037,1000022,
871 &1000023,1000025,1000035,4*1000002,1000001,2000001,1000001,
872 &2000001,1000021,1000039,-1000024,-1000037,1000022,1000023,
873 &1000025,1000035,4*1000003,1000004,2000004,1000004,2000004,
874 &1000021,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
875 &4*1000004,1000003,2000003,1000003,2000003,1000021,1000039,
876 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000005,
877 &1000006,2000006,1000006,2000006,1000021,1000039,1000024,1000037,
878 &1000022,1000023,1000025,1000035,4*1000006,1000005,2000005,
879 &1000005,2000005,1000021,1000039,-1000024,-1000037,1000022,
880 &1000023,1000025,1000035,4*1000011,1000012,2000012,1000012,
881 &2000012,1000039,-1000024,-1000037,1000022,1000023,1000025/
882 DATA (KFDP(I,1),I=2517,4000)/1000035,4*1000013,1000014,2000014,
883 &1000014,2000014,1000039,-1000024,-1000037,1000022,1000023,
884 &1000025,1000035,4*1000015,1000016,2000016,1000016,2000016,21,22,
885 &23,-24,21,22,23,24,22,23,-24,23,24,1447*0/
886 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,
887 &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,
888 &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,
889 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
890 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
891 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
892 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
893 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
894 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
895 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
896 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
897 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
898 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
899 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
900 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
901 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
902 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
903 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
904 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
905 &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/
906 DATA (KFDP(I,2),I= 340, 526)/-7,-8,-11,-13,-15,-17,21,22,2*23,
907 &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
908 &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
909 &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
910 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
911 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
912 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
913 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
914 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
915 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
916 &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
917 &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
918 &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
919 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
920 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
921 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
922 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
923 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
924 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
925 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
926 DATA (KFDP(I,2),I= 527, 931)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-3,-4,
927 &-5,-6,-11,-13,-15,21,-3,-5,5,12,14,16,-3,-4,-5,-6,-11,-13,-15,21,
928 &-24,-52,-24,-52,51,53,51,53,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,
929 &-14,-15,-16,-17,-18,23,51,23,51,22,53,2,4,6,8,2,4,6,8,2,4,6,8,2,
930 &4,6,8,12,14,16,18,2*51,2*53,-52,2*-24,-52,-1,-2,-3,-4,-5,-6,-7,
931 &-8,-11,-12,-13,-14,-15,-16,-17,-18,-11,-13,-15,-13,2*-15,24,-11,
932 &-13,-15,-13,2*-15,63,2,4,6,2,4,6,2,4,6,64,65,66,-82,12,14,-1,-3,
933 &11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
934 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
935 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
936 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
937 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
938 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
939 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
940 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
941 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
942 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
943 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
944 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
945 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111/
946 DATA (KFDP(I,2),I= 932,1317)/-211,211,-211,211,16,5*12,5*14,
947 &3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,2*-1,
948 &22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13,2*-15,
949 &211,213,20213,211,213,20213,431,433,431,433,311,313,311,313,311,
950 &313,-1,-4,-3,-4,-1,-3,22,-211,111,-211,111,-211,211,-211,211,
951 &6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,
952 &321,323,321,323,321,323,-1,-4,-3,-4,-1,-3,22,211,111,211,111,
953 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
954 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
955 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
956 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
957 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
958 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
959 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
960 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
961 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
962 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
963 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
964 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
965 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1/
966 DATA (KFDP(I,2),I=1318,1756)/-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,
967 &-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,-433,3*3122,
968 &1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,
969 &2*211,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,
970 &4,3,4,1,3,22,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,
971 &1,4,3,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,
972 &4,3,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,
973 &3,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,
974 &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,
975 &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,
976 &3,2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,
977 &113,-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,
978 &310,2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,
979 &311,2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,
980 &-311,-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,
981 &2*211,111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,
982 &-311,311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,
983 &111,-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,
984 &-13,-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,
985 &2*1,4*2,2*24,2*37,2,3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37/
986 DATA (KFDP(I,2),I=1757,2220)/4,5,2*6,4*5,2*-24,2*-37,5,6,2*5,4*6,
987 &2*24,2*37,6,4,-15,16,11,2*12,4*11,2*-24,2*-37,12,2*11,4*12,2*24,
988 &2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37,15,2*16,
989 &4*15,2*-24,2*-37,16,2*15,4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,
990 &-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,
991 &1,3,5,2,4,6,1,3,5,2,4,6,1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,
992 &35,36,-1,-3,22,23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,
993 &35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,
994 &15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
995 &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
996 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
997 &24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,
998 &24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,
999 &2*-13,2*14,2*-15,2*16,-1,-3,22,23,25,35,36,22,23,11,13,15,12,14,
1000 &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,
1001 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1002 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1003 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,
1004 &13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,22,23,25,
1005 &35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15/
1006 DATA (KFDP(I,2),I=2221,4000)/12,14,16,1,3,5,2,4,25,35,36,22,23,
1007 &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
1008 &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
1009 &1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
1010 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
1011 &-16,16,-16,16,1,3,5,2,4,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,
1012 &35,36,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,
1013 &-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,
1014 &2*12,2*-13,2*14,2*-15,2*16,-1,-3,1,2*2,4*1,23,25,35,36,2*-24,
1015 &2*-37,1,2,2*1,4*2,23,25,35,36,2*24,2*37,2,3,2*4,4*3,23,25,35,36,
1016 &2*-24,2*-37,3,4,2*3,4*4,23,25,35,36,2*24,2*37,4,5,2*6,4*5,23,25,
1017 &35,36,2*-24,2*-37,5,6,2*5,4*6,23,25,35,36,2*24,2*37,6,11,2*12,
1018 &4*11,23,25,35,36,2*-24,2*-37,13,2*14,4*13,23,25,35,36,2*-24,
1019 &2*-37,15,2*16,4*15,23,25,35,36,2*-24,2*-37,3*1,4*2,1,2*11,2*12,
1021 DATA (KFDP(I,3),I= 1,1134)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1022 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1023 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1024 &407*0,-5,112*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,
1025 &-211,211,-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,
1026 &3*0,111,211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,
1027 &5*0,2*221,3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,
1028 &221,331,113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,
1029 &223,22*0,111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,
1030 &111,-211,111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,
1031 &-323,-311,-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,
1032 &-211,310,-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,
1033 &2*211,6*0,111,-211,111,-211,0,221,331,333,321,311,221,331,333,
1034 &321,311,20*0,3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,
1035 &-413,-10413,-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,
1036 &5*0,111,-211,111,-211,-421,-423,-10423,-10421,-20423,-425,-421,
1037 &-423,-10423,-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,
1038 &5*0,111,-211,111,-211,-431,-433,-10433,-10431,-20433,-435,-431,
1039 &-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,
1040 &8*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531/
1041 DATA (KFDP(I,3),I=1135,2233)/533,3,2,3,2,511,513,511,513,1,2,
1042 &13*0,2*21,11*0,2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,
1043 &3212,3214,2112,2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,
1044 &52*0,3*3,1,6*0,4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,
1045 &2*2,4*4,1,4,3,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,
1046 &4*0,4*4,1,4,3,2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1047 &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,
1048 &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,
1049 &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,
1050 &3,2*2,4*4,1,4,3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,
1051 &111,211,30*0,-211,111,13*0,2*21,-211,111,76*0,2*5,91*0,-1,-3,-5,
1052 &-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,
1053 &-2,2,-4,4,-6,6,-2,2,-4,4,-6,6,5*0,11,12,7*0,-11,-13,-15,-12,-14,
1054 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1055 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,
1056 &12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,7*0,-11,-13,
1057 &-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,
1058 &-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,
1059 &-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,7*0,-11,-13,-15,-12,-14,-16,
1060 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0/
1061 DATA (KFDP(I,3),I=2234,4000)/-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,
1062 &-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,
1063 &-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,-11,-13,-15,-12,-14,-16,-1,-3,
1064 &-5,-2,-4,4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,
1065 &16,2,4,28*0,2,4,1601*0/
1066 DATA (KFDP(I,4),I= 1,4000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1067 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1068 &6*111,310,2*130,520*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1069 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1070 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1071 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1072 &-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,
1073 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1074 &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,
1075 &162*81,31*0,-211,111,2398*0/
1076 DATA (KFDP(I,5),I= 1,4000)/96*0,2*111,17*0,111,7*0,2*111,0,
1077 &3*111,0,111,715*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1078 &3*111,-211,111,3075*0/
1080 C...PYDAT4, with particle names (character strings).
1081 DATA (CHAF(I,1),I= 1, 185)/'d','u','s','c','b','t','b''','t''',
1082 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1083 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1084 &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1085 &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1086 &'rho_tech0','rho_tech+','omega_tech',4*' ','H_L++','H_R++',
1087 &'W_R+','nu_Re','nu_Rmu','nu_Rtau',14*' ','specflav','rndmflav',
1088 &'phasespa','c-hadron','b-hadron',5*' ','cluster','string',
1089 &'indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet','CELLjet',
1090 &'table',' ','rho_diff0','pi0','rho0','a_20','K_L0','pi_diffr+',
1091 &'pi+','rho+','a_2+','omega_di','eta','omega','f_2','K_S0','K0',
1092 &'K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''','phi',
1093 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1094 &'D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0','B*_20',
1095 &'B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+',
1096 &'B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-','ud_0',
1097 &'ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+','Delta+',
1098 &'Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0','su_0',
1099 &'su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-','Xi*-',
1100 &'Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0','Sigma*_c0'/
1101 DATA (CHAF(I,1),I= 186, 315)/'Lambda_c+','Xi_c0','cu_0','cu_1',
1102 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1103 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1104 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++',
1105 &'Omega_cc+','Omega*_cc+','Omega*_ccc++','bd_0','bd_1','Sigma_b-',
1106 &'Sigma*_b-','Lambda_b0','Xi_b-','Xi_bc0','bu_0','bu_1',
1107 &'Sigma_b0','Sigma*_b0','Sigma_b+','Sigma*_b+','Xi_b0','Xi_bc+',
1108 &'bs_0','bs_1','Xi''_b-','Xi*_b-','Xi''_b0','Xi*_b0','Omega_b-',
1109 &'Omega*_b-','Omega_bc0','bc_0','bc_1','Xi''_bc0','Xi*_bc0',
1110 &'Xi''_bc+','Xi*_bc+','Omega''_bc0','Omega*_bc0','Omega_bcc+',
1111 &'Omega*_bcc+','bb_1','Xi_bb-','Xi*_bb-','Xi_bb0','Xi*_bb0',
1112 &'Omega_bb-','Omega*_bb-','Omega_bbc0','Omega*_bbc0',
1113 &'Omega*_bbb-','a_00','b_10','a_0+','b_1+','f_0','h_1','K*_00',
1114 &'K_10','K*_0+','K_1+','f''_0','h''_1','D*_0+','D_1+','D*_00',
1115 &'D_10','D*_0s+','D_1s+','chi_0c','h_1c','B*_00','B_10','B*_0+',
1116 &'B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+','chi_0b','h_1b','a_10',
1117 &'a_1+','f_1','K*_10','K*_1+','f''_1','D*_1+','D*_10','D*_1s+',
1118 &'chi_1c','B*_10','B*_1+','B*_1s0','B*_1c+','chi_1b','psi''',
1119 &'Upsilon''','~d_L','~u_L','~s_L','~c_L','~b_1','~t_1','~e_L-',
1120 &'~nu_eL','~mu_L-','~nu_muL','~tau_1-','~nu_tauL','~g','~chi_10'/
1121 DATA (CHAF(I,1),I= 316, 500)/'~chi_20','~chi_1+','~chi_30',
1122 &'~chi_40','~chi_2+','~gravitino','~d_R','~u_R','~s_R','~c_R',
1123 &'~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR','~tau_2-',
1124 &'~nu_tauR','d*','u*','e*-','nu*_e0',163*' '/
1125 DATA (CHAF(I,2),I= 1, 198)/'dbar','ubar','sbar','cbar','bbar',
1126 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1127 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1128 &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1129 &'rho_tech-',5*' ','H_L--','H_R--','W_R-','nu_Rebar','nu_Rmubar',
1130 &'nu_Rtaubar',15*' ','rndmflavbar',' ','c-hadronbar',
1131 &'b-hadronbar',20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ',
1132 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-',
1133 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1134 &4*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1135 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar',
1136 &'Deltabar+','ud_0bar','ud_1bar','n_diffrbar0','nbar0',
1137 &'Deltabar0','uu_1bar','p_diffrbar-','pbar-','Deltabar-',
1138 &'Deltabar--','sd_0bar','sd_1bar','Sigmabar+','Sigma*bar+',
1139 &'Lambdabar0','su_0bar','su_1bar','Sigmabar0','Sigma*bar0',
1140 &'Sigmabar-','Sigma*bar-','ss_1bar','Xibar+','Xi*bar+','Xibar0',
1141 &'Xi*bar0','Omegabar+','cd_0bar','cd_1bar','Sigma_cbar0',
1142 &'Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar','cu_1bar',
1143 &'Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--','Sigma*_cbar--',
1144 &'Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0','Xi*_cbar0'/
1145 DATA (CHAF(I,2),I= 199, 308)/'Xi''_cbar-','Xi*_cbar-',
1146 &'Omega_cbar0','Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-',
1147 &'Xi_ccbar--','Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-',
1148 &'Omega*_cccbar-','bd_0bar','bd_1bar','Sigma_bbar+',
1149 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1150 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1151 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1152 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1153 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1154 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1155 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1156 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1157 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1158 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1159 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1160 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1161 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1162 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1163 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1164 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+'/
1165 DATA (CHAF(I,2),I= 309, 500)/'~nu_eLbar','~mu_L+','~nu_muLbar',
1166 &'~tau_1+','~nu_tauLbar',3*' ','~chi_1-',2*' ','~chi_2-',' ',
1167 &'~d_Rbar','~u_Rbar','~s_Rbar','~c_Rbar','~b_2bar','~t_2bar',
1168 &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1169 &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1171 C...PYDATR, with initial values for the random number generator.
1172 DATA MRPY/19780503,0,0,97,33,0/
1174 C...Default values for allowed processes and kinematics constraints.
1177 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1178 &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,
1181 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1182 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1183 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1184 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1185 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1186 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1187 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1188 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1189 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1190 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1191 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1192 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1193 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1194 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1195 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1196 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1199 C...Default values for main switches and parameters. Reset information.
1200 DATA (MSTP(I),I=1,100)/
1201 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1202 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1203 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1204 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1205 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1206 5 4, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1207 6 1, 3, 2, 2, 1, 5, 2, 1, 0, 0,
1208 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1209 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0,
1210 9 1, 3, 1, 3, 0, 0, 0, 0, 0, 0/
1211 DATA (MSTP(I),I=101,200)/
1212 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1213 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1214 2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
1215 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1216 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1217 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1218 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1219 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1220 8 6, 150, 2000, 06, 30, 0, 0, 0, 0, 0,
1221 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1222 DATA (PARP(I),I=1,100)/
1223 & 0.25D0, 10D0, 8*0D0,
1224 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1226 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1227 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
1229 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
1230 7 4.0D0, 0.25D0, 8*0D0,
1231 8 1.90D0, 2.10D0, 0.5D0, 0.2D0, 0.33D0,
1232 8 0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
1233 9 1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1234 DATA (PARP(I),I=101,200)/
1235 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 6*0D0,
1236 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1237 2 1.0D0, 0.4D0, 8*0D0,
1238 3 0.01D0, 8*0D0, 0D0,
1239 4 0.33333D0, 82D0, 1.33333D0, 4D0, 1D0,
1240 4 1D0, .0182D0, 1D0, 0D0, 1.33333D0,
1241 5 0D0, 0D0, 0D0, 0D0, 6*0D0,
1242 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1243 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1244 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1246 9 0.64D0, 5.0D0, 8*0D0/
1252 C...Constants for the generation of the various processes.
1253 DATA (ISET(I),I=1,100)/
1254 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1255 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1256 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1257 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1258 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1259 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1260 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1261 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1262 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1263 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1264 DATA (ISET(I),I=101,200)/
1265 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1266 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1267 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1268 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1269 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1270 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1271 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1272 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1273 8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
1274 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1275 DATA (ISET(I),I=201,300)/
1276 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1277 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1278 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1279 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1280 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1281 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1282 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1283 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1284 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1285 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1286 DATA (ISET(I),I=301,500)/
1288 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1289 5 5, 5, -1, -1, -1, -1, -1, -1, -1, -1,
1290 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1291 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1293 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1294 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1295 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1296 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1297 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1298 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1299 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1300 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1301 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1302 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1303 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1304 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1305 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1306 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1307 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1308 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1309 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1310 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1311 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1312 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1313 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1314 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1315 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1316 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1317 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1318 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1319 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1320 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1321 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1322 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1323 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1324 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
1325 4 4000011, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
1326 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1327 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1328 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1329 6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
1330 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1331 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1332 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1333 8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
1334 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
1335 9 54, 0, 55, 0, 56, 0, 11, 0, 11, 0,
1336 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1337 DATA ((KFPR(I,J),J=1,2),I=201,250)/
1338 & 1000011, 1000011, 2000011, 2000011, 1000011,
1339 & 2000011, 1000013, 1000013, 2000013, 2000013,
1340 & 1000013, 2000013, 1000015, 1000015, 2000015,
1341 & 2000015, 1000015, 2000015, 1000011, 1000012,
1342 1 1000015, 1000016, 2000015, 1000016, 1000012,
1343 1 1000012, 1000016, 1000016, 0, 0,
1344 1 1000022, 1000022, 1000023, 1000023, 1000025,
1345 1 1000025, 1000035, 1000035, 1000022, 1000023,
1346 2 1000022, 1000025, 1000022, 1000035, 1000023,
1347 2 1000025, 1000023, 1000035, 1000025, 1000035,
1348 2 1000024, 1000024, 1000037, 1000037, 1000024,
1349 2 1000037, 1000022, 1000024, 1000023, 1000024,
1350 3 1000025, 1000024, 1000035, 1000024, 1000022,
1351 3 1000037, 1000023, 1000037, 1000025, 1000037,
1352 3 1000035, 1000037, 1000021, 1000022, 1000021,
1353 3 1000023, 1000021, 1000025, 1000021, 1000035,
1354 4 1000021, 1000024, 1000021, 1000037, 1000021,
1355 4 1000021, 1000021, 1000021, 0, 0,
1356 4 1000002, 1000022, 2000002, 1000022, 1000002,
1357 4 1000023, 2000002, 1000023, 1000002, 1000025/
1358 DATA ((KFPR(I,J),J=1,2),I=251,300)/
1359 5 2000002, 1000025, 1000002, 1000035, 2000002,
1360 5 1000035, 1000001, 1000024, 2000005, 1000024,
1361 5 1000001, 1000037, 2000005, 1000037, 1000002,
1362 5 1000021, 2000002, 1000021, 0, 0,
1363 6 1000006, 1000006, 2000006, 2000006, 1000006,
1364 6 2000006, 1000006, 1000006, 2000006, 2000006,
1367 7 1000002, 1000002, 2000002, 2000002, 1000002,
1368 7 2000002, 1000002, 1000002, 2000002, 2000002,
1369 7 1000002, 2000002, 1000002, 1000002, 2000002,
1370 7 2000002, 1000002, 1000002, 2000002, 2000002,
1371 8 1000005, 1000002, 2000005, 2000002, 1000005,
1372 8 2000002, 1000005, 1000002, 2000005, 2000002,
1373 8 1000005, 2000002, 1000005, 1000005, 2000005,
1374 8 2000005, 1000005, 1000005, 2000005, 2000005,
1375 9 1000005, 1000005, 2000005, 2000005, 1000005,
1376 9 2000005, 1000005, 1000021, 2000005, 1000021,
1377 9 1000005, 2000005, 37, 25, 37,
1378 9 35, 36, 25, 36, 35/
1379 DATA ((KFPR(I,J),J=1,2),I=301,500)/
1382 4 11, 62, 11, 61, 13,
1383 4 62, 13, 61, 15, 62,
1384 4 15, 61, 61, 62, 62,
1389 6 24, 24, 24, 52, 52,
1390 6 52, 22, 51, 22, 53,
1391 6 23, 51, 23, 53, 24,
1393 7 24, 51, 52, 23, 52,
1394 7 51, 22, 52, 23, 52,
1395 7 24, 51, 24, 53, 0,
1398 DATA COEF/10000*0D0/
1399 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1400 &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,
1401 &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,
1402 &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,
1403 &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,
1404 &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,
1405 &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,
1406 &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,
1407 &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,
1408 &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,
1409 &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/
1411 C...Treatment of resonances.
1412 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1413 &10*0,6*1,4*0,3*1,238*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1415 C...Character constants: name of processes.
1416 DATA PROC(0)/ 'All included subprocesses '/
1417 DATA (PROC(I),I=1,20)/
1418 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1419 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1420 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1421 &' ', 'W+ + W- -> h0 ',
1422 &' ', 'f + f'' -> f + f'' (QFD) ',
1423 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1424 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1425 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1426 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1427 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1428 DATA (PROC(I),I=21,40)/
1429 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1430 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1431 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1432 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1433 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1434 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1435 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1436 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1437 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1438 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1439 DATA (PROC(I),I=41,60)/
1440 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1441 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1442 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1443 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1444 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1445 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1446 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1447 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1448 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1449 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1450 DATA (PROC(I),I=61,80)/
1451 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1452 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1453 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1454 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1455 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1456 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1457 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1458 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1459 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1460 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1461 DATA (PROC(I),I=81,100)/
1462 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1463 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1464 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1465 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1466 8'g + g -> chi_2c + g ', ' ',
1467 9'Elastic scattering ', 'Single diffractive (XB) ',
1468 9'Single diffractive (AX) ', 'Double diffractive ',
1469 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1471 9'q + gamma* -> q ', ' '/
1472 DATA (PROC(I),I=101,120)/
1473 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1474 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1475 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1476 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1477 &' ', 'f + fbar -> gamma + h0 ',
1478 1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
1479 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1480 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1481 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1483 DATA (PROC(I),I=121,140)/
1484 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1485 2'f + f'' -> f + f'' + h0 ',
1486 2'f + f'' -> f" + f"'' + h0 ',
1490 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1491 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1492 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1493 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1494 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1495 DATA (PROC(I),I=141,160)/
1496 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1497 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1498 4'q + l -> LQ ', 'e + gamma -> e* ',
1499 4'd + g -> d* ', 'u + g -> u* ',
1500 4'g + g -> eta_techni ', ' ',
1501 5'f + fbar -> H0 ', 'g + g -> H0 ',
1502 5'gamma + gamma -> H0 ', ' ',
1503 5' ', 'f + fbar -> A0 ',
1504 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1506 DATA (PROC(I),I=161,180)/
1507 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1508 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1509 6'f + fbar -> f'' + fbar'' (g/Z)',
1510 6'f +fbar'' -> f" + fbar"'' (W) ',
1511 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1512 6'q + qbar -> e + e* ', ' ',
1513 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1514 7'f + f'' -> f + f'' + H0 ',
1515 7'f + f'' -> f" + f"'' + H0 ',
1516 7' ', 'f + fbar -> Z0 + A0 ',
1517 7'f + fbar'' -> W+/- + A0 ',
1518 7'f + f'' -> f + f'' + A0 ',
1519 7'f + f'' -> f" + f"'' + A0 ',
1521 DATA (PROC(I),I=181,200)/
1522 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1524 8' ', 'g + g -> Q + Qbar + A0 ',
1525 8'q + qbar -> Q + Qbar + A0 ', ' ',
1527 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
1528 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1529 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1532 DATA (PROC(I),I=201,220)/
1533 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1534 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1535 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1536 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1537 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1538 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1539 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1540 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1541 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1542 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1543 DATA (PROC(I),I=221,240)/
1544 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1545 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1546 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1547 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1548 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1549 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1550 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1551 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1552 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1553 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1554 DATA (PROC(I),I=241,260)/
1555 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1556 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1557 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1558 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1559 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1560 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1561 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1562 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1563 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1564 5'qj + g -> ~qj_R + ~g ', ' '/
1565 DATA (PROC(I),I=261,300)/
1566 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1567 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1568 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1571 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1572 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1573 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1574 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1575 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1576 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1577 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1578 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1579 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1580 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1581 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1582 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1583 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1584 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1585 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1586 DATA (PROC(I),I=301,340)/
1587 &'f + fbar -> H+ + H- ', 39*' '/
1588 DATA (PROC(I),I=341,500)/
1589 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1590 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1591 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1592 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1593 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1594 5'f + f -> f'' + f'' + H_L++/-- ',
1595 5'f + f -> f'' + f'' + H_R++/-- ', 7*' ',
1596 6' ', 'f + fbar -> W_L+ W_L- ',
1597 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1598 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1599 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1600 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1601 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1602 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1603 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1604 7'f + fbar'' -> W+/- pi_T0 ',
1605 7'f + fbar'' -> W+/- pi_T0'' ',
1609 C...Cross sections and slope offsets.
1612 C...Supersymmetry switches and parameters.
1614 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1617 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1618 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1619 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
1622 C...Data for histogramming routines.
1623 DATA IHIST/1000,20000,55,1/
1629 C...A simple program (disguised as subroutine) to run at installation
1630 C...as a check that the program works as intended.
1632 SUBROUTINE PYTEST(MTEST)
1634 C...Double precision and integer declarations.
1635 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1636 IMPLICIT INTEGER(I-N)
1637 INTEGER PYK,PYCHGE,PYCOMP
1639 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1640 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1641 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1642 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
1643 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1644 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1645 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1647 DIMENSION PSUM(5),PINI(6),PFIN(6)
1649 C...Save defaults for values that are changed.
1666 C...First part: loop over simple events to be generated.
1667 IF(MTEST.GE.1) CALL PYTABU(20)
1671 C...Reset parameter values. Switch on some nonstandard features.
1686 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1688 C...Ten events each for some single jets configurations.
1692 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1693 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1694 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1695 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1696 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1697 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1699 C...Ten events each for some simple jet systems; string fragmentation.
1700 ELSEIF(IEV.LE.130) THEN
1702 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1703 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1704 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1705 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1706 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1707 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1708 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1709 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1710 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1712 C...Seventy events with independent fragmentation and momentum cons.
1713 ELSEIF(IEV.LE.200) THEN
1715 MSTJ(2)=1+MOD(IEV-131,4)
1716 MSTJ(3)=1+MOD((IEV-131)/4,4)
1717 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1718 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1719 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1720 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1721 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1722 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1724 C...A hundred events with random jets (check invariant mass).
1725 ELSEIF(IEV.LE.300) THEN
1732 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1733 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1734 EJET=5D0+20D0*PYR(0)
1735 THETA=ACOS(2D0*PYR(0)-1D0)
1737 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1738 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1739 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1740 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1742 PSUM(J)=PSUM(J)+P(I,J)
1745 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
1746 & (PSUM(5)+PARJ(32))**2) GOTO 100
1748 C...Fifty e+e- continuum events with matrix elements.
1749 ELSEIF(IEV.LE.350) THEN
1753 C...Fifty e+e- continuum event with varying shower options.
1754 ELSEIF(IEV.LE.400) THEN
1755 MSTJ(42)=1+MOD(IEV,2)
1756 MSTJ(43)=1+MOD(IEV/2,4)
1757 MSTJ(44)=MOD(IEV/8,3)
1760 C...Fifty e+e- continuum events with coherent shower.
1761 ELSEIF(IEV.LE.450) THEN
1762 CALL PYEEVT(0,500D0)
1764 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1766 CALL PYONIA(5,9.46D0)
1769 C...Generate event. Find total momentum, energy and charge.
1780 C...Check conservation of energy, momentum and charge;
1781 C...usually exact, but only approximate for single jets.
1784 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
1786 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
1787 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
1788 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
1791 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
1793 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
1795 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1796 & (PFIN(J),J=1,4),PFIN(6)
1798 C...Check that all KF codes are known ones, and that partons/particles
1799 C...satisfy energy-momentum-mass relation. Store particle statistics.
1801 IF(K(I,1).GT.20) GOTO 170
1802 IF(PYCOMP(K(I,2)).EQ.0) THEN
1803 WRITE(MSTU(11),5100) I
1806 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
1807 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
1809 WRITE(MSTU(11),5200) I
1813 IF(MTEST.GE.1) CALL PYTABU(21)
1815 C...List all erroneous events and some normal ones.
1816 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
1817 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1819 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
1823 C...Stop execution if too many errors.
1824 IF(MERR.NE.0) NERR=NERR+1
1826 WRITE(MSTU(11),6300)
1832 C...Summarize result of run.
1833 IF(MTEST.GE.1) CALL PYTABU(22)
1835 C...Reset commonblock variables changed during run.
1852 C...Second part: complete events of various kinds.
1853 C...Common initial values. Loop over initiating conditions.
1854 MSTP(122)=MAX(0,MIN(2,MTEST))
1855 MDCY(PYCOMP(111),1)=0
1858 C...Reset process type, kinematics cuts, and the flags used.
1875 C...Prompt photon production at fixed target.
1878 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
1882 CALL PYINIT('FIXT','pi+','p',PZSUM)
1884 C...QCD processes at ISR energies.
1885 ELSEIF(IPROC.EQ.2) THEN
1891 CALL PYINIT('CMS','p','p',PESUM)
1893 C...W production + multiple interactions at CERN Collider.
1894 ELSEIF(IPROC.EQ.3) THEN
1903 CALL PYINIT('CMS','p','pbar',PESUM)
1905 C...W/Z gauge boson pairs + pileup events at the Tevatron.
1906 ELSEIF(IPROC.EQ.4) THEN
1918 CALL PYINIT('CMS','p','pbar',PESUM)
1920 C...Higgs production at LHC.
1921 ELSEIF(IPROC.EQ.5) THEN
1933 CALL PYINIT('CMS','p','p',PESUM)
1935 C...Z' production at SSC.
1936 ELSEIF(IPROC.EQ.6) THEN
1945 CALL PYINIT('CMS','p','p',PESUM)
1947 C...W pair production at 1 TeV e+e- collider.
1948 ELSEIF(IPROC.EQ.7) THEN
1955 CALL PYINIT('CMS','e+','e-',PESUM)
1957 C...Deep inelastic scattering at a LEP+LHC ep collider.
1958 ELSEIF(IPROC.EQ.8) THEN
1971 CALL PYINIT('USER','p','e-',PESUM)
1974 C...Generate 20 events of each required type.
1978 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
1980 C...Check conservation of energy/momentum/flavour.
1991 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
1992 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
1993 DEVQ=ABS(PFIN(6)-PINI(6))
1994 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
1995 & DEVQ.GT.0.1D0) MERR=1
1996 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1997 & (PFIN(J),J=1,4),PFIN(6)
1999 C...Check that all KF codes are known ones, and that partons/particles
2000 C...satisfy energy-momentum-mass relation.
2002 IF(K(I,1).GT.20) GOTO 210
2003 IF(PYCOMP(K(I,2)).EQ.0) THEN
2004 WRITE(MSTU(11),5100) I
2007 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2009 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2010 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2011 WRITE(MSTU(11),5200) I
2016 C...Listing of erroneous events, and first event of each type.
2017 IF(MERR.GE.1) NERR=NERR+1
2019 WRITE(MSTU(11),6300)
2023 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2024 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2029 C...List statistics for each process type.
2030 IF(MTEST.GE.1) CALL PYSTAT(1)
2033 C...Summarize result of run.
2034 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2035 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2037 C...Format statements for output.
2038 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2039 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2040 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2041 &4(1X,F12.5),1X,F8.2)
2042 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2043 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2045 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2046 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2047 6400 FORMAT(5X,'Faulty event follows:')
2048 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2049 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2050 &5X,'This should not have happened!')
2055 C*********************************************************************
2058 C...Converts PYTHIA event record contents to or from
2059 C...the standard event record commonblock.
2061 SUBROUTINE PYHEPC(MCONV)
2063 C...Double precision and integer declarations.
2064 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2065 IMPLICIT INTEGER(I-N)
2066 INTEGER PYK,PYCHGE,PYCOMP
2068 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2069 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2070 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2071 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2072 C...HEPEVT commonblock.
2073 PARAMETER (NMXHEP=4000)
2074 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2075 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2076 DOUBLE PRECISION PHEP,VHEP
2079 C...Conversion from PYTHIA to standard, the easy part.
2082 IF(N.GT.NMXHEP) CALL PYERRM(8,
2083 & '(PYHEPC:) no more space in /HEPEVT/')
2087 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2088 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2089 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2090 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2094 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2108 C...Check if new event (from pileup).
2112 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2115 C...Fill in missing mother information.
2116 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2118 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
2122 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2125 IF(I1.GE.I) CALL PYERRM(8,
2126 & '(PYHEPC:) translation of inconsistent event history')
2127 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
2129 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
2130 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
2132 ELSEIF(K(I,2).EQ.94) THEN
2134 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2135 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2136 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2137 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2138 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2141 C...Fill in missing daughter information.
2142 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2143 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2144 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2148 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2150 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2151 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2152 IF(JDAHEP(1,I1).EQ.0) THEN
2159 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2160 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2163 C...Conversion from standard to PYTHIA, the easy part.
2165 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2166 & '(PYHEPC:) no more space in /PYJETS/')
2172 IF(ISTHEP(I).EQ.1) K(I,1)=1
2173 IF(ISTHEP(I).EQ.2) K(I,1)=11
2174 IF(ISTHEP(I).EQ.3) K(I,1)=21
2186 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2188 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2189 & PHEP(5,I)/PHEP(4,I)
2192 C...Fill in missing information on colour connection in jet systems.
2193 IF(ISTHEP(I).EQ.1) THEN
2196 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2197 IF(KQ.NE.0) NKQ=NKQ+1
2198 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2199 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2201 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2202 IF(K(I+1,2).EQ.21) K(I,1)=2
2206 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2207 & '(PYHEPC:) input parton configuration not colour singlet')
2212 C*********************************************************************
2215 C...Initializes the generation procedure; finds maxima of the
2216 C...differential cross-sections to be used for weighting.
2218 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2220 C...Double precision and integer declarations.
2221 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2222 IMPLICIT INTEGER(I-N)
2223 INTEGER PYK,PYCHGE,PYCOMP
2225 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2226 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2227 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2228 COMMON/PYDAT4/CHAF(500,2)
2230 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2231 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2232 COMMON/PYINT1/MINT(400),VINT(400)
2233 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2234 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2235 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2236 &/PYINT1/,/PYINT2/,/PYINT5/
2237 C...Local arrays and character variables.
2238 DIMENSION ALAMIN(20),NFIN(20)
2239 CHARACTER*(*) FRAME,BEAM,TARGET
2240 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2242 C...Interface to PDFLIB.
2243 COMMON/W50512/QCDL4,QCDL5
2245 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2246 CHARACTER*20 PARM(20)
2247 DATA VALUE/20*0D0/,PARM/20*' '/
2249 C...Data:Lambda and n_f values for parton distributions..
2250 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2251 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2253 DATA CHLH/'lepton','hadron'/
2255 C...Reset MINT and VINT arrays. Write headers.
2260 IF(MSTU(12).GE.1) CALL PYLIST(0)
2261 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2263 C...Maximum 4 generations; set maximum number of allowed flavours.
2264 MSTP(1)=MIN(4,MSTP(1))
2265 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2266 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2268 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2272 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2275 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2276 IPM=(5-ISIGN(1,I))/2
2278 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2279 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2281 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2286 C...Initialize parton distributions: PDFLIB.
2287 IF(MSTP(52).EQ.2) THEN
2291 VALUE(2)=MSTP(51)/1000
2293 VALUE(3)=MOD(MSTP(51),1000)
2297 CALL PDFSET_ALICE(PARM,VALUE)
2298 MINT(93)=1000000+MSTP(51)
2301 C...Choose Lambda value to use in alpha-strong.
2303 IF(MSTP(3).GE.2) THEN
2306 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2307 ALAM=ALAMIN(MSTP(51))
2309 ELSEIF(MSTP(52).EQ.2) THEN
2318 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2321 C...Initialize the SUSY generation: couplings, masses,
2322 C...decay modes, branching ratios, and so on.
2325 C...Initialize widths and partial widths for resonances.
2327 C...Set Z0 mass and width for e+e- routines.
2328 PARJ(123)=PMAS(23,1)
2329 PARJ(124)=PMAS(23,2)
2331 C...Identify beam and target particles and frame of process.
2335 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2336 IF(MINT(65).EQ.1) GOTO 170
2338 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2339 C...For e-gamma allow 2 alternatives.
2341 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2342 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2343 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2344 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2345 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2346 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2347 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2348 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2349 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2350 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2351 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2352 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2353 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=2
2354 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2355 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2356 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2357 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=4
2358 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2361 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2362 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2363 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2364 IF(MSTP(14).EQ.11) MINT(123)=0
2365 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2366 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2367 IF(MSTP(14).EQ.15) MINT(123)=2
2368 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2369 IF(MSTP(14).EQ.19) MINT(123)=3
2370 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2371 IF(MSTP(14).EQ.21) MINT(123)=0
2372 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2373 IF(MSTP(14).EQ.24) MINT(123)=1
2374 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2375 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2376 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2379 C...Set up kinematics of process.
2382 C...Set up kinematics for photons inside leptons.
2383 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2385 C...Precalculate flavour selection weights.
2388 C...Loop over gamma-p or gamma-gamma alternatives.
2391 DO 160 IGA=1,MINT(121)
2395 C...Select partonic subprocesses to be included in the simulation.
2402 C...Count number of subprocesses on.
2405 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2406 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2408 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2409 & MSUB(ISUB).EQ.1) THEN
2410 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2412 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2413 WRITE(MSTU(11),5300) ISUB
2415 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2416 WRITE(MSTU(11),5400) ISUB
2418 ELSEIF(MSUB(ISUB).EQ.1) THEN
2422 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2423 WRITE(MSTU(11),5500)
2426 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2427 MSAV48=MSAV48+MINT(48)
2429 C...Reset variables for cross-section calculation.
2437 C...Find parametrized total cross-sections.
2441 C...Maxima of differential cross-sections.
2442 IF(MSTP(121).LE.1) CALL PYMAXI
2444 C...Initialize possibility of pileup events.
2445 IF(MINT(121).GT.1) MSTP(131)=0
2446 IF(MSTP(131).NE.0) CALL PYPILE(1)
2448 C...Initialize multiple interactions with variable impact parameter.
2449 IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2450 & MSTP(82).GE.2) CALL PYMULT(1)
2452 C...Save results for gamma-p and gamma-gamma alternatives.
2453 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2456 C...Initialization finished.
2457 IF(MSAV48.EQ.0) THEN
2458 WRITE(MSTU(11),5500)
2461 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2463 C...Formats for initialization information.
2464 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2465 &'routines',1X,17('*'))
2466 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2467 &'-',A6,' interactions.'/1X,'Execution stopped!')
2468 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2469 &1X,'Execution stopped!')
2470 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2471 &1X,'Execution stopped!')
2472 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2473 &1X,'Execution stopped.')
2474 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2480 C*********************************************************************
2483 C...Administers the generation of a high-pT event via calls to
2484 C...a number of subroutines.
2488 C...Double precision and integer declarations.
2489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2490 IMPLICIT INTEGER(I-N)
2491 INTEGER PYK,PYCHGE,PYCOMP
2493 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2494 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2495 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2496 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2497 COMMON/PYINT1/MINT(400),VINT(400)
2498 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2499 COMMON/PYINT4/MWID(500),WIDS(500,5)
2500 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2501 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
2502 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,
2503 &/PYINT4/,/PYINT5/,/PYUPPR/
2507 C...Initial values for some counters.
2518 C...If variable energies: redo incoming kinematics and cross-section.
2520 IF(MSTP(171).EQ.1) THEN
2522 IF(MSTI(61).EQ.1) THEN
2526 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2530 C...Loop over number of pileup events; check space left.
2531 IF(MSTP(131).LE.0) THEN
2537 DO 260 IPILE=1,NPILE
2538 IF(MINT(84)+100.GE.MSTU(4)) THEN
2540 & '(PYEVNT:) no more space in PYJETS for pileup events')
2541 IF(MSTU(21).GE.1) GOTO 270
2545 C...Generate variables of hard scattering.
2549 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2554 IF(MSTI(61).EQ.1) THEN
2558 IF(MINT(51).EQ.2) RETURN
2560 IF(MSTP(111).EQ.-1) GOTO 250
2562 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2563 C...Hard scattering (including low-pT):
2564 C...reconstruct kinematics and colour flow of hard scattering.
2569 IF(MINT(51).EQ.1) GOTO 100
2572 IF(ISUB.EQ.95) GOTO 130
2574 C...Showering of initial state partons (optional).
2577 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2579 IF(MINT(51).EQ.1) GOTO 100
2581 C...Showering of final state partons (optional).
2584 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2588 IF(ISET(ISUB).EQ.5) IPU4=-3
2590 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2591 CALL PYSHOW(IPU3,IPU4,QMAX)
2592 ELSEIF(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN
2594 IPU3=IFUP(IUP,1)+MINT(84)
2595 IPU4=IFUP(IUP,2)+MINT(84)
2596 QMAX=SQRT(MAX(0D0,Q2UP(IUP)))
2597 CALL PYSHOW(IPU3,IPU4,QMAX)
2602 C...Decay of final state resonances.
2604 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2605 IF(MINT(51).EQ.1) GOTO 100
2608 C...Multiple interactions.
2609 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2612 C...Hadron remnants and primordial kT.
2613 130 CALL PYREMN(IPU1,IPU2)
2614 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2615 IF(MINT(51).EQ.1) GOTO 100
2617 ELSEIF(ISUB.NE.99) THEN
2618 C...Diffractive and elastic scattering.
2622 C...DIS scattering (photon flux external).
2624 IF(MINT(51).EQ.1) GOTO 100
2627 C...Check that no odd resonance left undecayed.
2628 IF(MSTP(111).GE.1) THEN
2630 DO 140 I=MINT(84)+1,NFIX
2631 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2632 & K(I,2).NE.22) THEN
2633 IF(MWID(PYCOMP(K(I,2))).NE.0) THEN
2635 IF(MINT(51).EQ.1) GOTO 100
2641 C...Boost hadronic subsystem to overall rest frame.
2642 C..(Only relevant when photon inside lepton beam.)
2643 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2645 C...Recalculate energies from momenta and masses (if desired).
2646 IF(MSTP(113).GE.1) THEN
2647 DO 150 I=MINT(83)+1,N
2648 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2649 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2654 C...Rearrange partons along strings, check invariant mass cuts.
2656 IF(MSTP(111).LE.0) MSTJ(14)=-1
2657 CALL PYPREP(MINT(84)+1)
2659 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2660 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2661 DO 180 I=MINT(84)+1,N
2662 IF(K(I,2).EQ.94) THEN
2663 DO 170 I1=I+1,MIN(N,I+3)
2664 IF(K(I1,3).EQ.I) THEN
2665 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2666 IF(K(I1,3).EQ.0) THEN
2667 DO 160 II=MINT(84)+1,I-1
2668 IF(K(II,2).EQ.K(I1,2)) THEN
2669 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2670 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2673 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2681 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2682 IF(MSTP(125).EQ.0) MINT(4)=0
2683 DO 200 I=MINT(83)+1,N
2684 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2686 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2687 IF(K(I1,3).EQ.I) K(I,5)=I1
2693 C...Introduce separators between sections in PYLIST event listing.
2694 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2697 ELSEIF(IPILE.EQ.1) THEN
2704 C...Go back to lab frame (needed for vertices, also in fragmentation).
2707 C...Set nonvanishing production vertex (optional).
2708 IF(MSTP(151).EQ.1) THEN
2710 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2711 & SIN(PARU(2)*PYR(0))
2713 DO 230 I=MINT(83)+1,N
2715 V(I,J)=V(I,J)+VTX(J)
2720 C...Perform hadronization (if desired).
2721 IF(MSTP(111).GE.1) THEN
2723 IF(MSTU(24).NE.0) GOTO 100
2725 IF(MSTP(113).GE.1) THEN
2727 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
2728 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2731 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
2733 C...Store event information and calculate Monte Carlo estimates of
2734 C...subprocess cross-sections.
2735 250 IF(IPILE.EQ.1) CALL PYDOCU
2737 C...Set counters for current pileup event and loop to next one.
2739 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
2740 IF(MSTU70.LT.10) THEN
2745 MINT(84)=N+MSTP(126)
2746 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
2749 C...Generic information on pileup events. Reconstruct missing history.
2750 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
2754 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
2758 C...Transform to the desired coordinate frame.
2759 270 CALL PYFRAM(MSTP(124))
2766 C***********************************************************************
2769 C...Prints out information about cross-sections, decay widths, branching
2770 C...ratios, kinematical limits, status codes and parameter values.
2772 SUBROUTINE PYSTAT(MSTAT)
2774 C...Double precision and integer declarations.
2775 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2776 IMPLICIT INTEGER(I-N)
2777 INTEGER PYK,PYCHGE,PYCOMP
2778 C...Parameter statement to help give large particle numbers.
2779 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2781 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2782 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2783 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2784 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2785 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2786 COMMON/PYINT1/MINT(400),VINT(400)
2787 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2788 COMMON/PYINT4/MWID(500),WIDS(500,5)
2789 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2790 COMMON/PYINT6/PROC(0:500)
2792 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2793 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
2794 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/
2795 C...Local arrays, character variables and data.
2796 DIMENSION WDTP(0:200),WDTE(0:200,0:5)
2797 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
2798 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
2799 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
2801 &'VMD/hadron * VMD ','VMD/hadron * direct ',
2802 &'VMD/hadron * anomalous ','direct * direct ',
2803 &'direct * anomalous ','anomalous * anomalous '/
2804 DATA DISGA/'e * VMD','e * anomalous'/
2806 &'direct * direct ','direct * VMD ',
2807 &'direct * anomalous ','VMD * direct ',
2808 &'VMD * VMD ','VMD * anomalous ',
2809 &'anomalous * direct ','anomalous * VMD ',
2810 &'anomalous * anomalous ','DIS * VMD ',
2811 &'DIS * anomalous ','VMD * DIS ',
2812 &'anomalous * DIS '/
2814 &'direct * direct ','direct * resolved ',
2815 &'resolved * direct ','resolved * resolved '/
2817 &'direct * hadron ','resolved * hadron '/
2819 &'VMD * hadron ','direct * hadron ',
2820 &'anomalous * hadron ','DIS * hadron '/
2821 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
2822 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2823 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
2824 &' y*_small ',' eta*_large ',' eta*_small ',
2825 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
2826 &' x_2 ',' x_F ',' cos(theta_hard) ',
2827 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
2828 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
2833 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
2834 WRITE(MSTU(11),5000)
2835 WRITE(MSTU(11),5100)
2836 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
2838 IF(MSUB(I).NE.1) GOTO 100
2839 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
2841 IF(MINT(121).GT.1) THEN
2842 WRITE(MSTU(11),5300)
2843 DO 110 IGA=1,MINT(121)
2845 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
2846 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
2848 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
2849 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
2851 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
2852 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
2854 ELSEIF(MINT(121).EQ.4) THEN
2855 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
2857 ELSEIF(MINT(121).EQ.2) THEN
2858 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
2861 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
2867 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
2868 & MAX(1D0,DBLE(NGEN(0,2)))
2870 C...Decay widths and branching ratios.
2871 ELSEIF(MSTAT.EQ.2) THEN
2872 WRITE(MSTU(11),5500)
2873 WRITE(MSTU(11),5600)
2876 CALL PYNAME(KF,CHKF)
2879 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
2880 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
2881 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
2882 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
2883 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
2885 IF(MWID(KC).LE.0) GOTO 140
2886 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
2887 & KF/KSUSY1.EQ.2)) GOTO 140
2889 C...Off-shell branchings.
2892 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
2893 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
2894 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
2895 DO 120 J=1,MDCY(KC,3)
2898 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2899 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2901 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2902 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2903 CALL PYNAME(KFDP(IDC,1),CHD1)
2904 CALL PYNAME(KFDP(IDC,2),CHD2)
2905 IF(KFDP(IDC,3).EQ.0) THEN
2906 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2907 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2908 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2910 CALL PYNAME(KFDP(IDC,3),CHD3)
2911 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2912 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2913 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2916 C...On-shell decays.
2918 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
2920 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
2921 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
2922 & STATE(MDCY(KC,1)),BRFIN
2923 DO 130 J=1,MDCY(KC,3)
2926 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2927 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2929 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2930 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2932 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
2933 CALL PYNAME(KFDP(IDC,1),CHD1)
2934 CALL PYNAME(KFDP(IDC,2),CHD2)
2935 IF(KFDP(IDC,3).EQ.0) THEN
2936 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2937 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2938 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
2939 & STATE(MDME(IDC,1)),BRFIN
2941 CALL PYNAME(KFDP(IDC,3),CHD3)
2942 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2943 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2944 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
2945 & STATE(MDME(IDC,1)),BRFIN
2950 WRITE(MSTU(11),6000)
2952 C...Allowed incoming partons/particles at hard interaction.
2953 ELSEIF(MSTAT.EQ.3) THEN
2954 WRITE(MSTU(11),6100)
2955 CALL PYNAME(MINT(11),CHAU)
2957 CALL PYNAME(MINT(12),CHAU)
2959 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
2963 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
2964 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
2966 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
2969 WRITE(MSTU(11),6400)
2971 C...User-defined limits on kinematical variables.
2972 ELSEIF(MSTAT.EQ.4) THEN
2973 WRITE(MSTU(11),6500)
2974 WRITE(MSTU(11),6600)
2976 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
2977 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
2978 PTHMIN=MAX(CKIN(3),CKIN(5))
2980 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
2981 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
2982 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
2984 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
2987 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
2988 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
2989 WRITE(MSTU(11),7000)
2991 C...Status codes and parameter values.
2992 ELSEIF(MSTAT.EQ.5) THEN
2993 WRITE(MSTU(11),7100)
2994 WRITE(MSTU(11),7200)
2996 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
3000 C...List of all processes implemented in the program.
3001 ELSEIF(MSTAT.EQ.6) THEN
3002 WRITE(MSTU(11),7400)
3003 WRITE(MSTU(11),7500)
3005 IF(ISET(I).LT.0) GOTO 180
3006 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3008 WRITE(MSTU(11),7700)
3011 C...Formats for printouts.
3012 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
3013 &'Events and Cross-sections',1X,9('*'))
3014 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3015 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3016 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3017 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3018 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3019 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3021 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3023 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3024 &1X,'I',34X,'I',28X,'I',12X,'I')
3025 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3026 &1X,'********* Fraction of events that fail fragmentation ',
3027 &'cuts =',1X,F8.5,' *********'/)
3028 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
3029 &'Ratios',1X,27('*'))
3030 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3031 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
3032 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3033 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3035 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3036 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3037 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3038 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3039 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3040 &1P,D10.3,0P,1X,'I')
3041 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3042 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3043 &1P,D10.3,0P,1X,'I')
3044 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3045 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3046 &'Particles at Hard Interaction',1X,7('*'))
3047 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3048 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3049 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3050 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3051 &78('=')/1X,'I',38X,'I',37X,'I')
3052 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3053 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3054 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3055 &'Kinematical Variables',1X,12('*'))
3056 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3057 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3059 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3060 &1X,'<',1X,1P,D10.3,0P,16X,'I')
3061 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3062 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3063 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3064 &'Parameter Values',1X,12('*'))
3065 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3067 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3068 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3070 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3071 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3072 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3073 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3074 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3079 C*********************************************************************
3082 C...Calculates full and effective widths of gauge bosons, stores
3083 C...masses and widths, rescales coefficients to be used for
3084 C...resonance production generation.
3088 C...Double precision and integer declarations.
3089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3090 IMPLICIT INTEGER(I-N)
3091 INTEGER PYK,PYCHGE,PYCOMP
3092 C...Parameter statement to help give large particle numbers.
3093 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
3095 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3096 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3097 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3098 COMMON/PYDAT4/CHAF(500,2)
3100 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3101 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3102 COMMON/PYINT1/MINT(400),VINT(400)
3103 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3104 COMMON/PYINT4/MWID(500),WIDS(500,5)
3105 COMMON/PYINT6/PROC(0:500)
3107 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3108 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3109 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3110 C...Local arrays and data.
3111 DIMENSION WDTP(0:200),WDTE(0:200,0:5),WDTPM(0:200),
3112 &WDTEM(0:200,0:5),KCORD(500),PMORD(500)
3114 C...Born level couplings in MSSM Higgs doublet sector.
3117 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3119 IF(MSTP(4).EQ.2) THEN
3121 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3125 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3126 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3128 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3129 WRITE(MSTU(11),5000)
3132 PMAS(35,1)=SQRT(SQMHP)
3133 PMAS(36,1)=SQRT(SQMA)
3134 PMAS(37,1)=SQRT(SQMHC)
3135 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3140 PARU(161)=-SIN(ALSU)/COS(BESU)
3141 PARU(162)=COS(ALSU)/SIN(BESU)
3143 PARU(164)=SIN(BESU-ALSU)
3145 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3146 PARU(171)=COS(ALSU)/COS(BESU)
3147 PARU(172)=SIN(ALSU)/SIN(BESU)
3149 PARU(174)=COS(BESU-ALSU)
3151 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3153 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3154 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3160 PARU(186)=COS(BESU-ALSU)
3161 PARU(187)=SIN(BESU-ALSU)
3165 PARU(195)=COS(BESU-ALSU)
3168 C...Reset effective widths of gauge bosons.
3175 C...Order resonances by increasing mass (except Z0 and W+/-).
3179 IF(KF.EQ.0) GOTO 140
3180 IF(MWID(KC).EQ.0) GOTO 140
3181 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3182 IF(MSTP(1).LE.3) GOTO 140
3184 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3185 IF(IMSS(1).LE.0) GOTO 140
3189 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3190 DO 120 I1=NRES-1,1,-1
3191 IF(PMRES.GE.PMORD(I1)) GOTO 130
3192 KCORD(I1+1)=KCORD(I1)
3193 PMORD(I1+1)=PMORD(I1)
3199 C...Loop over possible resonances.
3204 C...Check that no fourth generation channels on by mistake.
3205 IF(MSTP(1).LE.3) THEN
3206 DO 150 J=1,MDCY(KC,3)
3208 KFA1=IABS(KFDP(IDC,1))
3209 KFA2=IABS(KFDP(IDC,2))
3210 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3211 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3216 C...Check that no supersymmetric channels on by mistake.
3217 IF(IMSS(1).LE.0) THEN
3218 DO 160 J=1,MDCY(KC,3)
3220 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3221 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3222 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3227 C...Find mass and evaluate width.
3229 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3230 IF(MWID(KC).EQ.3) MINT(63)=1
3231 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3234 C...Evaluate suppression factors due to non-simulated channels.
3235 IF(KCHG(KC,3).EQ.0) THEN
3236 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3237 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3238 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3239 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3244 IF(MWID(KC).EQ.3) MINT(63)=1
3245 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3247 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3248 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3249 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3250 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3251 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3252 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3253 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3254 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3255 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3256 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3257 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3258 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3261 C...Set resonance widths and branching ratios;
3262 C...also on/off switch for decays.
3263 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3265 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3267 DO 170 J=1,MDCY(KC,3)
3270 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3275 C...Flavours of leptoquark: redefine charge and name.
3276 KFLQQ=KFDP(MDCY(39,2),1)
3277 KFLQL=KFDP(MDCY(39,2),2)
3278 KCHG(39,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3279 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3281 IF(IABS(KFLQL).EQ.13) LL=2
3282 IF(IABS(KFLQL).EQ.15) LL=3
3283 CHAF(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3284 &CHAF(IABS(KFLQL),1)(1:LL)//' '
3285 CHAF(39,2)=CHAF(39,2)(1:4+LL)//'bar '
3287 C...Special cases in treatment of gamma*/Z0: redefine process name.
3288 IF(MSTP(43).EQ.1) THEN
3289 PROC(1)='f + fbar -> gamma*'
3290 PROC(15)='f + fbar -> g + gamma*'
3291 PROC(19)='f + fbar -> gamma + gamma*'
3292 PROC(30)='f + g -> f + gamma*'
3293 PROC(35)='f + gamma -> f + gamma*'
3294 ELSEIF(MSTP(43).EQ.2) THEN
3295 PROC(1)='f + fbar -> Z0'
3296 PROC(15)='f + fbar -> g + Z0'
3297 PROC(19)='f + fbar -> gamma + Z0'
3298 PROC(30)='f + g -> f + Z0'
3299 PROC(35)='f + gamma -> f + Z0'
3300 ELSEIF(MSTP(43).EQ.3) THEN
3301 PROC(1)='f + fbar -> gamma*/Z0'
3302 PROC(15)='f + fbar -> g + gamma*/Z0'
3303 PROC(19)='f + fbar -> gamma + gamma*/Z0'
3304 PROC(30)='f + g -> f + gamma*/Z0'
3305 PROC(35)='f + gamma -> f + gamma*/Z0'
3308 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3309 IF(MSTP(44).EQ.1) THEN
3310 PROC(141)='f + fbar -> gamma*'
3311 ELSEIF(MSTP(44).EQ.2) THEN
3312 PROC(141)='f + fbar -> Z0'
3313 ELSEIF(MSTP(44).EQ.3) THEN
3314 PROC(141)='f + fbar -> Z''0'
3315 ELSEIF(MSTP(44).EQ.4) THEN
3316 PROC(141)='f + fbar -> gamma*/Z0'
3317 ELSEIF(MSTP(44).EQ.5) THEN
3318 PROC(141)='f + fbar -> gamma*/Z''0'
3319 ELSEIF(MSTP(44).EQ.6) THEN
3320 PROC(141)='f + fbar -> Z0/Z''0'
3321 ELSEIF(MSTP(44).EQ.7) THEN
3322 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3325 C...Special cases in treatment of WW -> WW: redefine process name.
3326 IF(MSTP(45).EQ.1) THEN
3327 PROC(77)='W+ + W+ -> W+ + W+'
3328 ELSEIF(MSTP(45).EQ.2) THEN
3329 PROC(77)='W+ + W- -> W+ + W-'
3330 ELSEIF(MSTP(45).EQ.3) THEN
3331 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3334 C...Format for error information.
3335 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3336 &'combination'/1X,'Execution stopped!')
3341 C*********************************************************************
3344 C...Identifies the two incoming particles and the choice of frame.
3346 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3348 C...Double precision and integer declarations.
3349 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3350 IMPLICIT INTEGER(I-N)
3351 INTEGER PYK,PYCHGE,PYCOMP
3353 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3354 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3355 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3356 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3357 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3358 COMMON/PYINT1/MINT(400),VINT(400)
3359 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3360 C...Local arrays, character variables and data.
3361 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
3362 &CHIDNT(3)*12,CHTEMP*12,CHCDE(35)*12,CHINIT*76
3363 DIMENSION LEN(3),KCDE(35),PM(2)
3364 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3365 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3366 DATA CHCDE/ 'e- ','e+ ','nu_e ',
3367 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
3368 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
3369 &'nu_taubar ','pi+ ','pi- ','n0 ',
3370 &'nbar0 ','p+ ','pbar- ','gamma ',
3371 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
3372 &'xi- ','xi0 ','omega- ','pi0 ',
3373 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
3374 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ '/
3375 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3376 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3377 &3312,3322,3334,111,28,29,6*22/
3379 C...Store initial energy. Default frame.
3383 C...Convert character variables to lowercase and find their length.
3390 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
3392 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
3398 C...Fix up bar, underscore and charge in particle name (if needed).
3400 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
3402 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
3405 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
3407 CHIDNT(I)='nu_'//CHTEMP(3:7)
3408 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
3409 CHIDNT(I)(1:3)='n0 '
3410 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
3411 CHIDNT(I)(1:5)='nbar0'
3412 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
3413 CHIDNT(I)(1:3)='p+ '
3414 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
3415 & CHIDNT(I)(1:2).EQ.'p-') THEN
3416 CHIDNT(I)(1:5)='pbar-'
3417 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
3419 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
3420 CHIDNT(I)(1:7)='reggeon'
3421 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
3422 CHIDNT(I)(1:7)='pomeron'
3426 C...Identify free initialization.
3427 IF(CHCOM(1)(1:2).EQ.'no') THEN
3432 C...Identify incoming beam and target particles.
3435 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
3437 PM(I)=PYMASS(MINT(10+I))
3440 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
3441 CHTEMP=CHIDNT(I+1)(7:12)//' '
3443 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
3445 PM(I)=PYMASS(MINT(140+I))
3449 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
3450 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
3451 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
3453 C...Identify choice of frame and input energies.
3456 C...Events defined in the CM frame.
3457 IF(CHCOM(1)(1:2).EQ.'cm') THEN
3460 IF(MSTP(122).GE.1) THEN
3461 IF(CHCOM(2)(1:1).NE.'e') THEN
3462 LOFFS=(31-(LEN(2)+LEN(3)))/2
3463 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
3464 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3467 LOFFS=(30-(LEN(2)+LEN(3)))/2
3468 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
3469 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3472 WRITE(MSTU(11),5200) CHINIT
3473 WRITE(MSTU(11),5300) WIN
3476 C...Events defined in fixed target frame.
3477 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
3479 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
3480 IF(MSTP(122).GE.1) THEN
3481 LOFFS=(29-(LEN(2)+LEN(3)))/2
3482 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3483 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3484 & ' fixed target'//' '
3485 WRITE(MSTU(11),5200) CHINIT
3486 WRITE(MSTU(11),5400) WIN
3487 WRITE(MSTU(11),5500) SQRT(S)
3490 C...Frame defined by user three-vectors.
3491 ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
3495 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3496 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3497 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3498 & (P(1,3)+P(2,3))**2
3499 IF(MSTP(122).GE.1) THEN
3500 LOFFS=(22-(LEN(2)+LEN(3)))/2
3501 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3502 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3503 & ' user configuration'//' '
3504 WRITE(MSTU(11),5200) CHINIT
3505 WRITE(MSTU(11),5600)
3506 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3507 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3508 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3511 C...Frame defined by user four-vectors.
3512 ELSEIF(CHCOM(1)(1:4).EQ.'four') THEN
3514 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3515 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3516 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3517 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3518 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3519 & (P(1,3)+P(2,3))**2
3520 IF(MSTP(122).GE.1) THEN
3521 LOFFS=(22-(LEN(2)+LEN(3)))/2
3522 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3523 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3524 & ' user configuration'//' '
3525 WRITE(MSTU(11),5200) CHINIT
3526 WRITE(MSTU(11),5600)
3527 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3528 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3529 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3532 C...Frame defined by user five-vectors.
3533 ELSEIF(CHCOM(1)(1:4).EQ.'five') THEN
3535 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3536 & (P(1,3)+P(2,3))**2
3537 IF(MSTP(122).GE.1) THEN
3538 LOFFS=(22-(LEN(2)+LEN(3)))/2
3539 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3540 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3541 & ' user configuration'//' '
3542 WRITE(MSTU(11),5200) CHINIT
3543 WRITE(MSTU(11),5600)
3544 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3545 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3546 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3549 C...Unknown frame. Error for too low CM energy.
3551 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
3554 IF(S.LT.PARP(2)**2) THEN
3555 WRITE(MSTU(11),5900) SQRT(S)
3559 C...Formats for initialization and error information.
3560 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
3561 &1X,'Execution stopped!')
3562 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
3563 &1X,'Execution stopped!')
3564 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
3565 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
3566 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
3567 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
3568 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
3569 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
3570 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
3571 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
3572 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
3573 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
3574 &1X,'Execution stopped!')
3575 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
3576 &'generation.'/1X,'Execution stopped!')
3581 C*********************************************************************
3584 C...Sets up kinematics, including rotations and boosts to/from CM frame.
3586 SUBROUTINE PYINKI(MODKI)
3588 C...Double precision and integer declarations.
3589 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3590 IMPLICIT INTEGER(I-N)
3591 INTEGER PYK,PYCHGE,PYCOMP
3593 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3596 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3597 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3598 COMMON/PYINT1/MINT(400),VINT(400)
3599 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3601 C...Set initial flavour state.
3606 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
3609 C...Reset boost. Do kinematics for various cases.
3614 C...Set up kinematics for events defined in CM frame.
3615 IF(MINT(111).EQ.1) THEN
3617 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3621 IF(MINT(141).NE.0) P(1,5)=VINT(303)
3622 IF(MINT(142).NE.0) P(2,5)=VINT(304)
3627 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
3630 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3631 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
3633 C...Set up kinematics for fixed target events.
3634 ELSEIF(MINT(111).EQ.2) THEN
3636 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3639 IF(MINT(141).NE.0) P(1,5)=VINT(303)
3640 IF(MINT(142).NE.0) P(2,5)=VINT(304)
3646 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3649 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
3650 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
3651 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
3653 C...Set up kinematics for events in user-defined frame.
3654 ELSEIF(MINT(111).EQ.3) THEN
3657 IF(MINT(141).NE.0) P(1,5)=VINT(303)
3658 IF(MINT(142).NE.0) P(2,5)=VINT(304)
3659 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3660 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3662 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3664 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3665 VINT(7)=PYANGL(P(1,1),P(1,2))
3666 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3667 VINT(6)=PYANGL(P(1,3),P(1,1))
3668 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3669 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
3671 C...Set up kinematics for events with user-defined four-vectors.
3672 ELSEIF(MINT(111).EQ.4) THEN
3673 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3674 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3675 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3676 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3678 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3680 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3681 VINT(7)=PYANGL(P(1,1),P(1,2))
3682 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3683 VINT(6)=PYANGL(P(1,3),P(1,1))
3684 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3685 S=(P(1,4)+P(2,4))**2
3687 C...Set up kinematics for events with user-defined five-vectors.
3688 ELSEIF(MINT(111).EQ.5) THEN
3690 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3692 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3693 VINT(7)=PYANGL(P(1,1),P(1,2))
3694 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3695 VINT(6)=PYANGL(P(1,3),P(1,1))
3696 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3697 S=(P(1,4)+P(2,4))**2
3700 C...Return or error for too low CM energy.
3701 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
3702 IF(MSTP(172).LE.1) THEN
3704 & '(PYINKI:) too low invariant mass in this event')
3711 C...Save information on incoming particles.
3714 IF(MINT(111).GE.4) THEN
3715 IF(MINT(141).EQ.0) THEN
3717 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
3721 IF(MINT(142).EQ.0) THEN
3723 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
3729 IF(MODKI.EQ.0) VINT(289)=S
3737 C...Store pT cut-off and related constants to be used in generation.
3738 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
3739 IF(MSTP(82).LE.1) THEN
3740 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
3742 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3744 VINT(149)=4D0*PTMN**2/S
3750 C*********************************************************************
3753 C...Selects partonic subprocesses to be included in the simulation.
3757 C...Double precision and integer declarations.
3758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3759 IMPLICIT INTEGER(I-N)
3760 INTEGER PYK,PYCHGE,PYCOMP
3762 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3763 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3764 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3765 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3766 COMMON/PYINT1/MINT(400),VINT(400)
3767 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3768 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
3770 C...Reset processes to be included.
3777 C...Set running pTmin scale.
3778 IF(MSTP(82).LE.1) THEN
3779 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
3781 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3784 C...Begin by assuming incoming photon to enter subprocess.
3785 IF(MINT(11).EQ.22) MINT(15)=22
3786 IF(MINT(12).EQ.22) MINT(16)=22
3788 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
3789 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3791 MINT(123)=MINT(122)+1
3793 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
3795 C...Here also set a few parameters otherwise normally not touched.
3796 ELSEIF(MINT(121).GT.1) THEN
3798 C...Parton distributions dampened at small Q2; go to low energies,
3799 C...alpha_s <1; no minimum pT cut-off a priori.
3800 IF(MSTP(18).EQ.2) THEN
3808 C...Define pT cut-off parameters and whether run involves low-pT.
3812 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
3814 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
3815 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
3817 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
3818 IF(MSEL.EQ.2) IPTL=1
3820 C...Set up for p/gamma * gamma; real or virtual photons.
3821 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
3822 & MSTP(14).EQ.30)) THEN
3824 C...Set up for p/VMD * VMD.
3825 IF(MINT(122).EQ.1) THEN
3833 IF(IPTL.EQ.1) MSUB(95)=1
3840 IF(IPTL.EQ.1) CKIN(3)=0D0
3842 C...Set up for p/VMD * direct gamma.
3843 ELSEIF(MINT(122).EQ.2) THEN
3845 IF(MINT(121).EQ.6) MINT(123)=5
3850 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3852 C...Set up for p/VMD * anomalous gamma.
3853 ELSEIF(MINT(122).EQ.3) THEN
3855 IF(MINT(121).EQ.6) MINT(123)=7
3862 IF(IPTL.EQ.1) MSUB(95)=1
3869 IF(IPTL.EQ.1) CKIN(3)=0D0
3871 C...Set up for DIS * p.
3872 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GE.28.OR.
3873 & IABS(MINT(12)).GE.28)) THEN
3875 IF(IPTL.EQ.1) MSUB(99)=1
3877 C...Set up for direct * direct gamma (switch off leptons).
3878 ELSEIF(MINT(122).EQ.4) THEN
3884 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3885 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3887 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3889 C...Set up for direct * anomalous gamma.
3890 ELSEIF(MINT(122).EQ.5) THEN
3896 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3898 C...Set up for anomalous * anomalous gamma.
3899 ELSEIF(MINT(122).EQ.6) THEN
3907 IF(IPTL.EQ.1) MSUB(95)=1
3914 IF(IPTL.EQ.1) CKIN(3)=0D0
3917 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
3918 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3920 C...Set up for direct * direct gamma (switch off leptons).
3921 IF(MINT(122).EQ.1) THEN
3927 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3928 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3930 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3932 C...Set up for direct * VMD and VMD * direct gamma.
3933 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
3939 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3941 C...Set up for direct * anomalous and anomalous * direct gamma.
3942 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
3948 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3950 C...Set up for VMD*VMD.
3951 ELSEIF(MINT(122).EQ.5) THEN
3959 IF(IPTL.EQ.1) MSUB(95)=1
3966 IF(IPTL.EQ.1) CKIN(3)=0D0
3968 C...Set up for VMD * anomalous and anomalous * VMD gamma.
3969 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
3977 IF(IPTL.EQ.1) MSUB(95)=1
3984 IF(IPTL.EQ.1) CKIN(3)=0D0
3986 C...Set up for anomalous * anomalous gamma.
3987 ELSEIF(MINT(122).EQ.9) THEN
3995 IF(IPTL.EQ.1) MSUB(95)=1
4002 IF(IPTL.EQ.1) CKIN(3)=0D0
4004 C...Set up for DIS * VMD and VMD * DIS gamma.
4005 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4007 IF(IPTL.EQ.1) MSUB(99)=1
4009 C...Set up for DIS * anomalous and anomalous * DIS gamma.
4010 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4012 IF(IPTL.EQ.1) MSUB(99)=1
4015 C...Set up for gamma* * p; virtual photons = dir, res.
4016 ELSEIF(MINT(121).EQ.2) THEN
4018 C...Set up for direct * p.
4019 IF(MINT(122).EQ.1) THEN
4025 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4027 C...Set up for resolved * p.
4028 ELSEIF(MINT(122).EQ.2) THEN
4036 IF(IPTL.EQ.1) MSUB(95)=1
4043 IF(IPTL.EQ.1) CKIN(3)=0D0
4046 C...Set up for gamma* * gamma*; virtual photons = dir, res.
4047 ELSEIF(MINT(121).EQ.4) THEN
4049 C...Set up for direct * direct gamma (switch off leptons).
4050 IF(MINT(122).EQ.1) THEN
4056 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4057 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4059 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4061 C...Set up for direct * resolved and resolved * direct gamma.
4062 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4068 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4070 C...Set up for resolved * resolved gamma.
4071 ELSEIF(MINT(122).EQ.4) THEN
4079 IF(IPTL.EQ.1) MSUB(95)=1
4086 IF(IPTL.EQ.1) CKIN(3)=0D0
4089 C...End of special set up for gamma-p and gamma-gamma.
4094 C...Flavour information for individual beams.
4097 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4098 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4099 IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2
4100 MINT(44+I)=MINT(40+I)
4101 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4102 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4105 C...If two real gammas, whereof one direct, pick the first.
4106 C...For two virtual photons, keep requested order.
4107 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4108 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4111 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4112 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4115 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4116 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4119 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4120 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4123 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4124 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4127 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4130 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4134 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4135 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4136 IF(MINT(11).EQ.22) THEN
4144 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4145 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4148 C...Flavour information on combination of incoming particles.
4149 MINT(43)=2*MINT(41)+MINT(42)-2
4151 IF(MINT(123).LE.0) THEN
4152 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4153 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4154 ELSEIF(MINT(123).LE.3) THEN
4155 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4156 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4157 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4161 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4162 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4163 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4164 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4166 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
4169 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4170 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
4172 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
4174 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
4175 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
4176 & MINT(122).EQ.10) MINT(108)=2
4177 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
4178 & MINT(122).EQ.11) MINT(108)=3
4179 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
4180 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
4181 IF(MINT(122).GE.3) MINT(107)=1
4182 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
4183 ELSEIF(MINT(121).EQ.2) THEN
4184 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
4185 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
4187 IF(MINT(11).EQ.22) THEN
4189 IF(MINT(123).GE.4) MINT(107)=0
4190 IF(MINT(123).EQ.7) MINT(107)=2
4191 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
4192 IF(MSTP(14).EQ.28) MINT(107)=2
4193 IF(MSTP(14).EQ.29) MINT(107)=3
4194 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4197 IF(MINT(12).EQ.22) THEN
4199 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
4200 IF(MINT(123).EQ.7) MINT(108)=3
4201 IF(MSTP(14).EQ.26) MINT(108)=2
4202 IF(MSTP(14).EQ.27) MINT(108)=3
4203 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
4204 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4207 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
4208 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
4214 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
4215 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
4217 C...Select default processes according to incoming beams
4218 C...(already done for gamma-p and gamma-gamma with
4219 C...MSTP(14) = 10, 20, 25 or 30).
4220 IF(MINT(121).GT.1) THEN
4221 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
4223 IF(MINT(43).EQ.1) THEN
4224 C...Lepton + lepton -> gamma/Z0 or W.
4225 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
4226 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
4228 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
4229 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
4230 C...Unresolved photon + lepton: Compton scattering.
4234 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
4235 & .OR.MINT(12).EQ.22)) THEN
4236 C...DIS as pure gamma* + f -> f process.
4239 ELSEIF(MINT(43).LE.3) THEN
4240 C...Lepton + hadron: deep inelastic scattering.
4243 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
4244 & MINT(12).EQ.22) THEN
4245 C...Two unresolved photons: fermion pair production,
4246 C...exclude lepton pairs.
4250 DO 155 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4251 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4254 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4255 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
4256 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
4258 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
4259 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
4260 & MINT(12).EQ.22)) THEN
4261 C...Unresolved photon + hadron: photon-parton scattering.
4266 ELSEIF(MSEL.EQ.1) THEN
4267 C...High-pT QCD processes:
4276 IF(CKIN(3).LT.PTMN) MSUB(95)=1
4277 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
4280 C...All QCD processes:
4294 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
4295 C...Heavy quark production.
4299 DO 170 J=1,MIN(8,MDCY(21,3))
4300 MDME(MDCY(21,2)+J-1,1)=0
4302 MDME(MDCY(21,2)+MSEL-1,1)=1
4304 DO 180 J=1,MIN(12,MDCY(22,3))
4305 MDME(MDCY(22,2)+J-1,1)=0
4307 MDME(MDCY(22,2)+MSEL-1,1)=1
4309 ELSEIF(MSEL.EQ.10) THEN
4310 C...Prompt photon production:
4315 ELSEIF(MSEL.EQ.11) THEN
4316 C...Z0/gamma* production:
4319 ELSEIF(MSEL.EQ.12) THEN
4320 C...W+/- production:
4323 ELSEIF(MSEL.EQ.13) THEN
4328 ELSEIF(MSEL.EQ.14) THEN
4333 ELSEIF(MSEL.EQ.15) THEN
4334 C...Z0 & W+/- pair production:
4341 ELSEIF(MSEL.EQ.16) THEN
4349 ELSEIF(MSEL.EQ.17) THEN
4350 C...h0 & Z0 or W+/- pair production:
4354 ELSEIF(MSEL.EQ.18) THEN
4355 C...h0 production; interesting processes in e+e-.
4361 ELSEIF(MSEL.EQ.19) THEN
4362 C...h0, H0 and A0 production; interesting processes in e+e-.
4376 ELSEIF(MSEL.EQ.21) THEN
4380 ELSEIF(MSEL.EQ.22) THEN
4381 C...W'+/- production:
4384 ELSEIF(MSEL.EQ.23) THEN
4385 C...H+/- production:
4388 ELSEIF(MSEL.EQ.24) THEN
4392 ELSEIF(MSEL.EQ.25) THEN
4393 C...LQ (leptoquark) production.
4399 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
4400 C...Production of one heavy quark (W exchange):
4402 DO 190 J=1,MIN(8,MDCY(21,3))
4403 MDME(MDCY(21,2)+J-1,1)=0
4405 MDME(MDCY(21,2)+MSEL-31,1)=1
4407 CMRENNA++Define SUSY alternatives.
4408 ELSEIF(MSEL.EQ.39) THEN
4409 C...Turn on all SUSY processes.
4410 IF(MINT(43).EQ.4) THEN
4411 C...Hadron-hadron processes.
4413 IF(ISET(I).GE.0) MSUB(I)=1
4415 ELSEIF(MINT(43).EQ.1) THEN
4416 C...Lepton-lepton processes: QED production of squarks.
4433 ELSEIF(MSEL.EQ.40) THEN
4434 C...Gluinos and squarks.
4435 IF(MINT(43).EQ.4) THEN
4447 ELSEIF(MINT(43).EQ.1) THEN
4452 ELSEIF(MSEL.EQ.41) THEN
4453 C...Stop production.
4457 IF(MINT(43).EQ.4) THEN
4462 ELSEIF(MSEL.EQ.42) THEN
4463 C...Slepton production.
4467 IF(MINT(43).NE.4) THEN
4473 ELSEIF(MSEL.EQ.43) THEN
4474 C...Neutralino/Chargino + Gluino/Squark.
4475 IF(MINT(43).EQ.4) THEN
4484 ELSEIF(MSEL.EQ.44) THEN
4485 C...Neutralino/Chargino pair production.
4486 IF(MINT(43).EQ.4) THEN
4490 ELSEIF(MINT(43).EQ.1) THEN
4496 ELSEIF(MSEL.EQ.45) THEN
4497 C...Sbottom production.
4500 IF(MINT(43).EQ.4) THEN
4506 ELSEIF(MSEL.EQ.50) THEN
4510 IF(MINT(43).EQ.4) THEN
4518 C...Find heaviest new quark flavour allowed in processes 81-84.
4520 DO 310 I=1,MIN(8,MDCY(21,3))
4522 IF(MDME(IDC,1).LE.0) GOTO 310
4525 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
4536 C...Find heaviest new fermion flavour allowed in process 85.
4538 DO 320 I=1,MIN(12,MDCY(22,3))
4540 IF(MDME(IDC,1).LE.0) GOTO 320
4543 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
4544 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
4552 C*********************************************************************
4555 C...Parametrizes total, elastic and diffractive cross-sections
4556 C...for different energies and beams. Donnachie-Landshoff for
4557 C...total and Schuler-Sjostrand for elastic and diffractive.
4558 C...Process code IPROC:
4565 C...= 7 : J/psi + p;
4566 C...= 11 : rho + rho;
4567 C...= 12 : rho + phi;
4568 C...= 13 : rho + J/psi;
4569 C...= 14 : phi + phi;
4570 C...= 15 : phi + J/psi;
4571 C...= 16 : J/psi + J/psi;
4572 C...= 21 : gamma + p (DL);
4573 C...= 22 : gamma + p (VDM).
4574 C...= 23 : gamma + pi (DL);
4575 C...= 24 : gamma + pi (VDM);
4576 C...= 25 : gamma + gamma (DL);
4577 C...= 26 : gamma + gamma (VDM).
4581 C...Double precision and integer declarations.
4582 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4583 IMPLICIT INTEGER(I-N)
4584 INTEGER PYK,PYCHGE,PYCOMP
4586 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4587 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4588 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4589 COMMON/PYINT1/MINT(400),VINT(400)
4590 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4591 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4592 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
4594 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
4595 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
4596 &CEFFD(10,9),SIGTMP(6,0:5)
4598 C...Common constants.
4599 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
4600 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
4603 C...Number of multiple processes to be evaluated (= 0 : undefined).
4604 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4605 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4606 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
4607 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
4608 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
4610 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
4611 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
4612 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
4614 C...Beam and target hadron class:
4615 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4616 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4617 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
4618 C...Characteristic class masses, slope parameters, beta = sqrt(X).
4619 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
4620 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
4621 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
4623 C...Fitting constants used in parametrizations of diffractive results.
4624 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4625 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4626 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
4627 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
4628 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
4629 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
4630 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
4631 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
4632 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
4633 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
4634 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
4635 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
4636 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
4637 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
4638 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
4639 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
4640 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
4641 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
4642 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
4643 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
4644 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
4645 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
4646 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
4647 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
4648 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
4649 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
4650 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
4651 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
4652 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
4654 C...Parameters. Combinations of the energy.
4663 C...Ratio of gamma/pi (for rescaling in parton distributions).
4664 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
4665 &(XPAR(5)*SEPS+YPAR(5)*SETA)
4667 IF(MINT(50).NE.1) RETURN
4669 C...Order flavours of incoming particles: KF1 < KF2.
4670 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
4679 ISGN12=ISIGN(1,MINT(11)*MINT(12))
4681 C...Find process number (for lookup tables).
4682 IF(KF1.GT.1000) THEN
4684 IF(ISGN12.LT.0) IPROC=2
4685 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
4687 IF(ISGN12.LT.0) IPROC=4
4688 IF(KF1.EQ.111) IPROC=5
4689 ELSEIF(KF1.GT.100) THEN
4691 ELSEIF(KF2.GT.1000) THEN
4693 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
4694 ELSEIF(KF2.GT.100) THEN
4696 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
4699 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
4702 C... Number of multiple processes to be stored; beam/target side.
4708 ELSEIF(NPR.EQ.6) THEN
4713 IF(MINT(101).EQ.4) N1=4
4715 IF(MINT(102).EQ.4) N2=4
4717 C...Do not do any more for user-set or undefined cross-sections.
4718 IF(MSTP(31).LE.0) RETURN
4719 IF(NPR.EQ.0) CALL PYERRM(26,
4720 &'(PYXTOT:) cross section for this process not yet implemented')
4722 C...Parameters. Combinations of the energy.
4731 C...Loop over multiple processes (for VDM).
4735 ELSEIF(NPR.EQ.3) THEN
4737 IF(KF2.LT.1000) IPR=I+10
4738 ELSEIF(NPR.EQ.6) THEN
4742 C...Evaluate hadron species, mass, slope contribution and fit number.
4752 C...Skip if energy too low relative to masses.
4756 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
4758 C...Total cross-section. Elastic slope parameter and cross-section.
4759 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
4760 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
4761 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
4763 C...Diffractive scattering A + B -> X + B.
4766 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
4767 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4768 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4769 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
4770 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
4771 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
4772 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
4774 C...Diffractive scattering A + B -> A + X.
4777 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
4778 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4779 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4780 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
4781 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
4782 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
4783 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
4785 C...Order single diffractive correctly.
4788 SIGTMP(I,2)=SIGTMP(I,3)
4792 C...Double diffractive scattering A + B -> X1 + X2.
4793 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
4794 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
4795 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
4796 IF(YEFF.LE.0) SUM1=0D0
4797 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
4798 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
4799 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
4800 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
4802 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
4803 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
4804 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
4806 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
4807 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
4808 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
4809 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
4810 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
4812 C...Non-diffractive by unitarity.
4813 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
4817 C...Put temporary results in output array: only one process.
4818 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
4820 SIGT(0,0,J)=SIGTMP(1,J)
4823 C...Beam multiple processes.
4824 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
4825 IF(MINT(107).EQ.2) THEN
4826 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
4828 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
4829 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
4831 IF(MSTP(20).GT.0) THEN
4832 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
4835 IF(MINT(107).EQ.2) THEN
4836 CONV=(AEM/PARP(160+I))*VINT(317)
4837 ELSEIF(VINT(154).GT.PARP(15)) THEN
4838 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
4839 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
4845 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
4849 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4852 C...Target multiple processes.
4853 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
4854 IF(MINT(108).EQ.2) THEN
4855 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
4857 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
4858 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
4860 IF(MSTP(20).GT.0) THEN
4861 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
4864 IF(MINT(108).EQ.2) THEN
4865 CONV=(AEM/PARP(160+I))*VINT(317)
4866 ELSEIF(VINT(154).GT.PARP(15)) THEN
4867 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
4868 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
4874 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
4878 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
4881 C...Both beam and target multiple processes.
4883 IF(MINT(107).EQ.2) THEN
4884 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
4886 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
4887 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
4889 IF(MINT(108).EQ.2) THEN
4890 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
4892 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
4893 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
4895 IF(MSTP(20).GT.0) THEN
4896 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
4897 & VINT(308)))**MSTP(20)
4901 IF(MINT(107).EQ.2) THEN
4902 CONV=(AEM/PARP(160+I1))*VINT(317)
4903 ELSEIF(VINT(154).GT.PARP(15)) THEN
4904 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
4905 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
4909 IF(MINT(108).EQ.2) THEN
4910 CONV=CONV*(AEM/PARP(160+I2))
4911 ELSEIF(VINT(154).GT.PARP(15)) THEN
4912 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
4913 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
4919 ELSEIF(I2.LE.2) THEN
4921 ELSEIF(I1.EQ.I2) THEN
4928 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
4929 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
4935 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
4936 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
4938 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4942 C...Scale up uniformly for Donnachie-Landshoff parametrization.
4943 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
4944 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
4948 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
4957 C*********************************************************************
4960 C...Finds optimal set of coefficients for kinematical variable selection
4961 C...and the maximum of the part of the differential cross-section used
4962 C...in the event weighting.
4966 C...Double precision and integer declarations.
4967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4968 IMPLICIT INTEGER(I-N)
4969 INTEGER PYK,PYCHGE,PYCOMP
4970 C...Parameter statement to help give large particle numbers.
4971 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
4973 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4974 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4975 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
4976 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4977 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4978 COMMON/PYINT1/MINT(400),VINT(400)
4979 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4980 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
4981 COMMON/PYINT4/MWID(500),WIDS(500,5)
4982 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4983 COMMON/PYINT6/PROC(0:500)
4985 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4986 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4987 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
4988 C...Local arrays, character variables and data.
4990 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
4991 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
4992 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
4993 DATA CVAR/'tau ','tau''','y* ','cth '/
4996 C...Initial values and loop over subprocesses.
5005 C...Find maximum weight factors for photon flux.
5006 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5007 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5010 C...Select subprocess to study: skip cases not applicable.
5011 IF(ISET(ISUB).EQ.11) THEN
5012 IF(MSUB(ISUB).NE.1) GOTO 460
5013 XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
5014 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5015 & WTGAGA*XSEC(ISUB,1)
5018 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5019 CALL PYSIGH(NCHN,SIGS)
5021 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5022 & WTGAGA*XSEC(ISUB,1)
5023 IF(MSUB(ISUB).NE.1) GOTO 460
5026 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5027 CALL PYSIGH(NCHN,SIGS)
5029 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5030 & WTGAGA*XSEC(ISUB,1)
5031 IF(XSEC(ISUB,1).EQ.0D0) THEN
5037 ELSEIF(ISUB.EQ.96) THEN
5038 IF(MINT(50).EQ.0) GOTO 460
5039 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5041 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5042 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5043 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5044 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5046 IF(MSUB(ISUB).NE.1) GOTO 460
5049 IF(ISUB.EQ.96) ISTSB=2
5050 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5052 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5053 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5055 C...Find resonances (explicit or implicit in cross-section).
5058 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5060 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5061 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5063 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5064 & .OR.ISUB.EQ.177) THEN
5066 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5068 IF(MSTP(46).EQ.5) THEN
5071 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5073 ELSEIF(ISUB.EQ.194) THEN
5075 ELSEIF(ISUB.EQ.195) THEN
5077 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5079 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5083 IF(CKMX.LE.0D0) CKMX=VINT(1)
5086 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5087 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5090 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5095 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5102 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5105 IF(ISUB.EQ.194) THEN
5107 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
5111 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5116 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5117 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5118 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5119 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5124 ELSEIF(KFR2.NE.0) THEN
5136 C...Find product masses and minimum pT of process.
5142 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5146 IF(KFPR(ISUB,I).EQ.0) THEN
5147 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5149 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5150 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5153 C...This prevents SUSY/t particles from becoming too light.
5155 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5158 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5159 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5160 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5161 & PMAS(PYCOMP(KFDP(IDC,2)),1)
5162 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5163 & PMAS(PYCOMP(KFDP(IDC,3)),1)
5164 PMMN(I)=MIN(PMMN(I),PMSUM)
5167 ELSEIF(KFLW.EQ.6) THEN
5168 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5175 CKIN(41)=MAX(PMMN(1),CKIN(41))
5176 CKIN(43)=MAX(PMMN(2),CKIN(43))
5177 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5180 IF(MINT(51).EQ.1) THEN
5181 WRITE(MSTU(11),5100) ISUB
5188 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
5189 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5190 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
5191 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5192 ELSEIF(ISUB.EQ.96) THEN
5193 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5199 C...Prepare for additional variable choices in 2 -> 3.
5202 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5204 VINT(204)=PMAS(23,1)
5205 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
5206 IF(ISUB.EQ.352) VINT(204)=PMAS(63,1)
5207 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
5208 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5212 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
5213 NPTS(1)=2+2*MINT(72)
5214 IF(MINT(47).EQ.1) THEN
5215 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
5216 ELSEIF(MINT(47).GE.5) THEN
5217 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
5220 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5221 IF(MINT(47).GE.2) NPTS(2)=2
5222 IF(MINT(47).GE.5) NPTS(2)=3
5225 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
5227 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
5228 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
5231 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
5232 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
5234 C...Reset coefficients of cross-section weighting.
5250 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
5251 C...in grid of phase space points.
5257 IF(METAU.EQ.1) GOTO 150
5258 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
5259 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
5260 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
5262 C...Special case when both resonances have same mass,
5263 C...as is often the case in process 194.
5264 IF(MINT(72).EQ.2) THEN
5265 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
5266 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
5267 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
5269 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
5274 CALL PYKMAP(1,MTAU,RTAU)
5275 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
5278 IF(METAUP.EQ.1) GOTO 150
5279 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
5281 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
5282 CALL PYKMAP(4,MTAUP,0.5D0)
5284 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
5288 IF(MEYST.EQ.1) GOTO 150
5289 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
5290 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
5291 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
5292 CALL PYKMAP(2,MYST,0.5D0)
5296 IF(MECTH.EQ.1) GOTO 150
5297 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5298 MCTH=1+MOD(ITRY-1,NPTS(4))
5299 CALL PYKMAP(3,MCTH,0.5D0)
5301 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
5303 C...Store position and limits.
5306 IF(MINT(51).EQ.1) GOTO 150
5309 MVARPT(NACC,2)=MTAUP
5313 VINTPT(NACC,J)=VINT(10+J)
5316 C...Normal case: calculate cross-section.
5318 CALL PYSIGH(NCHN,SIGS)
5324 C..2 -> 3: find highest value out of a number of tries.
5327 DO 140 IKIN3=1,MSTP(129)
5328 CALL PYKMAP(5,0,0D0)
5329 IF(MINT(51).EQ.1) GOTO 140
5330 CALL PYSIGH(NCHN,SIGTMP)
5335 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5339 C...Store cross-section.
5341 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5342 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
5343 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5346 WRITE(MSTU(11),5100) ISUB
5349 ELSEIF(SIGSAM.EQ.0D0) THEN
5350 WRITE(MSTU(11),5300) ISUB
5354 IF(ISUB.NE.96) NPOSI=NPOSI+1
5356 C...Calculate integrals in tau over maximal phase space limits.
5359 ATAU1=LOG(TAUMAX/TAUMIN)
5360 IF(NPTS(1).GE.2) THEN
5361 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
5363 IF(NPTS(1).GE.4) THEN
5364 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
5365 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
5368 IF(NPTS(1).GE.6) THEN
5369 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
5370 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
5373 IF(NPTS(1).GT.2+2*MINT(72)) THEN
5374 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
5377 C...Reset. Sum up cross-sections in points calculated.
5379 IF(NPTS(IVAR).EQ.1) GOTO 320
5380 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
5391 IBIN=MVARPT(IACC,IVAR)
5392 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
5393 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
5394 NAREL(IBIN)=NAREL(IBIN)+1
5395 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
5397 C...Sum up tau cross-section pieces in points used.
5400 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
5401 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
5403 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
5404 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
5405 & ((TAU-TAUR1)**2+GAMR1**2)
5408 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
5409 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
5410 & ((TAU-TAUR2)**2+GAMR2**2)
5412 IF(NBIN.GT.2+2*MINT(72)) THEN
5413 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
5414 & TAU/MAX(2D-10,1D0-TAU)
5417 C...Sum up tau' cross-section pieces in points used.
5418 ELSEIF(IVAR.EQ.2) THEN
5420 TAUP=VINTPT(IACC,16)
5421 TAUPMN=VINTPT(IACC,6)
5422 TAUPMX=VINTPT(IACC,26)
5423 ATAUP1=LOG(TAUPMX/TAUPMN)
5424 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
5425 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
5426 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
5427 & (1D0-TAU/TAUP)**3/TAUP
5429 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
5430 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
5431 & TAUP/MAX(2D-10,1D0-TAUP)
5434 C...Sum up y* cross-section pieces in points used.
5435 ELSEIF(IVAR.EQ.3) THEN
5437 YSTMIN=VINTPT(IACC,2)
5438 YSTMAX=VINTPT(IACC,22)
5440 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
5442 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
5443 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
5444 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
5445 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
5446 IF(MINT(45).EQ.3) THEN
5447 TAUE=VINTPT(IACC,11)
5448 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
5449 YST0=-0.5D0*LOG(TAUE)
5450 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
5451 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
5452 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
5453 & MAX(1D-10,1D0-EXP(YST-YST0))
5455 IF(MINT(46).EQ.3) THEN
5456 TAUE=VINTPT(IACC,11)
5457 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
5458 YST0=-0.5D0*LOG(TAUE)
5459 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
5460 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
5461 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
5462 & MAX(1D-10,1D0-EXP(-YST-YST0))
5465 C...Sum up cos(theta-hat) cross-section pieces in points used.
5467 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
5469 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
5471 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
5474 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
5475 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
5476 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
5477 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
5479 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
5480 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
5481 & MAX(RM34,RSQM-CTH)
5482 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
5483 & MAX(RM34,RSQM+CTH)
5484 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
5485 & MAX(RM34,RSQM-CTH)**2
5486 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
5487 & MAX(RM34,RSQM+CTH)**2
5491 C...Check that equation system solvable.
5492 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
5496 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
5497 & IRED=1,NBIN),WTREL(IBIN)
5498 IF(NAREL(IBIN).EQ.0) MSOLV=0
5499 WTRELS=WTRELS+WTREL(IBIN)
5501 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
5503 C...Solve to find relative importance of cross-section pieces.
5506 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
5508 DO 230 IRED=1,NBIN-1
5509 DO 220 IBIN=IRED+1,NBIN
5510 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
5514 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
5515 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
5516 DO 210 ICOE=IRED,NBIN
5517 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
5521 DO 250 IRED=NBIN,1,-1
5522 DO 240 ICOE=IRED+1,NBIN
5523 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
5525 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
5529 C...Share evenly if failure.
5530 260 IF(MSOLV.EQ.0) THEN
5534 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
5535 & WTREL(IBIN)/WTRELS)
5539 C...Normalize coefficients, with piece shared democratically.
5543 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
5544 COEFSU=COEFSU+COEFU(IBIN)
5545 WTRELS=WTRELS+WTRELN(IBIN)
5547 IF(COEFSU.GT.0D0) THEN
5549 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
5550 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
5554 COEFO(IBIN)=1D0/NBIN
5557 IF(IVAR.EQ.1) IOFF=0
5558 IF(IVAR.EQ.2) IOFF=17
5559 IF(IVAR.EQ.3) IOFF=7
5560 IF(IVAR.EQ.4) IOFF=12
5563 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
5564 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
5565 COEF(ISUB,ICOF)=COEFO(IBIN)
5567 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
5568 & (COEFO(IBIN),IBIN=1,NBIN)
5571 C...Find two most promising maxima among points previously determined.
5579 VINT(10+J)=VINTPT(IACC,J)
5582 CALL PYSIGH(NCHN,SIGS)
5589 DO 350 IKIN3=1,MSTP(129)
5590 CALL PYKMAP(5,0,0D0)
5591 IF(MINT(51).EQ.1) GOTO 350
5592 CALL PYSIGH(NCHN,SIGTMP)
5597 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5602 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
5605 DO 370 IMV=NMAX,1,-1
5607 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
5608 IACCMX(IMV+1)=IACCMX(IMV)
5609 SIGSMX(IMV+1)=SIGSMX(IMV)
5612 380 IACCMX(IIN)=IACC
5614 IF(NMAX.LE.1) NMAX=NMAX+1
5618 C...Read out starting position for search.
5619 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
5624 MTAUP=MVARPT(IACC,2)
5632 C...Starting point and step size in parameter space.
5635 IF(NPTS(IVAR).EQ.1) GOTO 420
5636 IF(IVAR.EQ.1) VVAR=VTAU
5637 IF(IVAR.EQ.2) VVAR=VTAUP
5638 IF(IVAR.EQ.3) VVAR=VYST
5639 IF(IVAR.EQ.4) VVAR=VCTH
5640 IF(IVAR.EQ.1) MVAR=MTAU
5641 IF(IVAR.EQ.2) MVAR=MTAUP
5642 IF(IVAR.EQ.3) MVAR=MYST
5643 IF(IVAR.EQ.4) MVAR=MCTH
5644 IF(IRPT.EQ.1) VDEL=0.1D0
5645 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
5647 IF(IRPT.EQ.1) VMAR=0.02D0
5648 IF(IRPT.EQ.2) VMAR=0.002D0
5650 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
5653 C...Define new point in parameter space.
5657 ELSEIF(IMOV.EQ.1) THEN
5660 ELSEIF(IMOV.EQ.2) THEN
5663 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
5664 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
5670 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
5671 & VVAR-2D0*VDEL.GT.VMAR) THEN
5677 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
5691 C...Convert to relevant variables and find derived new limits.
5695 CALL PYKMAP(1,MTAU,VTAU)
5696 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5698 IF(MINT(51).EQ.1) ILERR=1
5701 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
5703 IF(IVAR.EQ.2) VTAUP=VNEW
5704 CALL PYKMAP(4,MTAUP,VTAUP)
5706 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
5708 IF(MINT(51).EQ.1) ILERR=1
5710 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
5711 IF(IVAR.EQ.3) VYST=VNEW
5712 CALL PYKMAP(2,MYST,VYST)
5714 IF(MINT(51).EQ.1) ILERR=1
5716 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
5718 IF(IVAR.EQ.4) VCTH=VNEW
5719 CALL PYKMAP(3,MCTH,VCTH)
5721 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
5723 C...Evaluate cross-section. Save new maximum. Final maximum.
5726 ELSEIF(ISTSB.NE.5) THEN
5727 CALL PYSIGH(NCHN,SIGS)
5734 DO 400 IKIN3=1,MSTP(129)
5735 CALL PYKMAP(5,0,0D0)
5736 IF(MINT(51).EQ.1) GOTO 400
5737 CALL PYSIGH(NCHN,SIGTMP)
5742 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5746 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5747 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
5748 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5753 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
5754 XSEC(ISUB,1)=1.05D0*SIGSAM
5755 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5756 & WTGAGA*XSEC(ISUB,1)
5758 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
5759 & PARP(174)*XSEC(ISUB,1)
5760 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
5764 C...Print summary table.
5765 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
5766 WRITE(MSTU(11),5900)
5769 IF(MSTP(122).GE.1) THEN
5770 WRITE(MSTU(11),6000)
5771 WRITE(MSTU(11),6100)
5773 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
5774 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
5775 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
5776 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
5777 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
5778 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
5779 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
5781 WRITE(MSTU(11),6300)
5784 C...Format statements for maximization results.
5785 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
5786 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
5787 &'cth',9X,'tau''',7X,'sigma')
5788 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
5789 &'phase space.'/1X,'Process switched off!')
5790 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
5791 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
5792 &'cross-section.'/1X,'Process switched off!')
5793 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
5794 5500 FORMAT(1X,1P,8D11.3)
5795 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
5796 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
5797 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
5798 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
5799 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
5800 &'cross-section.'/1X,'Execution stopped!')
5801 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
5802 &'cross-section maximum search',1X,8('*'))
5803 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
5804 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
5805 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
5806 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
5807 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
5812 C*********************************************************************
5815 C...Initializes multiplicity distribution and selects mutliplicity
5816 C...of pileup events, i.e. several events occuring at the same
5819 SUBROUTINE PYPILE(MPILE)
5821 C...Double precision and integer declarations.
5822 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5823 IMPLICIT INTEGER(I-N)
5824 INTEGER PYK,PYCHGE,PYCOMP
5826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5827 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5828 COMMON/PYINT1/MINT(400),VINT(400)
5829 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5830 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
5831 C...Local arrays and saved variables.
5832 DIMENSION WTI(0:200)
5833 SAVE IMIN,IMAX,WTI,WTS
5835 C...Sum of allowed cross-sections for pileup events.
5837 VINT(131)=SIGT(0,0,5)
5838 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
5839 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
5840 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
5841 IF(MSTP(133).LE.0) RETURN
5843 C...Initialize multiplicity distribution at maximum.
5844 XNAVE=VINT(131)*PARP(131)
5845 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
5846 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
5849 WTN=WTI(INAVE)*INAVE
5851 C...Find shape of multiplicity distribution below maximum.
5853 DO 100 I=INAVE-1,1,-1
5854 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
5855 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
5856 IF(WTI(I).LT.1D-6) GOTO 110
5862 C...Find shape of multiplicity distribution above maximum.
5864 DO 120 I=INAVE+1,200
5865 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
5866 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
5867 IF(WTI(I).LT.1D-6) GOTO 130
5874 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
5875 & WTS/(WTS+WTI(1)/XNAVE)
5876 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
5877 IF(MSTP(133).GE.2) VINT(134)=XNAVE
5879 C...Pick multiplicity of pileup events.
5881 IF(MSTP(133).LE.0) THEN
5882 MINT(81)=MAX(1,MSTP(134))
5888 IF(WTR.LE.0D0) GOTO 150
5894 C...Format statement for error message.
5895 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
5896 &'crossing too large, ',1P,D12.4)
5901 C*********************************************************************
5904 C...Saves and restores parameter and cross section values for the
5905 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alnternatives.
5906 C...Also makes random choice between alternatives.
5908 SUBROUTINE PYSAVE(ISAVE,IGA)
5910 C...Double precision and integer declarations.
5911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5912 IMPLICIT INTEGER(I-N)
5913 INTEGER PYK,PYCHGE,PYCOMP
5915 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5916 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5917 COMMON/PYINT1/MINT(400),VINT(400)
5918 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5919 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5920 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5921 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
5922 C...Local arrays and saved variables.
5923 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
5924 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
5925 &INTCP(15,20),RECP(15,20)
5926 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
5928 C...Save list of subprocesses and cross-section information.
5932 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
5935 MSUBCP(IGA,ICP)=MSUB(I)
5937 COEFCP(IGA,ICP,J)=COEF(I,J)
5940 NGENCP(IGA,ICP,J)=NGEN(I,J)
5941 XSECCP(IGA,ICP,J)=XSEC(I,J)
5946 NGENCP(IGA,0,J)=NGEN(0,J)
5947 XSECCP(IGA,0,J)=XSEC(0,J)
5952 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
5957 C...Save various common process variables.
5959 INTCP(IGA,J)=MINT(40+J)
5961 INTCP(IGA,11)=MINT(101)
5962 INTCP(IGA,12)=MINT(102)
5963 INTCP(IGA,13)=MINT(107)
5964 INTCP(IGA,14)=MINT(108)
5965 INTCP(IGA,15)=MINT(123)
5967 RECP(IGA,2)=VINT(318)
5969 C...Save cross-section information only.
5970 ELSEIF(ISAVE.EQ.2) THEN
5971 DO 160 ICP=1,NCP(IGA)
5974 NGENCP(IGA,ICP,J)=NGEN(I,J)
5975 XSECCP(IGA,ICP,J)=XSEC(I,J)
5979 NGENCP(IGA,0,J)=NGEN(0,J)
5980 XSECCP(IGA,0,J)=XSEC(0,J)
5983 C...Choose between allowed alternatives.
5984 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
5987 DO 180 IG=1,MINT(121)
5988 XSUMCP=XSUMCP+XSECCP(IG,0,1)
5990 XSUMCP=XSUMCP*PYR(0)
5991 DO 190 IG=1,MINT(121)
5993 XSUMCP=XSUMCP-XSECCP(IG,0,1)
5994 IF(XSUMCP.LE.0D0) GOTO 200
5999 C...Restore cross-section information.
6003 DO 240 ICP=1,NCP(IGA)
6005 MSUB(I)=MSUBCP(IGA,ICP)
6007 COEF(I,J)=COEFCP(IGA,ICP,J)
6010 NGEN(I,J)=NGENCP(IGA,ICP,J)
6011 XSEC(I,J)=XSECCP(IGA,ICP,J)
6015 NGEN(0,J)=NGENCP(IGA,0,J)
6016 XSEC(0,J)=XSECCP(IGA,0,J)
6021 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6026 C...Restore various common process variables.
6028 MINT(40+J)=INTCP(IGA,J)
6030 MINT(101)=INTCP(IGA,11)
6031 MINT(102)=INTCP(IGA,12)
6032 MINT(107)=INTCP(IGA,13)
6033 MINT(108)=INTCP(IGA,14)
6034 MINT(123)=INTCP(IGA,15)
6037 VINT(318)=RECP(IGA,2)
6039 C...Sum up cross-section info (for PYSTAT).
6040 ELSEIF(ISAVE.EQ.5) THEN
6051 DO 290 IG=1,MINT(121)
6052 DO 280 ICP=1,NCP(IG)
6054 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6055 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6056 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6057 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6059 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6060 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6061 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6062 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6069 C*********************************************************************
6072 C...For lepton beams it gives photon-hadron or photon-photon systems
6073 C...to be treated with the ordinary machinery and combines this with a
6074 C...description of the lepton -> lepton + photon branching.
6076 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6078 C...Double precision and integer declarations.
6079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6080 IMPLICIT INTEGER(I-N)
6081 INTEGER PYK,PYCHGE,PYCOMP
6083 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6084 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6085 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6086 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6087 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6088 COMMON/PYINT1/MINT(400),VINT(400)
6089 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6090 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6092 C...Local variables and data statement.
6093 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6094 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6095 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6098 C...Initialize generation of photons inside leptons.
6101 C...Save quantities on incoming lepton system.
6105 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
6107 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
6108 PMC(3)=VINT(302)-PMS(1)-PMS(2)
6109 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
6111 C...Calculate range of x and Q2 values allowed in generation.
6113 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
6114 IF(MINT(140+I).NE.0) THEN
6115 XMIN(I)=MAX(CKIN(59+2*I),EPS)
6116 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
6118 YMIN=MAX(CKIN(71+2*I),EPS)
6119 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
6120 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
6121 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
6122 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
6123 THEMIN=MAX(CKIN(67+2*I),0D0)
6124 THEMAX=MIN(CKIN(68+2*I),PARU(1))
6125 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
6126 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
6127 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
6128 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
6129 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
6130 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
6131 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
6132 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
6133 C...W limits when lepton on one side only.
6134 IF(MINT(143-I).EQ.0) THEN
6135 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
6136 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
6137 & (CKIN(78)**2-PMS(3-I))/PMC(I))
6142 C...W limits when lepton on both sides.
6143 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6144 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
6145 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
6146 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
6147 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
6148 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
6149 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
6150 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
6151 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
6152 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
6154 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
6155 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
6159 C...Q2 and W values and photon flux weight factors for initialization.
6160 ELSEIF(IGAGA.EQ.2) THEN
6165 C...W value for photon on one or both sides, and for processes
6166 C...with gamma-gamma cross section peaked at small shat.
6167 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
6168 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
6169 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
6170 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
6171 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
6172 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
6173 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6175 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
6176 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6178 VINT(1)=SQRT(MAX(0D0,VINT(2)))
6180 C...Upper estimate of photon flux weight factor.
6181 C...Initialization Q2 scale. Flag incoming unresolved photon.
6184 IF(MINT(140+I).NE.0) THEN
6185 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
6186 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
6187 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
6189 Q2INIT=5D0+Q2MIN(3-I)
6190 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
6191 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
6192 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
6193 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
6194 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
6195 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
6197 ELSEIF(ISUB.EQ.140) THEN
6202 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
6203 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
6205 VINT(306+I)=VINT(2+I)**2
6210 C...Update pTmin and cross section information.
6211 IF(MSTP(82).LE.1) THEN
6212 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6214 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6216 VINT(149)=4D0*PTMN**2/VINT(2)
6221 C...Generate photons inside leptons and
6222 C...calculate photon flux weight factors.
6223 ELSEIF(IGAGA.EQ.3) THEN
6228 C...Generate phase space point and check against cuts.
6232 IF(MINT(140+I).NE.0) THEN
6234 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
6235 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
6236 C...Cuts on internal consistency in x and Q2.
6237 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
6238 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
6239 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
6240 C...Cuts on y and theta.
6241 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
6242 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
6243 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
6244 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
6245 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
6246 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
6247 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
6250 C...Phi angle isotropic. Reconstruct pT.
6251 PHI(I)=PARU(2)*PYR(0)
6252 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
6253 & PMS(I))*SIN(THETA(I))
6255 C...Store info on variables selected, for documentation purposes.
6256 VINT(2+I)=-SQRT(Q2(I))
6260 VINT(310+I)=THETA(I)
6271 C...Cut on W combines info from two sides.
6272 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6273 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
6274 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
6275 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
6276 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
6277 IF(W2.LT.W2MIN) GOTO 120
6278 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
6281 ELSEIF(MINT(141).NE.0) THEN
6282 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
6285 ELSEIF(MINT(142).NE.0) THEN
6286 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
6291 C...Store kinematics info for photon(s) in subsystem cm frame.
6296 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
6297 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
6298 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
6301 VINT(298)=-VINT(293)
6302 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
6303 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
6305 C...Assign weight for photon flux; different for transverse and
6306 C...longitudinal photons. Flag incoming unresolved photon.
6309 IF(MINT(140+I).NE.0) THEN
6310 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
6311 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
6312 IF(MSTP(16).EQ.0) THEN
6315 WTGAGA=WTGAGA*X(I)/Y(I)
6318 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
6319 WTGAGA=WTGAGA*(1D0-XY)
6320 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
6321 WTGAGA=WTGAGA*(1D0-XY)
6322 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
6323 WTGAGA=WTGAGA*(1D0-XY)
6325 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
6326 & PMS(I)*XY**2/Q2(I))
6328 IF(MINT(106+I).EQ.0) MINT(14+I)=22
6334 C...Update pTmin and cross section information.
6335 IF(MSTP(82).LE.1) THEN
6336 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6338 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6340 VINT(149)=4D0*PTMN**2/VINT(2)
6344 C...Reconstruct kinematics of photons inside leptons.
6345 ELSEIF(IGAGA.EQ.4) THEN
6347 C...Make place for incoming particles and scattered leptons.
6349 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
6350 MINT(4)=MINT(4)+MOVE
6351 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
6352 IF(K(I,1).EQ.21) THEN
6358 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
6359 & K(I+MOVE,3)=K(I,3)+MOVE
6360 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
6361 & K(I+MOVE,4)=K(I,4)+MOVE
6362 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
6363 & K(I+MOVE,5)=K(I,5)+MOVE
6366 DO 170 I=MINT(84)+1,N
6367 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
6368 & K(I,3)=K(I,3)+MOVE
6371 C...Fill in incoming particles.
6372 DO 190 I=MINT(83)+1,MINT(83)+MOVE
6381 IF(MINT(140+I).NE.0) THEN
6382 K(MINT(83)+I,2)=MINT(140+I)
6383 P(MINT(83)+I,5)=VINT(302+I)
6385 K(MINT(83)+I,2)=MINT(10+I)
6386 P(MINT(83)+I,5)=VINT(2+I)
6388 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
6389 & VINT(302))*(-1D0)**(I+1)
6390 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
6393 C...New mother-daughter relations in documentation section.
6394 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6395 K(MINT(83)+1,4)=MINT(83)+3
6396 K(MINT(83)+1,5)=MINT(83)+5
6397 K(MINT(83)+2,4)=MINT(83)+4
6398 K(MINT(83)+2,5)=MINT(83)+6
6399 K(MINT(83)+3,3)=MINT(83)+1
6400 K(MINT(83)+5,3)=MINT(83)+1
6401 K(MINT(83)+4,3)=MINT(83)+2
6402 K(MINT(83)+6,3)=MINT(83)+2
6403 ELSEIF(MINT(141).NE.0) THEN
6404 K(MINT(83)+1,4)=MINT(83)+3
6405 K(MINT(83)+1,5)=MINT(83)+4
6406 K(MINT(83)+2,4)=MINT(83)+5
6407 K(MINT(83)+3,3)=MINT(83)+1
6408 K(MINT(83)+4,3)=MINT(83)+1
6409 K(MINT(83)+5,3)=MINT(83)+2
6410 ELSEIF(MINT(142).NE.0) THEN
6411 K(MINT(83)+1,4)=MINT(83)+4
6412 K(MINT(83)+2,4)=MINT(83)+3
6413 K(MINT(83)+2,5)=MINT(83)+5
6414 K(MINT(83)+3,3)=MINT(83)+2
6415 K(MINT(83)+4,3)=MINT(83)+1
6416 K(MINT(83)+5,3)=MINT(83)+2
6419 C...Fill scattered lepton(s).
6421 IF(MINT(140+I).NE.0) THEN
6422 LSC=MINT(83)+MIN(I+2,MOVE)
6424 K(LSC,2)=MINT(140+I)
6425 P(LSC,1)=PT(I)*COS(PHI(I))
6426 P(LSC,2)=PT(I)*SIN(PHI(I))
6427 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
6428 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
6430 P(LSC,5)=VINT(302+I)
6434 C...Find incoming four-vectors to subprocess.
6436 IF(MINT(141).NE.0) THEN
6438 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
6442 P(N+1,J)=P(MINT(83)+1,J)
6446 IF(MINT(142).NE.0) THEN
6448 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
6452 P(N+2,J)=P(MINT(83)+2,J)
6456 C...Define boost and rotation between hadronic subsystem and
6457 C...collision rest frame; boost hadronic subsystem to this frame.
6459 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
6461 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
6462 BPHI=PYANGL(P(N+1,1),P(N+1,2))
6463 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
6464 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
6465 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
6468 C...Add on scattered leptons to final state.
6470 IF(MINT(140+I).NE.0) THEN
6471 LSC=MINT(83)+MIN(I+2,MOVE)
6487 C*********************************************************************
6490 C...Generates quantities characterizing the high-pT scattering at the
6491 C...parton level according to the matrix elements. Chooses incoming,
6492 C...reacting partons, their momentum fractions and one of the possible
6497 C...Double precision and integer declarations.
6498 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6499 IMPLICIT INTEGER(I-N)
6500 INTEGER PYK,PYCHGE,PYCOMP
6501 C...Parameter statement to help give large particle numbers.
6502 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
6504 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6505 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6506 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
6507 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6508 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6509 COMMON/PYINT1/MINT(400),VINT(400)
6510 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6511 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6512 COMMON/PYINT4/MWID(500),WIDS(500,5)
6513 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6514 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6515 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
6516 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
6517 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
6518 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/PYMSSM/
6520 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
6522 C...Parameters and data used in elastic/diffractive treatment.
6523 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
6524 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6526 C...Initial values, specifically for (first) semihard interaction.
6535 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
6542 C...Start by assuming incoming photon is entering subprocess.
6543 IF(MINT(11).EQ.22) THEN
6545 VINT(307)=VINT(3)**2
6547 IF(MINT(12).EQ.22) THEN
6549 VINT(308)=VINT(4)**2
6554 C...Choice of process type - first event of pileup.
6556 IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
6558 C...For gamma-p or gamma-gamma first pick between alternatives.
6560 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
6563 C...For real gamma + gamma with different nature, flip at random.
6564 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
6565 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
6575 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
6578 C...Pick process type.
6579 RSUB=XSEC(0,1)*PYR(0)
6581 IF(MSUB(I).NE.1) GOTO 110
6584 IF(RSUB.LE.0D0) GOTO 120
6586 120 IF(ISUB.EQ.95) ISUB=96
6587 IF(ISUB.EQ.96) INMULT=1
6589 C...Choice of inclusive process type - pileup events.
6590 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
6591 RSUB=VINT(131)*PYR(0)
6593 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
6594 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
6595 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
6596 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
6598 IF(ISUB.EQ.96) INMULT=1
6601 C...Choice of photon energy and flux factor inside lepton.
6602 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
6603 CALL PYGAGA(3,WTGAGA)
6604 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
6605 CKIN(3)=MAX(VINT(285),VINT(154))
6608 C...When necessary set direct/resolved photon by hand.
6609 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
6610 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6611 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6614 C...Restrict direct*resolved processes to pTmin >= Q,
6615 C...to avoid doublecounting with DIS.
6616 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
6617 IF(MINT(15).EQ.22) THEN
6618 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
6620 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
6625 C...Set up for multiple interactions.
6626 IF(INMULT.EQ.1) CALL PYMULT(2)
6628 C...Loopback point for minimum bias in photon physics.
6631 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
6632 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
6633 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
6634 &NGEN(97,1)=NGEN(97,1)+MINT(143)
6638 C...Random choice of flavour for some SUSY processes.
6639 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
6640 C...~e_L ~nu_e or ~mu_L ~nu_mu.
6641 IF(ISUB.EQ.210) THEN
6642 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
6643 KFPR(ISUB,2)=KFPR(ISUB,1)+1
6644 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
6645 ELSEIF(ISUB.EQ.213) THEN
6646 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
6647 KFPR(ISUB,2)=KFPR(ISUB,1)
6648 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
6649 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
6650 IF(ISUB.GE.258) THEN
6655 IF(MOD(ISUB,2).EQ.0) THEN
6656 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
6658 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
6660 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
6661 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
6662 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
6665 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
6668 ELSEIF(PYR(0).LT.0.5D0) THEN
6675 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
6676 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
6677 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
6678 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
6679 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
6680 KFPR(ISUB,2)=KFPR(ISUB,1)
6681 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
6682 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
6683 KFPR(ISUB,2)=KFPR(ISUB,1)
6684 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
6685 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
6686 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
6689 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
6692 ELSEIF(PYR(0).LT.0.5D0) THEN
6699 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
6704 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
6708 C...Find resonances (explicit or implicit in cross-section).
6711 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
6713 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
6714 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
6716 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
6719 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
6721 IF(MSTP(46).EQ.5) THEN
6724 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
6726 ELSEIF(ISUB.EQ.194) THEN
6728 ELSEIF(ISUB.EQ.195) THEN
6730 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
6732 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
6736 IF(CKMX.LE.0D0) CKMX=VINT(1)
6739 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
6740 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
6743 TAUR1=PMAS(KCR1,1)**2/VINT(2)
6748 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
6754 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
6757 IF(ISUB.EQ.194) THEN
6759 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
6763 TAUR2=PMAS(KCR2,1)**2/VINT(2)
6768 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
6769 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
6770 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
6771 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
6776 ELSEIF(KFR2.NE.0) THEN
6787 C...Find product masses and minimum pT of process,
6788 C...optionally with broadening according to a truncated Breit-Wigner.
6793 IF(MINT(82).GE.2) VINT(71)=0D0
6795 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6799 IF(KFPR(ISUB,I).EQ.0) THEN
6800 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
6802 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6805 C...This prevents SUSY/t particles from becoming too light.
6807 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
6810 DO 130 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
6811 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
6812 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
6813 & PMAS(PYCOMP(KFDP(IDC,2)),1)
6814 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
6815 & PMAS(PYCOMP(KFDP(IDC,3)),1)
6816 PMMN(I)=MIN(PMMN(I),PMSUM)
6819 ELSEIF(KFLW.EQ.6) THEN
6820 PMMN(I)=PMAS(24,1)+PMAS(5,1)
6827 CKIN(41)=MAX(PMMN(1),CKIN(41))
6828 CKIN(43)=MAX(PMMN(2),CKIN(43))
6829 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
6832 IF(MINT(51).EQ.1) THEN
6833 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6843 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
6844 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
6847 C...Prepare for additional variable choices in 2 -> 3.
6850 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
6852 VINT(204)=PMAS(23,1)
6853 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
6854 IF(ISUB.EQ.352) VINT(204)=PMAS(63,1)
6855 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
6856 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
6860 C...Select incoming VDM particle (rho/omega/phi/J/psi).
6861 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
6862 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
6863 VRN=PYR(0)*SIGT(0,0,5)
6864 IF(MINT(101).LE.1) THEN
6871 IF(MINT(102).LE.1) THEN
6882 VRN=VRN-SIGT(I1,I2,5)
6883 IF(VRN.LE.0D0) GOTO 170
6886 170 IF(MINT(101).GE.2) MINT(103)=KFV1
6887 IF(MINT(102).GE.2) MINT(104)=KFV2
6891 C...Elastic scattering or single or double diffractive scattering.
6893 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
6898 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
6900 VRN=PYR(0)*SIGT(0,0,JJ)
6901 IF(MINT(101).LE.1) THEN
6908 IF(MINT(102).LE.1) THEN
6919 VRN=VRN-SIGT(I1,I2,JJ)
6920 IF(VRN.LE.0D0) GOTO 200
6923 200 IF(MINT(101).GE.2) THEN
6927 IF(MINT(102).GE.2) THEN
6935 C...Select mass for GVMD states (rejecting previous assignment).
6937 Q1S=4D0*VINT(154)**2
6941 IF(MINT(106+JT).EQ.3) THEN
6943 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
6944 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
6945 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
6946 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
6949 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
6950 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
6955 C...Side/sides of diffractive system.
6958 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
6959 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
6961 C...Find masses of particles and minimal masses of diffractive states.
6964 VINT(68+JT)=PDIF(JT)
6965 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
6972 SMRES1=(PMM(1)+PMRC)**2
6973 SMRES2=(PMM(2)+PMRC)**2
6975 C...Find elastic slope and lower limit diffractive slope.
6976 IHA=MAX(2,IABS(MINT(103))/110)
6978 IHB=MAX(2,IABS(MINT(104))/110)
6981 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
6982 ELSEIF(ISUB.EQ.92) THEN
6983 BMN=MAX(2D0,2D0*BHAD(IHB))
6984 ELSEIF(ISUB.EQ.93) THEN
6985 BMN=MAX(2D0,2D0*BHAD(IHA))
6986 ELSEIF(ISUB.EQ.94) THEN
6990 C...Determine maximum possible t range and coefficient of generation.
6991 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
6992 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
6993 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
6994 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
6995 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
6996 & (SQM1*SQM4-SQM2*SQM3)/SH
6997 THL=-0.5D0*(THA+THB)
6999 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7001 C...Select diffractive mass/masses according to dm^2/m^2.
7005 IF(MINT(16+JT).EQ.0) THEN
7009 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7010 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7016 C..Additional mass factors, including resonance enhancement.
7017 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7018 IF(LOOP3.LT.100) GOTO 220
7022 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7023 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
7024 ELSEIF(ISUB.EQ.93) THEN
7025 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7026 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
7027 ELSEIF(ISUB.EQ.94) THEN
7028 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7029 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7030 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7031 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 220
7034 C...Select t according to exp(Bmn*t) and correct to right slope.
7035 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7038 BADD=2D0*ALP*LOG(SH/SQM3)
7039 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7040 ELSEIF(ISUB.EQ.93) THEN
7041 BADD=2D0*ALP*LOG(SH/SQM4)
7042 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7043 ELSEIF(ISUB.EQ.94) THEN
7044 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7046 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 220
7049 C...Check whether m^2 and t choices are consistent.
7050 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7051 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7052 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7053 IF(THB.LE.1D-8) GOTO 220
7054 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7055 & (SQM1*SQM4-SQM2*SQM3)/SH
7056 THLM=-0.5D0*(THA+THB)
7058 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 220
7060 C...Information to output.
7063 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
7065 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
7069 C...Note: in the following, by In is meant the integral over the
7070 C...quantity multiplying coefficient cn.
7071 C...Choose tau according to h1(tau)/tau, where
7072 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
7073 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7074 C...I1/I5*c5*1/(tau+tau_R') +
7075 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
7076 C...I1/I7*c7*tau/(1.-tau), and
7077 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
7078 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
7080 IF(MINT(51).NE.0) THEN
7081 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7090 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
7091 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
7092 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
7093 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
7095 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7096 & COEF(ISUB,5)) MTAU=6
7097 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7098 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
7099 CALL PYKMAP(1,MTAU,PYR(0))
7101 C...2 -> 3, 4 processes:
7102 C...Choose tau' according to h4(tau,tau')/tau', where
7103 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
7104 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
7105 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7107 IF(MINT(51).NE.0) THEN
7108 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7117 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
7118 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
7119 CALL PYKMAP(4,MTAUP,PYR(0))
7122 C...Choose y* according to h2(y*), where
7123 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7124 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
7125 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
7126 C...and c1 + c2 + c3 + c4 + c5 = 1.
7128 IF(MINT(51).NE.0) THEN
7129 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7138 IF(RYST.GT.COEF(ISUB,8)) MYST=2
7139 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
7140 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
7141 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
7142 & COEF(ISUB,11)) MYST=5
7143 CALL PYKMAP(2,MYST,PYR(0))
7145 C...2 -> 2 processes:
7146 C...Choose cos(theta-hat) (cth) according to h3(cth), where
7147 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7148 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7149 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7150 C...and c0 + c1 + c2 + c3 + c4 = 1.
7152 IF(MINT(51).NE.0) THEN
7153 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7160 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7163 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
7164 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
7165 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
7166 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
7167 & COEF(ISUB,16)) MCTH=5
7168 CALL PYKMAP(3,MCTH,PYR(0))
7171 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
7173 CALL PYKMAP(5,0,0D0)
7174 IF(MINT(51).NE.0) THEN
7175 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7184 C...DIS as f + gamma* -> f process: set dummy values.
7185 ELSEIF(ISTSB.EQ.8) THEN
7192 C...Low-pT or multiple interactions (first semihard interaction).
7193 ELSEIF(ISTSB.EQ.9) THEN
7197 C...Generate user-defined process: kinematics plus weight.
7198 ELSEIF(ISTSB.EQ.11) THEN
7200 CALL PYUPEV(ISUB,SIGS)
7204 IF(MINT(82).EQ.1) THEN
7205 NGEN(0,1)=NGEN(0,1)-1
7206 NGEN(0,2)=NGEN(0,2)-1
7207 NGEN(ISUB,1)=NGEN(ISUB,1)-1
7209 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7213 C...Construct 'trivial' kinematical variables needed.
7216 VINT(41)=2D0*PUP(1,4)/VINT(1)
7217 VINT(42)=2D0*PUP(2,4)/VINT(1)
7218 VINT(21)=VINT(41)*VINT(42)
7219 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
7220 VINT(44)=VINT(21)*VINT(2)
7221 VINT(43)=SQRT(MAX(0D0,VINT(44)))
7223 VINT(55)=SQRT(MAX(0D0,VINT(56)))
7225 C...Construct other kinematical variables needed (approximately).
7228 VINT(45)=-0.5D0*VINT(44)
7229 VINT(46)=-0.5D0*VINT(44)
7239 IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+
7240 & PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(2)
7241 IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+
7244 VINT(47)=SQRT(VINT(48))
7246 C...Calculate parton distribution weights.
7247 IF(MINT(47).GE.2) THEN
7248 DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
7249 MINT(105)=MINT(102+I)
7250 MINT(109)=MINT(106+I)
7253 C.... Store side in MINT(124)
7256 IF(MSTP(57).LE.1) THEN
7257 CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
7259 CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
7262 XSFX(I,KFL)=XPQ(KFL)
7268 C...Choose azimuthal angle.
7269 VINT(24)=PARU(2)*PYR(0)
7271 C...Check against user cuts on kinematics at parton level.
7273 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
7274 IF(MINT(51).NE.0) THEN
7275 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7282 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
7284 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
7287 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7296 C...Calculate differential cross-section for different subprocesses.
7297 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
7299 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
7301 C...Multiply cross section by lepton -> photon flux factor.
7302 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7305 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
7307 SIGLPT=WTGAGA*SIGLPT
7310 C...Multiply cross-section by user-defined weights.
7311 IF(MSTP(173).EQ.1) THEN
7314 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
7316 SIGLPT=PARP(173)*SIGLPT
7322 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
7323 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
7324 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
7327 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
7330 C...Calculations for Monte Carlo estimate of all cross-sections.
7331 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
7332 IF(MSTP(142).LE.1) THEN
7333 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
7335 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
7337 ELSEIF(MINT(82).EQ.1) THEN
7338 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
7340 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
7341 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
7343 C...Multiple interactions: store results of cross-section calculation.
7344 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
7349 C...Check that weight not negative.
7350 VIOL=SIGSWT/XSEC(ISUB,1)
7351 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
7352 IF(MSTP(123).LE.0) THEN
7353 IF(VIOL.LT.-1D-3) THEN
7354 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
7355 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
7356 & VINT(22),VINT(23),VINT(26)
7360 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
7362 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
7363 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
7364 & VINT(22),VINT(23),VINT(26)
7368 C...Weighting using estimate of maximum of differential cross-section.
7369 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
7370 IF(VIOL.LT.PYR(0)) THEN
7371 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7372 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
7375 ELSEIF(MFAIL.EQ.0) THEN
7376 RATND=SIGLPT/XSEC(95,1)
7377 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
7378 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7383 IF(VIOL.LT.PYR(0)) THEN
7386 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
7387 IF(VIOL.LT.PYR(0)) THEN
7389 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7393 RATND=SIGLPT/XSEC(95,1)
7394 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
7396 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7400 IF(VIOL.LT.PYR(0)) THEN
7401 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7406 C...Check for possible violation of estimated maximum of differential
7407 C...cross-section used in weighting.
7408 IF(MSTP(123).LE.0) THEN
7409 IF(VIOL.GT.1D0) THEN
7410 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
7411 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
7412 & VINT(22),VINT(23),VINT(26)
7415 ELSEIF(MSTP(123).EQ.1) THEN
7416 IF(VIOL.GT.VINT(108)) THEN
7418 IF(VIOL.GT.1D0) THEN
7420 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
7421 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
7422 & VINT(22),VINT(23),VINT(26)
7425 ELSEIF(VIOL.GT.VINT(108)) THEN
7427 IF(VIOL.GT.1D0) THEN
7429 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
7430 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
7431 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
7432 & XSEC(0,1)=XSEC(0,1)+XDIF
7433 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
7434 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
7435 & VINT(22),VINT(23),VINT(26)
7437 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
7438 ELSEIF(ISUB.LE.99) THEN
7439 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
7441 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
7447 C...Multiple interactions: choose impact parameter.
7449 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
7450 &MSTP(82).GE.3) THEN
7452 IF(VINT(150).LT.PYR(0)) THEN
7453 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7461 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
7462 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
7463 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
7464 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
7466 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
7468 C...Choose flavour of reacting partons (and subprocess).
7469 IF(ISTSB.GE.11) GOTO 300
7472 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
7473 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
7474 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
7475 &PYR(0).GT.RQQBAR)) THEN
7479 MINT(2)=ISIG(ICHN,3)
7480 RSIGS=RSIGS-SIGH(ICHN)
7481 IF(RSIGS.LE.0D0) GOTO 300
7484 C...Multiple interactions: choose qqbar preferentially at small pT.
7485 ELSEIF(ISUB.EQ.96) THEN
7488 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
7491 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
7494 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
7496 C...Low-pT: choose string drawing configuration.
7502 IF(RSIGS.GT.1D0) MINT(2)=2
7503 IF(RSIGS.GT.2D0) MINT(2)=3
7506 C...Reassign QCD process. Partons before initial state radiation.
7507 300 IF(MINT(2).GT.10) THEN
7509 MINT(2)=MOD(MINT(2),10)
7511 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
7522 C...Calculate x value of photon for parton inside photon inside e.
7527 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
7528 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
7529 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
7534 MINT(105)=MINT(102+JT)
7535 MINT(109)=MINT(106+JT)
7536 VINT(120)=VINT(2+JT)
7537 IF(MSTP(57).LE.1) THEN
7538 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
7540 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
7543 IF(MSTP(13).EQ.2) THEN
7544 Q2PMS=Q2HRD/PMAS(11,1)**2
7545 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
7548 XG=MIN(1D0-1D-10,XHRD/XE)
7549 IF(MSTP(57).LE.1) THEN
7550 CALL PYPDFU(22,XG,Q2HRD,XPQ)
7552 CALL PYPDFL(22,XG,Q2HRD,XPQ)
7554 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
7555 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
7556 IF(WT.LT.PYR(0)*WTMX) GOTO 310
7560 XSFX(JT,KFLS)=XPQ(KFLS)
7565 C...Pick scale where photon is resolved.
7569 IF(MINT(107).EQ.3) THEN
7570 IF(MSTP(66).EQ.1) THEN
7571 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
7572 ELSEIF(MSTP(66).EQ.2) THEN
7574 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
7575 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
7576 Q2INT=SQRT(Q0S*Q2EFF)
7577 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
7578 ELSEIF(MSTP(66).EQ.3) THEN
7579 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
7580 ELSEIF(MSTP(66).GE.4) THEN
7581 PS=0.25D0*VINT(3)**2
7582 VINT(283)=(Q0S+PS)*(Q1S+PS)/
7583 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7587 IF(MINT(108).EQ.3) THEN
7588 IF(MSTP(66).EQ.1) THEN
7589 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
7590 ELSEIF(MSTP(66).EQ.2) THEN
7592 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
7593 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
7594 Q2INT=SQRT(Q0S*Q2EFF)
7595 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
7596 ELSEIF(MSTP(66).EQ.3) THEN
7597 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
7598 ELSEIF(MSTP(66).GE.4) THEN
7599 PS=0.25D0*VINT(4)**2
7600 VINT(284)=(Q0S+PS)*(Q1S+PS)/
7601 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7604 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7606 C...Format statements for differential cross-section maximum violations.
7607 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
7608 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
7609 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
7610 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
7611 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
7613 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
7614 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
7615 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
7617 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
7618 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
7619 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
7624 C*********************************************************************
7627 C...Finds outgoing flavours and event type; sets up the kinematics
7628 C...and colour flow of the hard scattering
7632 C...Double precision and integer declarations
7633 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7634 IMPLICIT INTEGER(I-N)
7635 INTEGER PYK,PYCHGE,PYCOMP
7636 C...Parameter statement to help give large particle numbers.
7637 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
7639 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
7640 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7641 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7642 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
7643 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7644 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7645 COMMON/PYINT1/MINT(400),VINT(400)
7646 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7647 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7648 COMMON/PYINT4/MWID(500),WIDS(500,5)
7649 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7650 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
7651 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
7653 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
7654 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/
7655 C...Local arrays and saved variables
7656 DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2),
7657 &PHI(2),KUPPO(20),VINTSV(41:66)
7660 C...Read out process
7664 C...Restore information for low-pT processes
7665 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
7667 100 VINT(J)=VINTSV(J)
7670 C...Convert H' or A process into equivalent H one
7673 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
7676 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
7678 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
7679 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
7680 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
7681 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
7682 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
7683 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
7684 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
7685 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
7686 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
7689 C...Choice of subprocess, number of documentation lines
7691 IF(ISUB.EQ.95) IDOC=8
7692 IF(ISET(ISUB).EQ.5) IDOC=9
7693 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
7695 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
7704 C...Reset K, P and V vectors. Store incoming particles
7705 DO 120 JT=1,MSTP(126)+20
7718 P(I,J)=VINT(285+5*JT+J)
7724 C...Store incoming partons in their CM-frame
7727 SHP=VINT(26)*VINT(2)
7730 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
7735 K(I,3)=MINT(83)+2+JT
7736 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
7740 C...Copy incoming partons to documentation lines
7752 C...Choose new quark/lepton flavour for relevant annihilation graphs
7753 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
7754 &(ISUB.GE.135.AND.ISUB.LE.140)) THEN
7756 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
7757 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
7758 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
7759 DO 190 I=1,MDCY(IGLGA,3)
7760 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
7761 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
7762 IF(RKFL.LE.0D0) GOTO 200
7765 IF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
7766 & IABS(KFLF).GE.3) THEN
7767 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
7769 FACCIB=VINT(46)**2/PARU(155)**4
7770 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
7771 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
7772 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
7773 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
7774 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
7778 C...Final state flavours and colour flow: default values
7785 KCS=ISIGN(1,MINT(15))
7787 IF(ISET(ISUB).EQ.11) THEN
7788 C...User-defined processes: find products
7791 IF(KUP(IUP,1).NE.1) THEN
7792 ELSEIF(IRUP.LE.5) THEN
7794 MINT(20+IRUP)=KUP(IUP,2)
7798 ELSEIF(ISUB.LE.10) THEN
7800 C...f + fbar -> gamma*/Z0
7803 ELSEIF(ISUB.EQ.2) THEN
7804 C...f + fbar' -> W+/-
7805 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7806 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7807 KFRES=ISIGN(24,KCH1+KCH2)
7809 ELSEIF(ISUB.EQ.3) THEN
7810 C...f + fbar -> h0 (or H0, or A0)
7813 ELSEIF(ISUB.EQ.4) THEN
7814 C...gamma + W+/- -> W+/-
7816 ELSEIF(ISUB.EQ.5) THEN
7821 PMQ(1)=PYMASS(MINT(21))
7822 PMQ(2)=PYMASS(MINT(22))
7823 220 JT=INT(1.5D0+PYR(0))
7824 ZMIN=2D0*PMQ(JT)/SHPR
7825 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7826 & (SHPR*(SHPR-PMQ(3-JT)))
7827 ZMAX=MIN(1D0-XH,ZMAX)
7828 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7829 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7830 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
7831 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7832 IF(SQC1.LT.1D-8) GOTO 220
7834 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7835 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7836 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7837 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7838 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7839 IF(SQC1.LT.1D-8) GOTO 220
7841 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7842 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7843 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7846 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7847 & SQRT(1D0-CTHE(2)**2)*CPHI
7849 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7850 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7851 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7852 & PMQ(3-JT)**2/SHP))
7853 ZMIN=2D0*PMQ(3-JT)/SHPR
7854 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7855 ZMAX=MIN(1D0-XH,ZMAX)
7856 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
7860 ELSEIF(ISUB.EQ.6) THEN
7861 C...Z0 + W+/- -> W+/-
7863 ELSEIF(ISUB.EQ.7) THEN
7866 ELSEIF(ISUB.EQ.8) THEN
7873 RVCKM=VINT(180+I)*PYR(0)
7876 IPM=(5-ISIGN(1,I))/2
7878 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
7879 MINT(20+JT)=ISIGN(IB,I)
7880 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7881 IF(RVCKM.LE.0D0) GOTO 250
7884 IB=2*((IA+1)/2)-1+MOD(IA,2)
7885 MINT(20+JT)=ISIGN(IB,I)
7887 250 PMQ(JT)=PYMASS(MINT(20+JT))
7889 JT=INT(1.5D0+PYR(0))
7890 ZMIN=2D0*PMQ(JT)/SHPR
7891 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7892 & (SHPR*(SHPR-PMQ(3-JT)))
7893 ZMAX=MIN(1D0-XH,ZMAX)
7894 IF(ZMIN.GE.ZMAX) GOTO 230
7895 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7896 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7897 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
7898 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7899 IF(SQC1.LT.1D-8) GOTO 230
7901 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7902 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7903 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7904 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7905 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7906 IF(SQC1.LT.1D-8) GOTO 230
7908 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7909 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7910 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7913 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7914 & SQRT(1D0-CTHE(2)**2)*CPHI
7916 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7917 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7918 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7919 & PMQ(3-JT)**2/SHP))
7920 ZMIN=2D0*PMQ(3-JT)/SHPR
7921 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7922 ZMAX=MIN(1D0-XH,ZMAX)
7923 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
7927 ELSEIF(ISUB.EQ.10) THEN
7928 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
7929 IF(MINT(2).EQ.1) THEN
7932 C...W exchange: need to mix flavours according to CKM matrix
7937 RVCKM=VINT(180+I)*PYR(0)
7940 IPM=(5-ISIGN(1,I))/2
7942 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
7943 MINT(20+JT)=ISIGN(IB,I)
7944 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7945 IF(RVCKM.LE.0D0) GOTO 280
7948 IB=2*((IA+1)/2)-1+MOD(IA,2)
7949 MINT(20+JT)=ISIGN(IB,I)
7956 ELSEIF(ISUB.LE.20) THEN
7958 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
7960 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
7962 ELSEIF(ISUB.EQ.12) THEN
7963 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
7964 MINT(21)=ISIGN(KFLF,MINT(15))
7968 ELSEIF(ISUB.EQ.13) THEN
7969 C...f + fbar -> g + g; th arbitrary
7974 ELSEIF(ISUB.EQ.14) THEN
7975 C...f + fbar -> g + gamma; th arbitrary
7976 IF(PYR(0).GT.0.5D0) JS=2
7981 ELSEIF(ISUB.EQ.15) THEN
7982 C...f + fbar -> g + Z0; th arbitrary
7983 IF(PYR(0).GT.0.5D0) JS=2
7988 ELSEIF(ISUB.EQ.16) THEN
7989 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
7990 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7991 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7992 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
7994 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
7997 ELSEIF(ISUB.EQ.17) THEN
7998 C...f + fbar -> g + h0; th arbitrary
7999 IF(PYR(0).GT.0.5D0) JS=2
8004 ELSEIF(ISUB.EQ.18) THEN
8005 C...f + fbar -> gamma + gamma; th arbitrary
8009 ELSEIF(ISUB.EQ.19) THEN
8010 C...f + fbar -> gamma + Z0; th arbitrary
8011 IF(PYR(0).GT.0.5D0) JS=2
8015 ELSEIF(ISUB.EQ.20) THEN
8016 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
8017 C...(p(fbar')-p(W+))**2
8018 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8019 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8020 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8022 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8025 ELSEIF(ISUB.LE.30) THEN
8027 C...f + fbar -> gamma + h0; th arbitrary
8028 IF(PYR(0).GT.0.5D0) JS=2
8032 ELSEIF(ISUB.EQ.22) THEN
8033 C...f + fbar -> Z0 + Z0; th arbitrary
8037 ELSEIF(ISUB.EQ.23) THEN
8038 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8039 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8040 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8041 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8043 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8045 ELSEIF(ISUB.EQ.24) THEN
8046 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
8047 IF(PYR(0).GT.0.5D0) JS=2
8051 ELSEIF(ISUB.EQ.25) THEN
8052 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
8053 MINT(21)=-ISIGN(24,MINT(15))
8056 ELSEIF(ISUB.EQ.26) THEN
8057 C...f + fbar' -> W+/- + h0 (or H0, or A0);
8058 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8059 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8060 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8061 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
8062 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
8065 ELSEIF(ISUB.EQ.27) THEN
8066 C...f + fbar -> h0 + h0
8068 ELSEIF(ISUB.EQ.28) THEN
8069 C...f + g -> f + g; th = (p(f)-p(f))**2
8071 IF(MINT(15).EQ.21) KCC=KCC+2
8072 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8073 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8075 ELSEIF(ISUB.EQ.29) THEN
8076 C...f + g -> f + gamma; th = (p(f)-p(f))**2
8077 IF(MINT(15).EQ.21) JS=2
8080 KCS=ISIGN(1,MINT(14+JS))
8082 ELSEIF(ISUB.EQ.30) THEN
8083 C...f + g -> f + Z0; th = (p(f)-p(f))**2
8084 IF(MINT(15).EQ.21) JS=2
8087 KCS=ISIGN(1,MINT(14+JS))
8090 ELSEIF(ISUB.LE.40) THEN
8092 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
8093 IF(MINT(15).EQ.21) JS=2
8096 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8097 RVCKM=VINT(180+I)*PYR(0)
8100 IPM=(5-ISIGN(1,I))/2
8102 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
8103 MINT(20+JS)=ISIGN(IB,I)
8104 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8105 IF(RVCKM.LE.0D0) GOTO 300
8108 KCS=ISIGN(1,MINT(14+JS))
8110 ELSEIF(ISUB.EQ.32) THEN
8111 C...f + g -> f + h0; th = (p(f)-p(f))**2
8112 IF(MINT(15).EQ.21) JS=2
8115 KCS=ISIGN(1,MINT(14+JS))
8117 ELSEIF(ISUB.EQ.33) THEN
8118 C...f + gamma -> f + g; th=(p(f)-p(f))**2
8119 IF(MINT(15).EQ.22) JS=2
8122 KCS=ISIGN(1,MINT(14+JS))
8124 ELSEIF(ISUB.EQ.34) THEN
8125 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
8126 IF(MINT(15).EQ.22) JS=2
8128 KCS=ISIGN(1,MINT(14+JS))
8130 ELSEIF(ISUB.EQ.35) THEN
8131 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
8132 IF(MINT(15).EQ.22) JS=2
8136 ELSEIF(ISUB.EQ.36) THEN
8137 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
8138 IF(MINT(15).EQ.22) JS=2
8141 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8143 RVCKM=VINT(180+I)*PYR(0)
8146 IPM=(5-ISIGN(1,I))/2
8148 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
8149 MINT(20+JS)=ISIGN(IB,I)
8150 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8151 IF(RVCKM.LE.0D0) GOTO 320
8154 IB=2*((IA+1)/2)-1+MOD(IA,2)
8155 MINT(20+JS)=ISIGN(IB,I)
8159 ELSEIF(ISUB.EQ.37) THEN
8160 C...f + gamma -> f + h0
8162 ELSEIF(ISUB.EQ.38) THEN
8165 ELSEIF(ISUB.EQ.39) THEN
8166 C...f + Z0 -> f + gamma
8168 ELSEIF(ISUB.EQ.40) THEN
8169 C...f + Z0 -> f + Z0
8172 ELSEIF(ISUB.LE.50) THEN
8174 C...f + Z0 -> f' + W+/-
8176 ELSEIF(ISUB.EQ.42) THEN
8177 C...f + Z0 -> f + h0
8179 ELSEIF(ISUB.EQ.43) THEN
8180 C...f + W+/- -> f' + g
8182 ELSEIF(ISUB.EQ.44) THEN
8183 C...f + W+/- -> f' + gamma
8185 ELSEIF(ISUB.EQ.45) THEN
8186 C...f + W+/- -> f' + Z0
8188 ELSEIF(ISUB.EQ.46) THEN
8189 C...f + W+/- -> f' + W+/-
8191 ELSEIF(ISUB.EQ.47) THEN
8192 C...f + W+/- -> f' + h0
8194 ELSEIF(ISUB.EQ.48) THEN
8197 ELSEIF(ISUB.EQ.49) THEN
8198 C...f + h0 -> f + gamma
8200 ELSEIF(ISUB.EQ.50) THEN
8201 C...f + h0 -> f + Z0
8204 ELSEIF(ISUB.LE.60) THEN
8206 C...f + h0 -> f' + W+/-
8208 ELSEIF(ISUB.EQ.52) THEN
8209 C...f + h0 -> f + h0
8211 ELSEIF(ISUB.EQ.53) THEN
8212 C...g + g -> f + fbar; th arbitrary
8213 KCS=(-1)**INT(1.5D0+PYR(0))
8214 MINT(21)=ISIGN(KFLF,KCS)
8218 ELSEIF(ISUB.EQ.54) THEN
8219 C...g + gamma -> f + fbar; th arbitrary
8220 KCS=(-1)**INT(1.5D0+PYR(0))
8221 MINT(21)=ISIGN(KFLF,KCS)
8224 IF(MINT(16).EQ.21) KCC=28
8226 ELSEIF(ISUB.EQ.55) THEN
8227 C...g + Z0 -> f + fbar
8229 ELSEIF(ISUB.EQ.56) THEN
8230 C...g + W+/- -> f + fbar'
8232 ELSEIF(ISUB.EQ.57) THEN
8233 C...g + h0 -> f + fbar
8235 ELSEIF(ISUB.EQ.58) THEN
8236 C...gamma + gamma -> f + fbar; th arbitrary
8237 KCS=(-1)**INT(1.5D0+PYR(0))
8238 MINT(21)=ISIGN(KFLF,KCS)
8242 ELSEIF(ISUB.EQ.59) THEN
8243 C...gamma + Z0 -> f + fbar
8245 ELSEIF(ISUB.EQ.60) THEN
8246 C...gamma + W+/- -> f + fbar'
8249 ELSEIF(ISUB.LE.70) THEN
8251 C...gamma + h0 -> f + fbar
8253 ELSEIF(ISUB.EQ.62) THEN
8254 C...Z0 + Z0 -> f + fbar
8256 ELSEIF(ISUB.EQ.63) THEN
8257 C...Z0 + W+/- -> f + fbar'
8259 ELSEIF(ISUB.EQ.64) THEN
8260 C...Z0 + h0 -> f + fbar
8262 ELSEIF(ISUB.EQ.65) THEN
8263 C...W+ + W- -> f + fbar
8265 ELSEIF(ISUB.EQ.66) THEN
8266 C...W+/- + h0 -> f + fbar'
8268 ELSEIF(ISUB.EQ.67) THEN
8269 C...h0 + h0 -> f + fbar
8271 ELSEIF(ISUB.EQ.68) THEN
8272 C...g + g -> g + g; th arbitrary
8274 KCS=(-1)**INT(1.5D0+PYR(0))
8276 ELSEIF(ISUB.EQ.69) THEN
8277 C...gamma + gamma -> W+ + W-; th arbitrary
8282 ELSEIF(ISUB.EQ.70) THEN
8283 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
8284 IF(MINT(15).EQ.22) MINT(21)=23
8285 IF(MINT(16).EQ.22) MINT(22)=23
8289 ELSEIF(ISUB.LE.80) THEN
8290 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
8291 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
8295 PMQ(1)=PYMASS(MINT(21))
8296 PMQ(2)=PYMASS(MINT(22))
8297 330 JT=INT(1.5D0+PYR(0))
8298 ZMIN=2D0*PMQ(JT)/SHPR
8299 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8300 & (SHPR*(SHPR-PMQ(3-JT)))
8301 ZMAX=MIN(1D0-XH,ZMAX)
8302 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8303 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8304 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
8305 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8306 IF(SQC1.LT.1D-8) GOTO 330
8308 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8309 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8310 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8311 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8312 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8313 IF(SQC1.LT.1D-8) GOTO 330
8315 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8316 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8317 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8320 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8321 & SQRT(1D0-CTHE(2)**2)*CPHI
8323 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8324 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8325 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8326 & PMQ(3-JT)**2/SHP))
8327 ZMIN=2D0*PMQ(3-JT)/SHPR
8328 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8329 ZMAX=MIN(1D0-XH,ZMAX)
8330 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
8333 ELSEIF(ISUB.EQ.73) THEN
8334 C...Z0 + W+/- -> Z0 + W+/-
8341 RVCKM=VINT(180+I)*PYR(0)
8344 IPM=(5-ISIGN(1,I))/2
8346 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
8347 MINT(20+JT)=ISIGN(IB,I)
8348 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8349 IF(RVCKM.LE.0D0) GOTO 360
8352 IB=2*((IA+1)/2)-1+MOD(IA,2)
8353 MINT(20+JT)=ISIGN(IB,I)
8355 360 PMQ(JT)=PYMASS(MINT(20+JT))
8356 MINT(23-JT)=MINT(17-JT)
8357 PMQ(3-JT)=PYMASS(MINT(23-JT))
8358 JT=INT(1.5D0+PYR(0))
8359 ZMIN=2D0*PMQ(JT)/SHPR
8360 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8361 & (SHPR*(SHPR-PMQ(3-JT)))
8362 ZMAX=MIN(1D0-XH,ZMAX)
8363 IF(ZMIN.GE.ZMAX) GOTO 340
8364 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8365 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8366 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
8367 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8368 IF(SQC1.LT.1D-8) GOTO 340
8370 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8371 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8372 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8373 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8374 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8375 IF(SQC1.LT.1D-8) GOTO 340
8377 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8378 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8379 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8382 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8383 & SQRT(1D0-CTHE(2)**2)*CPHI
8385 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8386 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8387 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8388 & PMQ(3-JT)**2/SHP))
8389 ZMIN=2D0*PMQ(3-JT)/SHPR
8390 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8391 ZMAX=MIN(1D0-XH,ZMAX)
8392 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
8395 ELSEIF(ISUB.EQ.74) THEN
8396 C...Z0 + h0 -> Z0 + h0
8398 ELSEIF(ISUB.EQ.75) THEN
8399 C...W+ + W- -> gamma + gamma
8401 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
8402 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
8408 RVCKM=VINT(180+I)*PYR(0)
8411 IPM=(5-ISIGN(1,I))/2
8413 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
8414 MINT(20+JT)=ISIGN(IB,I)
8415 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8416 IF(RVCKM.LE.0D0) GOTO 390
8419 IB=2*((IA+1)/2)-1+MOD(IA,2)
8420 MINT(20+JT)=ISIGN(IB,I)
8422 390 PMQ(JT)=PYMASS(MINT(20+JT))
8424 JT=INT(1.5D0+PYR(0))
8425 ZMIN=2D0*PMQ(JT)/SHPR
8426 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8427 & (SHPR*(SHPR-PMQ(3-JT)))
8428 ZMAX=MIN(1D0-XH,ZMAX)
8429 IF(ZMIN.GE.ZMAX) GOTO 370
8430 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8431 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8432 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
8433 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8434 IF(SQC1.LT.1D-8) GOTO 370
8436 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8437 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8438 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8439 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8440 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8441 IF(SQC1.LT.1D-8) GOTO 370
8443 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8444 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8445 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8448 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8449 & SQRT(1D0-CTHE(2)**2)*CPHI
8451 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8452 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8453 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8454 & PMQ(3-JT)**2/SHP))
8455 ZMIN=2D0*PMQ(3-JT)/SHPR
8456 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8457 ZMAX=MIN(1D0-XH,ZMAX)
8458 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
8461 ELSEIF(ISUB.EQ.78) THEN
8462 C...W+/- + h0 -> W+/- + h0
8464 ELSEIF(ISUB.EQ.79) THEN
8465 C...h0 + h0 -> h0 + h0
8467 ELSEIF(ISUB.EQ.80) THEN
8468 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
8469 IF(MINT(15).EQ.22) JS=2
8472 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
8474 MINT(20+JS)=ISIGN(IB,I)
8478 ELSEIF(ISUB.LE.90) THEN
8480 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
8481 MINT(21)=ISIGN(MINT(55),MINT(15))
8485 ELSEIF(ISUB.EQ.82) THEN
8486 C...g + g -> Q + Qbar; th arbitrary
8487 KCS=(-1)**INT(1.5D0+PYR(0))
8488 MINT(21)=ISIGN(MINT(55),KCS)
8492 ELSEIF(ISUB.EQ.83) THEN
8493 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
8495 IF(MINT(2).EQ.2) KFOLD=MINT(15)
8497 IF(KFAOLD.GT.10) THEN
8498 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
8500 RCKM=VINT(180+KFOLD)*PYR(0)
8501 IPM=(5-ISIGN(1,KFOLD))/2
8502 KFANEW=-MOD(KFAOLD+1,2)
8504 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
8505 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
8506 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
8507 & VCKM(KFAOLD/2,(KFANEW+1)/2)
8508 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
8509 & VCKM(KFANEW/2,(KFAOLD+1)/2)
8511 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
8513 IF(MINT(2).EQ.1) THEN
8514 MINT(21)=ISIGN(MINT(55),MINT(15))
8515 MINT(22)=ISIGN(KFANEW,MINT(16))
8517 MINT(21)=ISIGN(KFANEW,MINT(15))
8518 MINT(22)=ISIGN(MINT(55),MINT(16))
8523 ELSEIF(ISUB.EQ.84) THEN
8524 C...g + gamma -> Q + Qbar; th arbitary
8525 KCS=(-1)**INT(1.5D0+PYR(0))
8526 MINT(21)=ISIGN(MINT(55),KCS)
8529 IF(MINT(16).EQ.21) KCC=28
8531 ELSEIF(ISUB.EQ.85) THEN
8532 C...gamma + gamma -> F + Fbar; th arbitary
8533 KCS=(-1)**INT(1.5D0+PYR(0))
8534 MINT(21)=ISIGN(MINT(56),KCS)
8538 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
8539 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
8540 MINT(21)=KFPR(ISUB,1)
8541 MINT(22)=KFPR(ISUB,2)
8543 KCS=(-1)**INT(1.5D0+PYR(0))
8546 ELSEIF(ISUB.LE.100) THEN
8548 C...Low-pT ( = energyless g + g -> g + g)
8550 KCS=(-1)**INT(1.5D0+PYR(0))
8552 ELSEIF(ISUB.EQ.96) THEN
8553 C...Multiple interactions (should be reassigned to QCD process)
8556 ELSEIF(ISUB.LE.110) THEN
8557 IF(ISUB.EQ.101) THEN
8558 C...g + g -> gamma*/Z0
8562 ELSEIF(ISUB.EQ.102) THEN
8563 C...g + g -> h0 (or H0, or A0)
8567 ELSEIF(ISUB.EQ.103) THEN
8568 C...gamma + gamma -> h0 (or H0, or A0)
8572 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
8573 C...g + g -> chi_0c or chi_2c.
8577 ELSEIF(ISUB.EQ.106) THEN
8578 C...g + g -> J/Psi + gamma
8579 MINT(21)=KFPR(ISUB,1)
8580 MINT(22)=KFPR(ISUB,2)
8583 ELSEIF(ISUB.EQ.107) THEN
8584 C...g + gamma -> J/Psi + g
8585 MINT(21)=KFPR(ISUB,1)
8586 MINT(22)=KFPR(ISUB,2)
8588 IF(MINT(16).EQ.22) KCC=33
8590 ELSEIF(ISUB.EQ.108) THEN
8591 C...gamma + gamma -> J/Psi + gamma
8592 MINT(21)=KFPR(ISUB,1)
8593 MINT(22)=KFPR(ISUB,2)
8595 ELSEIF(ISUB.EQ.110) THEN
8596 C...f + fbar -> gamma + h0; th arbitrary
8597 IF(PYR(0).GT.0.5D0) JS=2
8602 ELSEIF(ISUB.LE.120) THEN
8603 IF(ISUB.EQ.111) THEN
8604 C...f + fbar -> g + h0; th arbitrary
8605 IF(PYR(0).GT.0.5D0) JS=2
8610 ELSEIF(ISUB.EQ.112) THEN
8611 C...f + g -> f + h0; th = (p(f) - p(f))**2
8612 IF(MINT(15).EQ.21) JS=2
8615 KCS=ISIGN(1,MINT(14+JS))
8617 ELSEIF(ISUB.EQ.113) THEN
8618 C...g + g -> g + h0; th arbitrary
8619 IF(PYR(0).GT.0.5D0) JS=2
8622 KCS=(-1)**INT(1.5D0+PYR(0))
8624 ELSEIF(ISUB.EQ.114) THEN
8625 C...g + g -> gamma + gamma; th arbitrary
8626 IF(PYR(0).GT.0.5D0) JS=2
8631 ELSEIF(ISUB.EQ.115) THEN
8632 C...g + g -> g + gamma; th arbitrary
8633 IF(PYR(0).GT.0.5D0) JS=2
8636 KCS=(-1)**INT(1.5D0+PYR(0))
8638 ELSEIF(ISUB.EQ.116) THEN
8639 C...g + g -> gamma + Z0
8641 ELSEIF(ISUB.EQ.117) THEN
8642 C...g + g -> Z0 + Z0
8644 ELSEIF(ISUB.EQ.118) THEN
8645 C...g + g -> W+ + W-
8648 ELSEIF(ISUB.LE.140) THEN
8649 IF(ISUB.EQ.121) THEN
8650 C...g + g -> Q + Qbar + h0
8651 KCS=(-1)**INT(1.5D0+PYR(0))
8652 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
8654 KCC=11+INT(0.5D0+PYR(0))
8657 ELSEIF(ISUB.EQ.122) THEN
8658 C...q + qbar -> Q + Qbar + h0
8659 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
8664 ELSEIF(ISUB.EQ.123) THEN
8665 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
8670 ELSEIF(ISUB.EQ.124) THEN
8671 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
8677 RVCKM=VINT(180+I)*PYR(0)
8680 IPM=(5-ISIGN(1,I))/2
8682 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
8683 MINT(20+JT)=ISIGN(IB,I)
8684 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8685 IF(RVCKM.LE.0D0) GOTO 430
8688 IB=2*((IA+1)/2)-1+MOD(IA,2)
8689 MINT(20+JT)=ISIGN(IB,I)
8695 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
8696 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
8697 IF(MINT(15).EQ.22) JS=2
8700 KCS=ISIGN(1,MINT(14+JS))
8702 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
8703 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
8704 IF(MINT(15).EQ.22) JS=2
8706 KCS=ISIGN(1,MINT(14+JS))
8708 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8709 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
8710 KCS=(-1)**INT(1.5D0+PYR(0))
8711 MINT(21)=ISIGN(KFLF,KCS)
8714 IF(MINT(16).EQ.21) KCC=28
8716 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8717 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
8718 KCS=(-1)**INT(1.5D0+PYR(0))
8719 MINT(21)=ISIGN(KFLF,KCS)
8725 ELSEIF(ISUB.LE.160) THEN
8726 IF(ISUB.EQ.141) THEN
8727 C...f + fbar -> gamma*/Z0/Z'0
8730 ELSEIF(ISUB.EQ.142) THEN
8731 C...f + fbar' -> W'+/-
8732 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8733 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8734 KFRES=ISIGN(34,KCH1+KCH2)
8736 ELSEIF(ISUB.EQ.143) THEN
8737 C...f + fbar' -> H+/-
8738 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8739 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8740 KFRES=ISIGN(37,KCH1+KCH2)
8742 ELSEIF(ISUB.EQ.144) THEN
8744 KFRES=ISIGN(40,MINT(15)+MINT(16))
8746 ELSEIF(ISUB.EQ.145) THEN
8747 C...q + l -> LQ (leptoquark)
8748 IF(IABS(MINT(16)).LE.8) JS=2
8749 KFRES=ISIGN(39,MINT(14+JS))
8751 KCS=ISIGN(1,MINT(14+JS))
8753 ELSEIF(ISUB.EQ.146) THEN
8754 C...e + gamma -> e* (excited lepton)
8755 IF(MINT(15).EQ.22) JS=2
8756 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
8759 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
8760 C...q + g -> q* (excited quark)
8761 IF(MINT(15).EQ.21) JS=2
8762 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
8764 KCS=ISIGN(1,MINT(14+JS))
8766 ELSEIF(ISUB.EQ.149) THEN
8767 C...g + g -> eta_techni
8770 KCS=(-1)**INT(1.5D0+PYR(0))
8773 ELSEIF(ISUB.LE.200) THEN
8774 IF(ISUB.EQ.161) THEN
8775 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
8776 IF(MINT(15).EQ.21) JS=2
8779 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
8780 IB=IA+MOD(IA,2)-MOD(IA+1,2)
8781 MINT(20+JS)=ISIGN(IB,I)
8783 KCS=ISIGN(1,MINT(14+JS))
8785 ELSEIF(ISUB.EQ.162) THEN
8786 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
8787 IF(MINT(15).EQ.21) JS=2
8788 MINT(20+JS)=ISIGN(39,MINT(14+JS))
8789 KFLQL=KFDP(MDCY(39,2),2)
8790 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
8792 KCS=ISIGN(1,MINT(14+JS))
8794 ELSEIF(ISUB.EQ.163) THEN
8795 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
8796 KCS=(-1)**INT(1.5D0+PYR(0))
8797 MINT(21)=ISIGN(39,KCS)
8801 ELSEIF(ISUB.EQ.164) THEN
8802 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
8803 MINT(21)=ISIGN(39,MINT(15))
8807 ELSEIF(ISUB.EQ.165) THEN
8808 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
8809 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8812 ELSEIF(ISUB.EQ.166) THEN
8813 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
8814 IF(MOD(MINT(15),2).EQ.0) THEN
8815 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
8816 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
8818 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8819 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
8822 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
8823 C...q + q' -> q" + q* (excited quark)
8825 KFQEXC=MOD(KFQSTR,KEXCIT)
8827 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
8828 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
8829 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
8832 ELSEIF(ISUB.EQ.169) THEN
8833 C...q + qbar -> e + e* (excited lepton)
8835 KFQEXC=MOD(KFQSTR,KEXCIT)
8837 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
8838 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
8840 ELSEIF(ISUB.EQ.191) THEN
8841 C...f + fbar -> rho_tech0.
8844 ELSEIF(ISUB.EQ.192) THEN
8845 C...f + fbar' -> rho_tech+/-
8846 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8847 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8848 KFRES=ISIGN(55,KCH1+KCH2)
8850 ELSEIF(ISUB.EQ.193) THEN
8851 C...f + fbar -> omega_tech0.
8854 ELSEIF(ISUB.EQ.194) THEN
8855 C...f + fbar -> f' + fbar' via mixture of s-channel
8856 C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
8857 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8860 ELSEIF(ISUB.EQ.195) THEN
8861 C...f + fbar' -> f'' + fbar''' via s-channel
8862 C...rho_tech+ th=(p(f)-p(f'))**2
8863 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
8864 IF(MOD(MINT(15),2).EQ.0) THEN
8865 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
8866 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
8868 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8869 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
8874 ELSEIF(ISUB.LE.215) THEN
8875 IF(ISUB.EQ.201) THEN
8876 C...f + fbar -> ~e_L + ~e_Lbar
8877 MINT(21)=ISIGN(KSUSY1+11,KCS)
8880 ELSEIF(ISUB.EQ.202) THEN
8881 C...f + fbar -> ~e_R + ~e_Rbar
8882 MINT(21)=ISIGN(KSUSY2+11,KCS)
8885 ELSEIF(ISUB.EQ.203) THEN
8886 C...f + fbar -> ~e_R + ~e_Lbar
8888 IF(MINT(2).EQ.2) KCSG=-1
8889 MINT(21)=ISIGN(KSUSY1+11,KCSG)
8890 MINT(22)=-ISIGN(KSUSY2+11,KCSG)
8892 ELSEIF(ISUB.EQ.204) THEN
8893 C...f + fbar -> ~mu_L + ~mu_Lbar
8894 MINT(21)=ISIGN(KSUSY1+13,KCS)
8897 ELSEIF(ISUB.EQ.205) THEN
8898 C...f + fbar -> ~mu_R + ~mu_Rbar
8899 MINT(21)=ISIGN(KSUSY2+13,KCS)
8902 ELSEIF(ISUB.EQ.206) THEN
8903 C...f + fbar -> ~mu_L + ~mu_Rbar
8905 IF(MINT(2).EQ.2) KCSG=-1
8906 MINT(21)=ISIGN(KSUSY1+13,KCSG)
8907 MINT(22)=-ISIGN(KSUSY2+13,KCSG)
8909 ELSEIF(ISUB.EQ.207) THEN
8910 C...f + fbar -> ~tau_1 + ~tau_1bar
8911 MINT(21)=ISIGN(KSUSY1+15,KCS)
8914 ELSEIF(ISUB.EQ.208) THEN
8915 C...f + fbar -> ~tau_2 + ~tau_2bar
8916 MINT(21)=ISIGN(KSUSY2+15,KCS)
8919 ELSEIF(ISUB.EQ.209) THEN
8920 C...f + fbar -> ~tau_1 + ~tau_2bar
8922 IF(MINT(2).EQ.2) KCSG=-1
8923 MINT(21)=ISIGN(KSUSY1+15,KCSG)
8924 MINT(22)=-ISIGN(KSUSY2+15,KCSG)
8926 ELSEIF(ISUB.EQ.210) THEN
8927 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
8928 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8929 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8930 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
8931 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
8933 ELSEIF(ISUB.EQ.211) THEN
8934 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
8935 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8936 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8937 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
8938 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
8940 ELSEIF(ISUB.EQ.212) THEN
8941 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
8942 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8943 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8944 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
8945 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
8947 ELSEIF(ISUB.EQ.213) THEN
8948 C...f + fbar -> ~nul + ~nulbar
8949 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8952 ELSEIF(ISUB.EQ.214) THEN
8953 C...f + fbar -> ~nutau + ~nutaubar
8954 MINT(21)=ISIGN(KSUSY1+16,KCS)
8958 ELSEIF(ISUB.LE.225) THEN
8959 IF(ISUB.EQ.216) THEN
8960 C...f + fbar -> ~chi01 + ~chi01
8964 ELSEIF(ISUB.EQ.217) THEN
8965 C...f + fbar -> ~chi02 + ~chi02
8969 ELSEIF(ISUB.EQ.218 ) THEN
8970 C...f + fbar -> ~chi03 + ~chi03
8974 ELSEIF(ISUB.EQ.219 ) THEN
8975 C...f + fbar -> ~chi04 + ~chi04
8979 ELSEIF(ISUB.EQ.220 ) THEN
8980 C...f + fbar -> ~chi01 + ~chi02
8981 IF(PYR(0).GT.0.5D0) JS=2
8982 MINT(20+JS)=KSUSY1+22
8983 MINT(23-JS)=KSUSY1+23
8985 ELSEIF(ISUB.EQ.221 ) THEN
8986 C...f + fbar -> ~chi01 + ~chi03
8987 IF(PYR(0).GT.0.5D0) JS=2
8988 MINT(20+JS)=KSUSY1+22
8989 MINT(23-JS)=KSUSY1+25
8991 ELSEIF(ISUB.EQ.222) THEN
8992 C...f + fbar -> ~chi01 + ~chi04
8993 IF(PYR(0).GT.0.5D0) JS=2
8994 MINT(20+JS)=KSUSY1+22
8995 MINT(23-JS)=KSUSY1+35
8997 ELSEIF(ISUB.EQ.223) THEN
8998 C...f + fbar -> ~chi02 + ~chi03
8999 IF(PYR(0).GT.0.5D0) JS=2
9000 MINT(20+JS)=KSUSY1+23
9001 MINT(23-JS)=KSUSY1+25
9003 ELSEIF(ISUB.EQ.224) THEN
9004 C...f + fbar -> ~chi02 + ~chi04
9005 IF(PYR(0).GT.0.5D0) JS=2
9006 MINT(20+JS)=KSUSY1+23
9007 MINT(23-JS)=KSUSY1+35
9009 ELSEIF(ISUB.EQ.225) THEN
9010 C...f + fbar -> ~chi03 + ~chi04
9011 IF(PYR(0).GT.0.5D0) JS=2
9012 MINT(20+JS)=KSUSY1+25
9013 MINT(23-JS)=KSUSY1+35
9016 ELSEIF(ISUB.LE.236) THEN
9017 IF(ISUB.EQ.226) THEN
9018 C...f + fbar -> ~chi+-1 + ~chi-+1
9019 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
9020 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9021 MINT(21)=ISIGN(KSUSY1+24,KCH1)
9024 ELSEIF(ISUB.EQ.227) THEN
9025 C...f + fbar -> ~chi+-2 + ~chi-+2
9026 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9027 MINT(21)=ISIGN(KSUSY1+37,KCH1)
9030 ELSEIF(ISUB.EQ.228) THEN
9031 C...f + fbar -> ~chi+-1 + ~chi-+2
9032 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
9033 C...js=1 if pyr<.5, js=2 if pyr>.5
9034 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
9035 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
9036 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
9037 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
9038 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9039 C KCH1=ISIGN(1,MINT(15))
9041 IF(MINT(2).EQ.1) THEN
9042 MINT(22-KCH2)= -(KSUSY1+24)
9043 MINT(21+KCH2)= KSUSY1+37
9046 MINT(21+KCH2)= KSUSY1+24
9047 MINT(22-KCH2)= -(KSUSY1+37)
9051 ELSEIF(ISUB.EQ.229) THEN
9052 C...q + qbar' -> ~chi01 + ~chi+-1
9053 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
9054 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9055 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9057 IF(MOD(MINT(15),2).NE.0) JS=2
9058 MINT(20+JS)=KSUSY1+22
9059 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9061 ELSEIF(ISUB.EQ.230) THEN
9062 C...q + qbar' -> ~chi02 + ~chi+-1
9063 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9064 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9065 IF(MOD(MINT(15),2).NE.0) JS=2
9066 MINT(20+JS)=KSUSY1+23
9067 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9069 ELSEIF(ISUB.EQ.231) THEN
9070 C...q + qbar' -> ~chi03 + ~chi+-1
9071 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9072 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9073 IF(MOD(MINT(15),2).NE.0) JS=2
9074 MINT(20+JS)=KSUSY1+25
9075 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9077 ELSEIF(ISUB.EQ.232) THEN
9078 C...q + qbar' -> ~chi04 + ~chi+-1
9079 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9080 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9081 IF(MOD(MINT(15),2).NE.0) JS=2
9082 MINT(20+JS)=KSUSY1+35
9083 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9085 ELSEIF(ISUB.EQ.233) THEN
9086 C...q + qbar' -> ~chi01 + ~chi+-2
9087 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9088 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9089 IF(MOD(MINT(15),2).NE.0) JS=2
9090 MINT(20+JS)=KSUSY1+22
9091 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9093 ELSEIF(ISUB.EQ.234) THEN
9094 C...q + qbar' -> ~chi02 + ~chi+-2
9095 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9096 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9097 IF(MOD(MINT(15),2).NE.0) JS=2
9098 MINT(20+JS)=KSUSY1+23
9099 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9101 ELSEIF(ISUB.EQ.235) THEN
9102 C...q + qbar' -> ~chi03 + ~chi+-2
9103 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9104 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9105 IF(MOD(MINT(15),2).NE.0) JS=2
9106 MINT(20+JS)=KSUSY1+25
9107 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9109 ELSEIF(ISUB.EQ.236) THEN
9110 C...q + qbar' -> ~chi04 + ~chi+-2
9111 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9112 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9113 IF(MOD(MINT(15),2).NE.0) JS=2
9114 MINT(20+JS)=KSUSY1+35
9115 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9118 ELSEIF(ISUB.LE.245) THEN
9119 IF(ISUB.EQ.237) THEN
9120 C...q + qbar -> ~chi01 + ~g
9122 IF(PYR(0).GT.0.5D0) JS=2
9123 MINT(20+JS)=KSUSY1+21
9124 MINT(23-JS)=KSUSY1+22
9127 ELSEIF(ISUB.EQ.238) THEN
9128 C...q + qbar -> ~chi02 + ~g
9130 IF(PYR(0).GT.0.5D0) JS=2
9131 MINT(20+JS)=KSUSY1+21
9132 MINT(23-JS)=KSUSY1+23
9135 ELSEIF(ISUB.EQ.239) THEN
9136 C...q + qbar -> ~chi03 + ~g
9138 IF(PYR(0).GT.0.5D0) JS=2
9139 MINT(20+JS)=KSUSY1+21
9140 MINT(23-JS)=KSUSY1+25
9143 ELSEIF(ISUB.EQ.240) THEN
9144 C...q + qbar -> ~chi04 + ~g
9146 IF(PYR(0).GT.0.5D0) JS=2
9147 MINT(20+JS)=KSUSY1+21
9148 MINT(23-JS)=KSUSY1+35
9151 ELSEIF(ISUB.EQ.241) THEN
9152 C...q + qbar' -> ~chi+-1 + ~g
9153 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
9154 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
9155 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
9156 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
9157 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
9158 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9159 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9161 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9162 MINT(20+JS)=KSUSY1+21
9163 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9166 ELSEIF(ISUB.EQ.242) THEN
9167 C...q + qbar' -> ~chi+-2 + ~g
9168 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
9169 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
9170 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
9171 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
9172 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
9173 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9174 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9176 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9177 MINT(20+JS)=KSUSY1+21
9178 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9181 ELSEIF(ISUB.EQ.243) THEN
9182 C...q + qbar -> ~g + ~g ; th arbitrary
9187 ELSEIF(ISUB.EQ.244) THEN
9188 C...g + g -> ~g + ~g ; th arbitrary
9190 KCS=(-1)**INT(1.5D0+PYR(0))
9195 ELSEIF(ISUB.LE.260) THEN
9196 IF(ISUB.EQ.246) THEN
9197 C...qj + g -> ~qj_L + ~chi01
9198 IF(MINT(15).EQ.21) JS=2
9201 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9202 MINT(23-JS)=KSUSY1+22
9204 KCS=ISIGN(1,MINT(14+JS))
9206 ELSEIF(ISUB.EQ.247) THEN
9207 C...qj + g -> ~qj_R + ~chi01
9208 IF(MINT(15).EQ.21) JS=2
9211 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9212 MINT(23-JS)=KSUSY1+22
9214 KCS=ISIGN(1,MINT(14+JS))
9216 ELSEIF(ISUB.EQ.248) THEN
9217 C...qj + g -> ~qj_L + ~chi02
9218 IF(MINT(15).EQ.21) JS=2
9221 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9222 MINT(23-JS)=KSUSY1+23
9224 KCS=ISIGN(1,MINT(14+JS))
9226 ELSEIF(ISUB.EQ.249) THEN
9227 C...qj + g -> ~qj_R + ~chi02
9228 IF(MINT(15).EQ.21) JS=2
9231 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9232 MINT(23-JS)=KSUSY1+23
9234 KCS=ISIGN(1,MINT(14+JS))
9236 ELSEIF(ISUB.EQ.250) THEN
9237 C...qj + g -> ~qj_L + ~chi03
9238 IF(MINT(15).EQ.21) JS=2
9241 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9242 MINT(23-JS)=KSUSY1+25
9244 KCS=ISIGN(1,MINT(14+JS))
9246 ELSEIF(ISUB.EQ.251) THEN
9247 C...qj + g -> ~qj_R + ~chi03
9248 IF(MINT(15).EQ.21) JS=2
9251 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9252 MINT(23-JS)=KSUSY1+25
9254 KCS=ISIGN(1,MINT(14+JS))
9256 ELSEIF(ISUB.EQ.252) THEN
9257 C...qj + g -> ~qj_L + ~chi04
9258 IF(MINT(15).EQ.21) JS=2
9261 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9262 MINT(23-JS)=KSUSY1+35
9264 KCS=ISIGN(1,MINT(14+JS))
9266 ELSEIF(ISUB.EQ.253) THEN
9267 C...qj + g -> ~qj_R + ~chi04
9268 IF(MINT(15).EQ.21) JS=2
9271 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9272 MINT(23-JS)=KSUSY1+35
9274 KCS=ISIGN(1,MINT(14+JS))
9276 ELSEIF(ISUB.EQ.254) THEN
9277 C...qj + g -> ~qk_L + ~chi+-1
9278 IF(MINT(15).EQ.21) JS=2
9281 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
9282 IB=-IA+INT((IA+1)/2)*4-1
9283 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
9285 KCS=ISIGN(1,MINT(14+JS))
9287 ELSEIF(ISUB.EQ.255) THEN
9288 C...qj + g -> ~qk_L + ~chi+-1
9289 IF(MINT(15).EQ.21) JS=2
9292 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
9293 IB=-IA+INT((IA+1)/2)*4-1
9294 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
9296 KCS=ISIGN(1,MINT(14+JS))
9298 ELSEIF(ISUB.EQ.256) THEN
9299 C...qj + g -> ~qk_L + ~chi+-2
9300 IF(MINT(15).EQ.21) JS=2
9303 IB=-IA+INT((IA+1)/2)*4-1
9304 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
9305 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
9307 KCS=ISIGN(1,MINT(14+JS))
9309 ELSEIF(ISUB.EQ.257) THEN
9310 C...qj + g -> ~qk_R + ~chi+-2
9311 IF(MINT(15).EQ.21) JS=2
9314 IB=-IA+INT((IA+1)/2)*4-1
9315 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
9316 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
9318 KCS=ISIGN(1,MINT(14+JS))
9320 ELSEIF(ISUB.EQ.258) THEN
9321 C...qj + g -> ~qj_L + ~g
9322 IF(MINT(15).EQ.21) JS=2
9325 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9326 MINT(23-JS)=KSUSY1+21
9328 IF(JS.EQ.2) KCC=KCC+2
9331 ELSEIF(ISUB.EQ.259) THEN
9332 C...qj + g -> ~qj_R + ~g
9333 IF(MINT(15).EQ.21) JS=2
9336 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9337 MINT(23-JS)=KSUSY1+21
9339 IF(JS.EQ.2) KCC=KCC+2
9343 ELSEIF(ISUB.LE.270) THEN
9344 IF(ISUB.EQ.261) THEN
9345 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
9347 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
9348 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
9350 C...Correct color combination
9351 IF(MINT(43).EQ.4) KCC=4
9353 ELSEIF(ISUB.EQ.262) THEN
9354 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
9356 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
9357 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
9359 C...Correct color combination
9360 IF(MINT(43).EQ.4) KCC=4
9362 ELSEIF(ISUB.EQ.263) THEN
9363 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
9364 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
9365 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
9366 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9367 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
9370 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
9371 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
9373 C...Correct color combination
9374 IF(MINT(43).EQ.4) KCC=4
9376 ELSEIF(ISUB.EQ.264) THEN
9377 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
9378 KCS=(-1)**INT(1.5D0+PYR(0))
9379 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9383 ELSEIF(ISUB.EQ.265) THEN
9384 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
9385 KCS=(-1)**INT(1.5D0+PYR(0))
9386 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9391 ELSEIF(ISUB.LE.296) THEN
9392 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
9393 C...qi + qj -> ~qi_L + ~qj_L
9395 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9396 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
9397 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
9399 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
9400 C...qi + qj -> ~qi_R + ~qj_R
9402 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9403 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
9404 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
9406 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
9407 C...qi + qj -> ~qi_L + ~qj_R
9408 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9409 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
9411 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9413 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
9414 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
9415 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
9416 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
9418 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9420 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
9421 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
9422 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
9423 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
9425 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9427 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
9428 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
9429 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9430 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
9432 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9434 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
9435 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
9437 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
9438 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
9440 IF(MINT(43).EQ.4) KCC=4
9442 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
9443 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
9445 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
9446 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
9448 IF(MINT(43).EQ.4) KCC=4
9450 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
9451 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
9453 KCS=(-1)**INT(1.5D0+PYR(0))
9454 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9458 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
9459 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
9460 KCS=(-1)**INT(1.5D0+PYR(0))
9461 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9465 ELSEIF(ISUB.EQ.294) THEN
9466 C...qj + g -> ~qj_L + ~g
9467 IF(MINT(15).EQ.21) JS=2
9470 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9471 MINT(23-JS)=KSUSY1+21
9473 IF(JS.EQ.2) KCC=KCC+2
9476 ELSEIF(ISUB.EQ.295) THEN
9477 C...qj + g -> ~qj_R + ~g
9478 IF(MINT(15).EQ.21) JS=2
9481 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9482 MINT(23-JS)=KSUSY1+21
9484 IF(JS.EQ.2) KCC=KCC+2
9488 ELSEIF(ISUB.LE.340) THEN
9490 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
9491 C...q + qbar' -> H+ + H0
9492 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9493 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9494 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9495 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
9496 MINT(23-JS)=KFPR(ISUB,2)
9497 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
9498 C...f + fbar -> A0 + H0; th arbitrary
9499 IF(PYR(0).GT.0.5D0) JS=2
9500 MINT(20+JS)=KFPR(ISUB,1)
9501 MINT(23-JS)=KFPR(ISUB,2)
9502 ELSEIF(ISUB.EQ.301) THEN
9503 C...f + fbar -> H+ H-
9504 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9509 ELSEIF(ISUB.LE.360) THEN
9511 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
9512 C...l + l -> H_L++/--, H_R++/--
9513 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9514 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9515 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9517 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
9518 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
9519 IF(MINT(15).EQ.22) JS=2
9520 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
9521 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
9524 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
9525 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
9526 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
9529 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
9530 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
9531 C...as inner process).
9536 RVCKM=VINT(180+I)*PYR(0)
9539 IPM=(5-ISIGN(1,I))/2
9541 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 422
9542 MINT(20+JT)=ISIGN(IB,I)
9543 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9544 IF(RVCKM.LE.0D0) GOTO 432
9547 IB=2*((IA+1)/2)-1+MOD(IA,2)
9548 MINT(20+JT)=ISIGN(IB,I)
9552 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
9553 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
9557 ELSEIF(ISUB.LE.380) THEN
9558 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
9559 C...f + fbar -> pi+ pi-
9560 KSW=(-1)**INT(1.5D0+PYR(0))
9561 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
9562 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
9563 C...f + fbar -> neutral neutral
9564 ELSEIF(ISUB.LE.367) THEN
9565 MINT(21)=KFPR(ISUB,1)
9566 MINT(22)=KFPR(ISUB,2)
9567 C...f + fbar' -> charged neutral
9568 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
9571 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9572 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9573 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9574 c MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
9575 c MINT(23-JS)=KFPR(ISUB,IN)
9576 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
9577 MINT(20+JS)=KFPR(ISUB,IN)
9579 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
9582 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9583 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9584 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9585 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
9586 MINT(23-JS)=KFPR(ISUB,IN)
9590 IF(ISET(ISUB).EQ.11) THEN
9591 C...Store documentation for user-defined processes
9592 BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4))
9598 IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN
9608 IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3))
9615 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
9618 C...Store final state partons for user-defined processes
9623 IF(KUP(IUP,1).NE.1) K(N,1)=11
9625 IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN
9628 K(N,3)=MINT(84)+KUP(IUP,3)
9636 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
9638 C...Arrange colour flow for user-defined processes
9642 IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480
9643 IF(K(N,1).EQ.1) K(N,1)=3
9644 IF(K(N,1).EQ.11) K(N,1)=14
9645 IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+
9647 IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+
9649 IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84)
9650 IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84)
9653 ELSEIF(IDOC.EQ.7) THEN
9654 C...Resonance not decaying; store kinematics
9669 C...Special cases: colour flow in coloured resonances
9671 IF(KCHG(KCRES,2).NE.0) THEN
9675 IF(KCS.EQ.-1) JC=3-J
9676 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
9677 & MINT(84)+ICOL(KCC,1,JC)
9678 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
9679 & MINT(84)+ICOL(KCC,2,JC)
9680 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
9681 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
9690 ELSEIF(IDOC.EQ.8) THEN
9691 C...2 -> 2 processes: store outgoing partons in their CM-frame
9694 KCA=PYCOMP(MINT(20+JT))
9696 IF(KCHG(KCA,2).NE.0) K(I,1)=3
9698 K(I,3)=MINT(83)+IDOC+JT-2
9700 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
9701 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
9703 P(I,5)=PYMASS(K(I,2))
9705 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
9706 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
9708 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
9711 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
9719 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
9720 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
9721 P(IPU4,4)=SHR-P(IPU3,4)
9722 P(IPU4,3)=-P(IPU3,3)
9727 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
9728 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
9730 ELSEIF(IDOC.EQ.9) THEN
9731 C...2 -> 3 processes: store outgoing partons in their CM frame
9734 KCA=PYCOMP(MINT(20+JT))
9736 IF(KCHG(KCA,2).NE.0) K(I,1)=3
9738 K(I,3)=MINT(83)+IDOC+JT-3
9739 IF(IABS(K(I,2)).LE.22) THEN
9740 P(I,5)=PYMASS(K(I,2))
9742 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
9744 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
9745 P(I,1)=PT*COS(VINT(198+5*JT))
9746 P(I,2)=PT*SIN(VINT(198+5*JT))
9750 K(IPU5,3)=MINT(83)+IDOC
9752 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
9753 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
9754 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
9755 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
9756 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
9758 P(IPU5,3)=PMT3*SINH(VINT(211))
9759 P(IPU5,4)=PMT3*COSH(VINT(211))
9760 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
9761 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
9762 IF(SQL12.LE.0D0) THEN
9766 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
9767 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
9768 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
9769 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
9770 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
9776 ELSEIF(IDOC.EQ.11) THEN
9777 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
9778 PHI(1)=PARU(2)*PYR(0)
9783 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
9785 K(I,3)=MINT(83)+IDOC+JT-2
9786 P(I,5)=PYMASS(K(I,2))
9787 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
9791 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
9792 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
9793 P(I,1)=PTABS*COS(PHI(JT))
9794 P(I,2)=PTABS*SIN(PHI(JT))
9795 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
9796 P(I,4)=0.5D0*SHPR*Z(JT)
9800 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
9804 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
9805 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
9806 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
9813 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
9814 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
9815 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
9816 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
9825 ELSEIF(IDOC.EQ.12) THEN
9826 C...Z0 and W+/- scattering: store bosons and outgoing partons
9827 PHI(1)=PARU(2)*PYR(0)
9829 JTRAN=INT(1.5D0+PYR(0))
9833 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
9835 K(I,3)=MINT(83)+IDOC+JT-2
9836 P(I,5)=PYMASS(K(I,2))
9837 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
9838 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
9839 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
9840 P(I,1)=PTABS*COS(PHI(JT))
9841 P(I,2)=PTABS*SIN(PHI(JT))
9842 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
9843 P(I,4)=0.5D0*SHPR*Z(JT)
9846 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
9849 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
9854 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
9855 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
9856 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
9859 K(IPU,2)=KFPR(ISUB,JT)
9860 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
9861 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
9862 K(IPU,3)=MINT(83)+8+JT
9863 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
9864 P(IPU,5)=PYMASS(K(IPU,2))
9866 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
9868 MINT(22+JT)=K(IPU,2)
9870 C...Find rotation and boost for hard scattering subsystem
9873 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
9874 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
9875 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
9876 GAMCM=(P(I1,4)+P(I2,4))/SHR
9877 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
9878 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
9879 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
9880 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
9881 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
9883 C...Store hard scattering subsystem. Rotate and boost it
9884 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
9886 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
9888 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
9889 PHIWZ=VINT(24)-PHICM
9890 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
9891 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
9892 P(IPU5,3)=PABS*CTHWZ
9893 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
9894 P(IPU6,1)=-P(IPU5,1)
9895 P(IPU6,2)=-P(IPU5,2)
9896 P(IPU6,3)=-P(IPU5,3)
9897 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
9898 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
9913 IF(ISET(ISUB).EQ.11) THEN
9914 ELSEIF(IDOC.GE.8) THEN
9915 C...Store colour connection indices
9918 IF(KCS.EQ.-1) JC=3-J
9919 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
9920 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
9921 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
9922 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
9923 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
9924 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
9925 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
9926 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
9929 C...Copy outgoing partons to documentation lines
9931 IF(IDOC.EQ.9) IMAX=3
9933 I1=MINT(83)+IDOC-IMAX+I
9937 IF(IDOC.LE.9) K(I1,3)=0
9938 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
9944 ELSEIF(IDOC.EQ.9) THEN
9945 C...Store colour connection indices
9948 IF(KCS.EQ.-1) JC=3-J
9949 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
9950 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
9951 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
9952 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
9953 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
9954 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
9955 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
9956 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
9957 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
9958 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
9961 C...Copy outgoing partons to documentation lines
9963 I1=MINT(83)+IDOC-3+I
9974 C...Low-pT events: remove gluons used for string drawing purposes
9976 K(IPU3,1)=K(IPU3,1)+10
9977 K(IPU4,1)=K(IPU4,1)+10
9982 DO 650 I=MINT(83)+5,MINT(83)+8
9992 C*********************************************************************
9995 C...Generates spacelike parton showers.
9997 SUBROUTINE PYSSPA(IPU1,IPU2)
9999 C...Double precision and integer declarations.
10000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10001 IMPLICIT INTEGER(I-N)
10002 INTEGER PYK,PYCHGE,PYCOMP
10004 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10005 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10006 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10007 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10008 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10009 COMMON/PYINT1/MINT(400),VINT(400)
10010 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10011 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10012 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10014 C...Local arrays and data.
10015 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
10016 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
10017 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
10018 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
10019 &THEFIS(2,2),ISFI(2)
10022 C...Read out basic information; set global Q^2 scale.
10027 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
10029 IF(MSTP(68).EQ.1.AND.(ISUB.EQ.1.OR.ISUB.EQ.2.OR.
10030 &ISUB.EQ.141.OR.ISUB.EQ.142.OR.ISUB.EQ.144)) MECOR=1
10033 C...Initialize QCD evolution and check phase space.
10037 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
10040 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10041 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10042 Q2INT=SQRT(Q0S*Q2EFF)
10043 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
10044 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
10045 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
10047 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
10050 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10051 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10052 Q2INT=SQRT(Q0S*Q2EFF)
10053 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
10054 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
10055 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
10062 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
10064 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
10065 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
10066 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
10067 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
10071 C...Initialize QED evolution and check phase space.
10075 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
10076 &SPME=PMAS(13,1)**2
10077 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
10078 &SPME=PMAS(15,1)**2
10079 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
10082 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
10084 TEMX=LOG(Q2MX/SPME)
10085 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
10087 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
10089 C...Loopback point in case of failure to reconstruct kinematics.
10093 IF(LOOP.GT.100) THEN
10099 C...Initial values: flavours, momenta, virtualities.
10102 KFBEAM(JT)=MINT(10+JT)
10103 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
10104 KFLS(JT)=MINT(14+JT)
10105 KFLS(JT+2)=KFLS(JT)
10107 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
10109 Q2S(JT)=FCQ2MX*Q2MX
10115 XFS(JT,KFL)=XSFX(JT,KFL)
10117 C...Special kinematics check for c/b quarks (that g -> c cbar or
10118 C...b bbar kinematically possible).
10119 KFLCB=IABS(KFLS(JT))
10120 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
10121 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
10128 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
10130 C...Find if interference with final state partons.
10132 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
10136 KCA=PYCOMP(IABS(KFLS(I)))
10137 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
10139 IF(KCFI(I).NE.0) THEN
10140 IF(I.EQ.1) IPFS=IPUS1
10141 IF(I.EQ.2) IPFS=IPUS2
10143 ICSI=MOD(K(IPFS,3+J),MSTU(5))
10144 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
10145 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
10147 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
10149 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
10154 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
10157 C...Pick up leg with highest virtuality.
10160 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
10161 IF(MORE(JT).EQ.0) JT=3-JT
10165 XFB(KFL)=XFS(JT,KFL)
10170 C...Check if allowed to branch.
10172 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
10174 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
10175 IF(XB.GE.1D0-2D0*XEC) MCEV=0
10178 IF(MINT(44+JT).EQ.3) THEN
10180 IF(XB.GE.1D0-2D0*XEE) MEEV=0
10181 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
10183 C***Currently kill QED shower for resolved photoproduction.
10184 IF(MINT(18+JT).EQ.1) MEEV=0
10185 C***Currently kill shower for W inside electron.
10186 IF(IABS(KFLB).EQ.24) THEN
10191 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
10196 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
10200 IF(MSTP(62).LE.1) THEN
10201 IF(ZS(JT).GT.0.99999D0) THEN
10204 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
10205 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
10206 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
10208 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
10209 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
10212 ALSDUM=PYALPS(FQ2C*Q2B)
10213 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
10215 B0=(33D0-2D0*MSTU(118))/6D0
10220 C...Select side for interference with final state partons.
10221 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
10224 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
10226 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
10227 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
10228 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
10230 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
10234 C...Calculate Altarelli-Parisi weights.
10240 C...q -> q, g -> q.
10241 IF(IABS(KFLB).LE.10) THEN
10242 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
10243 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
10244 IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2))
10245 & WTAPC(21)=3D0*WTAPC(21)
10246 C...f -> f, gamma -> f.
10247 ELSEIF(IABS(KFLB).LE.20) THEN
10248 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
10249 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
10250 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
10251 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
10252 IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2))
10253 & WTAPE(22)=3D0*WTAPE(22)
10254 C...f -> g, g -> g.
10255 ELSEIF(KFLB.EQ.21) THEN
10256 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
10257 DO 180 KFL=1,MSTP(58)
10261 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
10262 C...f -> gamma, W+, W-.
10263 ELSEIF(KFLB.EQ.22) THEN
10264 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
10267 ELSEIF(KFLB.EQ.24) THEN
10268 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
10269 & (XEE*(XB+XEE)))/XB
10270 ELSEIF(KFLB.EQ.-24) THEN
10271 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
10272 & (XEE*(XB+XEE)))/XB
10275 C...Calculate parton distribution weights and sum.
10278 IF(NTRY.GT.500) THEN
10284 XFBO=MAX(1D-10,XFB(KFLB))
10286 WTSF(KFL)=XFB(KFL)/XFBO
10287 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
10288 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
10290 WTSUMC=MAX(0.0001D0,WTSUMC)
10291 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
10293 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
10296 IF(NTRY2.GT.500) THEN
10301 IF(MSTP(64).LE.0) THEN
10302 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
10303 ELSEIF(MSTP(64).EQ.1) THEN
10304 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
10306 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
10310 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
10311 & (PARU(101)*FWTE*WTSUME*TEMX)))
10314 C...Translate t into Q2 scale; choose between QCD and QED evolution.
10315 220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
10316 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
10317 C...Ensure that Q2 is above threshold for charm/bottom.
10319 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
10321 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
10322 Q2CB=1.1*PMAS(KFLCB,1)**2
10323 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
10324 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
10328 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
10329 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
10330 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
10331 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
10332 IF(Q2EB.GT.Q2MNE) MCE=2
10333 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
10335 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
10336 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
10339 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
10340 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
10343 C...Evolution possibly ended. Update t values.
10347 ELSEIF(MCE.EQ.1) THEN
10350 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
10354 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
10357 C...Select flavour for branching parton.
10358 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
10359 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
10362 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
10363 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
10364 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 230
10365 IF(KFLA.EQ.25) THEN
10370 C...Choose z value and corrective weight.
10373 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
10374 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
10375 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
10376 WTZ=0.5D0*(1D0+Z**2)
10378 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
10379 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
10380 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
10381 C...f -> f + gamma.
10382 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
10383 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
10384 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
10385 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
10387 Z=XB+XB*(XEE/(1D0-XEE))*
10388 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
10390 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
10391 C...f -> gamma + f.
10392 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
10393 Z=XB+XB*(XEE/(1D0-XEE))*
10394 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
10395 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
10397 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
10398 Z=XB+XB*(XEE/(1D0-XEE))*
10399 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
10400 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
10401 & (Q2B/(Q2B+PMAS(24,1)**2))
10403 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
10404 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
10405 WTZ=1D0-2D0*Z*(1D0-Z)
10407 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
10408 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
10409 WTZ=(1D0-Z*(1D0-Z))**2
10410 C...gamma -> f + fbar.
10411 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
10412 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
10413 WTZ=1D0-2D0*Z*(1D0-Z)
10415 IF(MCE.EQ.2) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
10417 C...Option with resummation of soft gluon emission as effective z shift.
10419 IF(MSTP(65).GE.1) THEN
10421 IF(KFLB.NE.21) RSOFT=8D0/3D0
10422 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
10423 IF(Z.LE.XB) GOTO 210
10426 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
10427 IF(MSTP(64).GE.2) THEN
10428 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 210
10429 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
10430 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210
10431 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
10435 C...Remove kinematically impossible branchings.
10436 UHAT=Q2B-DSH*(1D0-Z)/Z
10437 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 210
10439 C...Matrix-element corrections for s-channel resonance production.
10440 IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
10443 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
10444 RMEPS=(THAT**2+UHAT**2+2D0*DSH*SHAT)/(SHAT**2+DSH**2)
10446 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
10447 RMEPS=(SHAT**2+UHAT**2+2D0*DSH*THAT)/((SHAT-DSH)**2+DSH**2)
10452 C...Impose angular constraint in first branching from interference
10453 C...with final state partons.
10455 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
10456 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
10457 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
10458 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 210
10459 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
10460 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210
10464 C...Option with angular ordering requirement.
10465 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
10466 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
10467 IF(THE2T.GT.THE2(JT)) GOTO 210
10471 C...Weighting with new parton distributions.
10472 MINT(105)=MINT(102+JT)
10473 MINT(109)=MINT(106+JT)
10474 VINT(120)=VINT(2+JT)
10476 C.... Store side in MINT(124)
10480 C.... Store side in MINT(124)
10483 IF(MSTP(57).LE.1) THEN
10484 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
10486 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
10489 IF(XFBN.LT.1D-20) THEN
10490 IF(KFLA.EQ.KFLB) THEN
10496 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
10497 TEVCB=0.5D0*(TEVCBS+TEVCB)
10499 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
10500 TEVEB=0.5D0*(TEVEBS+TEVEB)
10512 C.... Store side in MINT(124)
10515 IF(MSTP(57).LE.1) THEN
10516 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
10518 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
10521 IF(XFAN.LT.1D-20) GOTO 190
10523 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190
10525 C...Define two hard scatterers in their CM-frame.
10526 250 IF(N.EQ.NS+2) THEN
10528 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
10531 IF(JR.EQ.1) IPO=IPUS1
10532 IF(JR.EQ.2) IPO=IPUS2
10542 P(I,3)=DPLCM*(-1)**(JR+1)
10543 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
10544 P(I,5)=-SQRT(DQ2(JR))
10547 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
10548 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
10551 C...Find maximum allowed mass of timelike parton.
10552 ELSEIF(N.GT.NS+2) THEN
10557 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
10558 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
10559 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
10560 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
10561 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
10563 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
10564 & 1D-10*DPD(1)) IKIN=1
10565 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
10566 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
10567 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
10568 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
10570 C...Generate timelike parton shower (if required).
10577 C...f -> f + g (gamma).
10578 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
10580 IF(IABS(KFLB).GE.11) K(IT,2)=22
10581 C...f -> g (gamma, W+-) + f.
10582 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
10584 IF(KFLS(JT+2).EQ.24) THEN
10586 ELSEIF(KFLS(JT+2).EQ.-24) THEN
10589 C...g (gamma) -> f + fbar, g + g.
10591 K(IT,2)=-KFLS(JT+2)
10592 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
10595 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
10596 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
10597 P(IT,5)=PYMASS(K(IT,2))
10598 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
10599 IF(MSTP(63).GE.1.AND.MCE.EQ.1) THEN
10602 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
10603 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
10604 IF(MSTP(63).EQ.1) THEN
10606 ELSEIF(MSTP(63).EQ.2) THEN
10607 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
10611 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
10612 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
10613 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
10614 PARJ(85)=SQRT(MAX(0D0,DPT2))*
10615 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
10617 CALL PYSHOW(IT,0,SQRT(Q2TIM))
10620 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
10623 C...Reconstruct kinematics of branching: timelike parton shower.
10625 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
10626 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
10627 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
10628 & (4D0*DSH*DPC(3)**2)
10629 IF(DPT2.LT.0D0) GOTO 100
10630 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
10631 & DSHR)/DPC(3)-DPC(3)
10633 P(IT,3)=DPB(1)*(-1)**(JT+1)
10634 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
10636 DPB(1)=SQRT(DPB(1)**2+DPT2)
10637 DPB(2)=SQRT(DPB(1)**2+DMS)
10639 DPB(4)=SQRT(DPB(3)**2+DMS)
10640 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
10642 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
10643 THE=PYANGL(P(IT,3),P(IT,1))
10644 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
10647 C...Reconstruct kinematics of branching: spacelike parton.
10656 P(N+1,3)=P(IT,3)+P(IS(JT),3)
10657 P(N+1,4)=P(IT,4)+P(IS(JT),4)
10658 P(N+1,5)=-SQRT(DQ2(3))
10660 C...Define colour flow of branching.
10665 C...f -> f + gamma (Z, W).
10666 IF(IABS(K(IT,2)).GE.22) THEN
10670 C...f -> gamma (Z, W) + f.
10671 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
10674 C...gamma -> q + qbar, g + g.
10675 ELSEIF(K(N+1,2).EQ.22) THEN
10681 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
10685 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
10688 C...qbar -> qbar + g.
10689 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
10692 C...qbar -> g + qbar.
10693 ELSEIF(K(N+1,2).LT.0) THEN
10696 C...g -> g + g; g -> q + qbar.
10697 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
10704 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
10705 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
10706 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
10707 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
10708 IF(ID1.NE.ID2) THEN
10709 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
10710 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
10714 C...Boost to new CM-frame.
10715 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
10716 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
10717 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
10718 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
10719 IR=N+(JT-1)*(IS(1)-N)
10720 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),PARU(2)*PYR(0),
10724 C...Update kinematics variables.
10727 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
10730 C...Save quantities; loop back.
10732 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
10733 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
10734 KFLS(JT+2)=KFLS(JT)
10739 XFS(JT,KFL)=XFA(KFL)
10748 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
10749 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
10750 IF(MSTU(21).GE.1) N=NS
10751 IF(MSTU(21).GE.1) RETURN
10753 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
10755 C...Boost hard scattering partons to frame of shower initiators.
10757 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
10763 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
10764 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
10765 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
10766 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
10769 C...Store user information. Reset Lambda value.
10770 K(IPU1,3)=MINT(83)+3
10771 K(IPU2,3)=MINT(83)+4
10773 MINT(12+JT)=KFLS(JT)
10774 VINT(140+JT)=XS(JT)
10775 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
10782 C*********************************************************************
10785 C...Allows resonances to decay (including parton showers for hadronic
10788 SUBROUTINE PYRESD(IRES)
10790 C...Double precision and integer declarations.
10791 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10792 IMPLICIT INTEGER(I-N)
10793 INTEGER PYK,PYCHGE,PYCOMP
10794 C...Parameter statement to help give large particle numbers.
10795 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
10797 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10798 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10799 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10800 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
10801 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10802 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10803 COMMON/PYINT1/MINT(400),VINT(400)
10804 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10805 COMMON/PYINT4/MWID(500),WIDS(500,5)
10806 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
10807 &/PYINT1/,/PYINT2/,/PYINT4/
10808 C...Local arrays and complex and character variables.
10809 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
10810 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
10811 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
10812 &PHI(3),WDTP(0:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5),
10814 COMPLEX FGK,HA(6,6),HC(6,6)
10816 CHARACTER CODE*9,MASS*9
10818 C...The F, Xi and Xj functions of Gunion and Kunszt
10819 C...(Phys. Rev. D33, 665, plus errata from the authors).
10820 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
10821 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
10822 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
10823 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
10824 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
10825 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
10826 &2D0*(D34/D56+D56/D34))
10828 C...Some general constants.
10831 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
10834 GMMZ=PMAS(23,1)*PMAS(23,2)
10836 GMMW=PMAS(24,1)*PMAS(24,2)
10839 C...Reset original resonance configuration.
10844 C...Define initial one, two or three objects for subprocess.
10847 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
10848 IREF(1,1)=MINT(84)+2+ISET(ISUB)
10849 IREF(1,4)=MINT(83)+6+ISET(ISUB)
10851 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
10852 IREF(1,1)=MINT(84)+1+ISET(ISUB)
10853 IREF(1,2)=MINT(84)+2+ISET(ISUB)
10854 IREF(1,4)=MINT(83)+5+ISET(ISUB)
10855 IREF(1,5)=MINT(83)+6+ISET(ISUB)
10857 ELSEIF(ISET(ISUB).EQ.5) THEN
10858 IREF(1,1)=MINT(84)+3
10859 IREF(1,2)=MINT(84)+4
10860 IREF(1,3)=MINT(84)+5
10861 IREF(1,4)=MINT(83)+7
10862 IREF(1,5)=MINT(83)+8
10863 IREF(1,6)=MINT(83)+9
10867 C...Define original resonance for odd cases.
10874 C...Check if initial resonance has been moved (in resonance + jet).
10876 IF(IREF(1,JT).GT.0) THEN
10877 IF(K(IREF(1,JT),1).GT.10) THEN
10878 KFA=IABS(K(IREF(1,JT),2))
10879 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
10880 DO 110 I=IREF(1,JT)+1,N
10881 IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2))
10885 KDA=MOD(K(IREF(1,JT),4),MSTU(4))
10886 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
10892 C.....Set decay vertex for initial resonances
10895 V(IREF(1,JT),I)=0D0
10899 C...Loop over decay history.
10905 IF(IREF(IP,2).EQ.0) JTMAX=1
10906 IF(IREF(IP,3).NE.0) JTMAX=3
10910 C...Start treatment of one, two or three resonances in parallel.
10921 C...Check whether particle can/is allowed to decay.
10922 IF(ID.EQ.0) GOTO 240
10925 IF(MWID(KCA).EQ.0) GOTO 240
10926 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 240
10927 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
10928 & KFA.EQ.18) IT4=IT4+1
10929 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
10930 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
10932 C...Choose lifetime and determine decay vertex.
10933 IF(K(ID,1).EQ.5) THEN
10935 ELSEIF(K(ID,1).NE.4) THEN
10936 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
10939 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
10942 C...Determine whether decay allowed or not.
10944 IF(MSTJ(22).EQ.2) THEN
10945 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
10946 ELSEIF(MSTJ(22).EQ.3) THEN
10947 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
10948 ELSEIF(MSTJ(22).EQ.4) THEN
10949 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
10950 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
10952 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
10957 C...Info for selection of decay channel: sign, pairings.
10958 IF(KCHG(KCA,3).EQ.0) THEN
10961 IPM=(5-ISIGN(1,K(ID,2)))/2
10964 IF(JTMAX.EQ.2) THEN
10965 KFB=IABS(K(IREF(IP,3-JT),2))
10966 ELSEIF(JTMAX.EQ.3) THEN
10968 KFB=IABS(K(IREF(IP,JT2),2))
10969 IF(KFB.NE.KFA) THEN
10970 JT2=JT+2-3*((JT+1)/3)
10971 KFB=IABS(K(IREF(IP,JT2),2))
10975 C...Select decay channel.
10976 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
10977 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
10978 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
10979 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
10980 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
10981 IF(WDTE0S.LE.0D0) GOTO 240
10985 IDC=IDL+MDCY(KCA,2)-1
10986 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
10987 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
10988 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
10990 C...Read out flavours and colour charges of decay channel chosen.
10991 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
10992 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
10993 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
10994 KFC1A=PYCOMP(IABS(KFL1(JT)))
10995 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
10996 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
10997 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
10998 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
10999 KFC2A=PYCOMP(IABS(KFL2(JT)))
11000 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
11001 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
11002 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
11003 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
11004 IF(KFL3(JT).NE.0) THEN
11005 KFC3A=PYCOMP(IABS(KFL3(JT)))
11006 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
11007 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
11008 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
11011 C...Set/save further info on channel.
11013 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
11015 HGZ(JT,1)=VINT(111)
11016 HGZ(JT,2)=VINT(112)
11017 HGZ(JT,3)=VINT(114)
11020 C...Select masses; to begin with assume resonances narrow.
11025 KFLW=IABS(KFL1(JT))
11027 ELSEIF(I.EQ.2) THEN
11028 KFLW=IABS(KFL2(JT))
11030 ELSEIF(I.EQ.3) THEN
11031 IF(KFL3(JT).EQ.0) GOTO 200
11032 KFLW=IABS(KFL3(JT))
11035 P(N+I,5)=PMAS(KCW,1)
11037 C...This prevents SUSY/t particles from becoming too light.
11038 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
11039 PMMN(I)=PMAS(KCW,1)
11040 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
11041 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
11042 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
11043 & PMAS(PYCOMP(KFDP(IDC,2)),1)
11044 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
11045 & PMAS(PYCOMP(KFDP(IDC,3)),1)
11046 PMMN(I)=MIN(PMMN(I),PMSUM)
11050 ELSEIF(KFLW.EQ.6) THEN
11051 PMMN(I)=PMAS(24,1)+PMAS(5,1)
11055 C...Check which two out of three are widest.
11058 PWID1=PMAS(KFC1A,2)
11059 PWID2=PMAS(KFC2A,2)
11060 KFLW1=IABS(KFL1(JT))
11061 KFLW2=IABS(KFL2(JT))
11062 IF(KFL3(JT).NE.0) THEN
11063 PWID3=PMAS(KFC3A,2)
11064 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
11067 KFLW1=IABS(KFL3(JT))
11068 ELSEIF(PWID3.GT.PWID2) THEN
11071 KFLW2=IABS(KFL3(JT))
11075 C...If all narrow then only check that masses consistent.
11076 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
11077 & PWID2.LT.PARP(41))) THEN
11079 C....Handle near degeneracy cases.
11080 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
11081 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
11082 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
11083 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
11087 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
11088 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
11091 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
11092 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
11097 C...For three wide resonances select narrower of three
11098 C...according to BW decoupled from rest.
11101 IF(KFL3(JT).NE.0) THEN
11102 IWID3=6-IWID1-IWID2
11103 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
11107 P(N+IWID3,5)=PYMASS(KFLW3)
11108 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
11109 PMTOT=PMTOT-P(N+IWID3,5)
11111 C...Select other two correlated within remaining phase space.
11115 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
11116 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
11117 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
11122 CKIN(49)=PMMN(IWID1)
11123 CKIN(50)=PMMN(IWID2)
11124 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
11129 IF(MINT(51).EQ.1) RETURN
11132 C...Begin fill decay products, with colour flow for coloured objects.
11138 C...1) Three-body decays of SUSY particles (plus special case top).
11139 IF(KFL3(JT).NE.0) THEN
11158 C...Set colour flow for t -> W + b + Z.
11162 IF(KCQM(JT).EQ.-1) ISID=5
11164 K(ID,ISID)=K(ID,ISID)+IDAU
11165 K(IDAU,ISID)=MSTU(5)*ID
11167 C...Set colour flow in three-body decays - programmed as special cases.
11168 ELSEIF(KFC2A.LE.6) THEN
11172 IF(KFL2(JT).LT.0) ISID=5
11173 K(N+2,ISID)=MSTU(5)*(N+3)
11174 K(N+3,9-ISID)=MSTU(5)*(N+2)
11176 IF(KFL1(JT).EQ.KSUSY1+21) THEN
11181 IF(KFL2(JT).LT.0) ISID=5
11182 K(N+1,ISID)=MSTU(5)*(N+2)
11183 K(N+1,9-ISID)=MSTU(5)*(N+3)
11184 K(N+2,ISID)=MSTU(5)*(N+1)
11185 K(N+3,9-ISID)=MSTU(5)*(N+1)
11187 IF(KFA.EQ.KSUSY1+21) THEN
11191 IF(KFL2(JT).LT.0) ISID=5
11192 K(ID,ISID)=K(ID,ISID)+(N+2)
11193 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
11194 K(N+2,ISID)=MSTU(5)*ID
11195 K(N+3,9-ISID)=MSTU(5)*ID
11200 C...2) Everything else two-body decay.
11202 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
11203 C...First set colour flow as if mother colour singlet.
11204 IF(KCQ1(JT).NE.0) THEN
11206 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
11207 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
11209 IF(KCQ2(JT).NE.0) THEN
11211 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
11212 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
11214 C...Then redirect colour flow if mother (anti)triplet.
11215 IF(KCQM(JT).EQ.0) THEN
11216 ELSEIF(KCQM(JT).NE.2) THEN
11218 IF(KCQM(JT).EQ.-1) ISID=5
11220 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
11221 K(ID,ISID)=K(ID,ISID)+IDAU
11222 K(IDAU,ISID)=MSTU(5)*ID
11223 C...Then redirect colour flow if mother octet.
11224 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
11226 IF(KCQ1(JT).EQ.0) IDAU=N
11227 K(ID,4)=K(ID,4)+IDAU
11228 K(ID,5)=K(ID,5)+IDAU
11229 K(IDAU,4)=MSTU(5)*ID
11230 K(IDAU,5)=MSTU(5)*ID
11233 IF(KCQ1(JT).EQ.-1) ISID=5
11234 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
11235 K(ID,ISID)=K(ID,ISID)+(N-1)
11236 K(ID,9-ISID)=K(ID,9-ISID)+N
11237 K(N-1,ISID)=MSTU(5)*ID
11238 K(N,9-ISID)=MSTU(5)*ID
11242 C...End loop over resonances for daughter flavour and mass selection.
11244 240 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
11246 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.KFL1(JT).EQ.0) THEN
11247 WRITE(CODE,'(I9)') K(ID,2)
11248 WRITE(MASS,'(F9.3)') P(ID,5)
11249 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
11250 & CODE//' with mass'//MASS)
11256 C...Check for allowed combinations. Skip if no decays.
11257 IF(JTMAX.EQ.1) THEN
11258 IF(KDCY(1).EQ.0) GOTO 620
11259 ELSEIF(JTMAX.EQ.2) THEN
11260 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 620
11261 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
11262 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
11263 ELSEIF(JTMAX.EQ.3) THEN
11264 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 620
11265 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
11266 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
11267 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
11268 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
11269 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
11270 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
11273 C...Special case: matrix element option for Z0 decay to quarks.
11274 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
11275 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
11277 C...Check consistency of MSTJ options set.
11278 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
11280 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
11283 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
11285 & '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
11289 C...Select alpha_strong behaviour.
11292 MSTU(111)=MSTJ(108)
11293 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
11295 PARU(112)=PARJ(121)
11296 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
11298 C...Find axial fraction in total cross section for scalar gluon model.
11300 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
11301 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
11302 POLL=1D0-PARJ(131)*PARJ(132)
11303 SFF=1D0/(16D0*XW*XW1)
11304 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
11305 & (PARJ(123)*PARJ(124))**2)
11306 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
11308 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
11309 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
11310 & (PARJ(132)-PARJ(131)))
11313 QF=KCHG(KFLC,1)/3D0
11315 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
11316 & 1D0-(2D0*PMQ/P(ID,5))**2))
11317 VF=SIGN(1D0,QF)-4D0*QF*XW
11318 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
11319 & VF**2*HF1W)+VQ**3*HF1W
11320 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
11323 C...Choice of jet configuration.
11324 CALL PYXJET(P(ID,5),NJET,CUT)
11328 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
11329 ELSEIF(NJET.EQ.3) THEN
11330 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
11335 C...Fill jet configuration; return if incorrect kinematics.
11337 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
11338 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
11339 ELSEIF(NJET.EQ.2) THEN
11340 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
11341 ELSEIF(NJET.EQ.3) THEN
11342 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
11343 ELSEIF(KFLN.EQ.21) THEN
11344 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
11347 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
11350 IF(MSTU(24).NE.0) THEN
11357 C...Angular orientation according to matrix element.
11358 IF(MSTJ(106).EQ.1) THEN
11359 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
11360 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
11362 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
11363 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
11366 C...Boost partons to Z0 rest frame.
11367 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
11368 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
11370 C...Mark decayed resonance and add documentation lines,
11372 IDOC=MINT(83)+MINT(4)
11374 I1=MINT(83)+MINT(4)+1
11376 IF(MSTP(128).GE.1) K(I,3)=ID
11377 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
11388 C...Generate parton shower.
11389 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
11391 C... End special case for Z0: skip ahead.
11397 C...Order incoming partons and outgoing resonances.
11398 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
11401 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
11402 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
11403 & ILIN(1)=2*MINT(84)+3-ILIN(1)
11404 ILIN(2)=2*MINT(84)+3-ILIN(1)
11406 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
11410 IF(K(IREF(IP,1),2).EQ.23) IORD=2
11411 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
11412 IAKIPD=IABS(K(IREF(IP,IORD),2))
11413 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
11414 IF(KDCY(IORD).EQ.0) IORD=3-IORD
11416 C...Order decay products of resonances.
11417 DO 280 JT=IORD,3-IORD,3-2*IORD
11418 IF(KDCY(JT).EQ.0) THEN
11419 ILIN(IMAX+1)=NSD(JT)
11421 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
11422 ILIN(IMAX+1)=N+2*JT-1
11423 ILIN(IMAX+2)=N+2*JT
11425 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
11426 K(N+2*JT,2)=K(NSD(JT)+2,2)
11428 ILIN(IMAX+1)=N+2*JT
11429 ILIN(IMAX+2)=N+2*JT-1
11431 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
11432 K(N+2*JT,2)=K(NSD(JT)+2,2)
11436 C...Find charge, isospin, left- and righthanded couplings.
11441 KFA=IABS(K(ILIN(I),2))
11442 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 300
11443 COUP(I,1)=KCHG(KFA,1)/3D0
11444 COUP(I,2)=(-1)**MOD(KFA,2)
11445 COUP(I,4)=-2D0*COUP(I,1)*XWV
11446 COUP(I,3)=COUP(I,2)+COUP(I,4)
11449 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
11450 IF(ISUB.EQ.22) THEN
11453 IF(I.EQ.5) I1=3-IORD
11456 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
11457 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
11458 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
11463 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
11464 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
11465 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
11466 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
11467 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
11471 C...Select angular orientation type - Z'/W' only.
11473 IF(ISUB.EQ.141) THEN
11474 IF(PYR(0).LT.PARU(130)) MZPWP=1
11476 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
11477 IAKIR=IABS(K(IREF(2,2),2))
11478 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
11479 IF(IAKIR.LE.20) MZPWP=2
11481 IF(IP.GE.3) MZPWP=2
11482 ELSEIF(ISUB.EQ.142) THEN
11483 IF(PYR(0).LT.PARU(136)) MZPWP=1
11485 IAKIR=IABS(K(IREF(2,2),2))
11486 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
11487 IF(IAKIR.LE.20) MZPWP=2
11489 IF(IP.GE.3) MZPWP=2
11492 C...Select random angles (begin of weighting procedure).
11493 340 DO 350 JT=1,JTMAX
11494 IF(KDCY(JT).EQ.0) GOTO 350
11495 IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
11496 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
11497 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
11500 CTHE(JT)=2D0*PYR(0)-1D0
11501 PHI(JT)=PARU(2)*PYR(0)
11505 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
11506 C...Construct massless four-vectors.
11515 IF(KDCY(JT).EQ.0) GOTO 380
11517 P(N+2*JT-1,3)=0.5D0*P(ID,5)
11518 P(N+2*JT-1,4)=0.5D0*P(ID,5)
11519 P(N+2*JT,3)=-0.5D0*P(ID,5)
11520 P(N+2*JT,4)=0.5D0*P(ID,5)
11521 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
11522 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
11525 C...Store incoming and outgoing momenta, with random rotation to
11526 C...avoid accidental zeroes in HA expressions.
11530 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
11531 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
11532 P(N+4+I,5)=P(ILIN(I),5)
11534 P(N+4+I,J)=P(ILIN(I),J)
11537 410 THERR=ACOS(2D0*PYR(0)-1D0)
11538 PHIRR=PARU(2)*PYR(0)
11539 CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
11541 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
11549 C...Calculate internal products.
11550 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
11551 & ISUB.EQ.142) THEN
11552 DO 450 I1=IMIN,IMAX-1
11553 DO 440 I2=I1+1,IMAX
11554 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
11555 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
11556 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
11557 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
11558 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
11559 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
11560 HC(I1,I2)=CONJG(HA(I1,I2))
11561 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
11562 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
11563 HA(I2,I1)=-HA(I1,I2)
11564 HC(I2,I1)=-HC(I1,I2)
11569 C...Calculate four-products.
11576 DO 490 I1=IMIN,IMAX-1
11577 DO 480 I2=I1+1,IMAX
11578 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
11579 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
11580 PKK(I2,I1)=PKK(I1,I2)
11586 KFAGM=IABS(IREF(IP,7))
11587 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
11588 C...Isotropic decay selected by user.
11592 ELSEIF(JTMAX.EQ.3) THEN
11593 C...Isotropic decay when three mother particles.
11597 ELSEIF(IT4.GE.1) THEN
11598 C... Isotropic decay t -> b + W etc for 4th generation q and l.
11602 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
11603 & IREF(IP,7).EQ.36) THEN
11604 C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
11605 IF(IP.EQ.1) WTMAX=SH**2
11606 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
11607 KFA=IABS(K(IREF(IP,1),2))
11609 KFLF1A=IABS(KFL1(1))
11610 EF1=KCHG(KFLF1A,1)/3D0
11611 AF1=SIGN(1D0,EF1+0.1D0)
11612 VF1=AF1-4D0*EF1*XWV
11613 KFLF2A=IABS(KFL1(2))
11614 EF2=KCHG(KFLF2A,1)/3D0
11615 AF2=SIGN(1D0,EF2+0.1D0)
11616 VF2=AF2-4D0*EF2*XWV
11617 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
11618 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
11619 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
11620 ELSEIF(KFA.EQ.24) THEN
11621 WT=16D0*PKK(3,5)*PKK(4,6)
11626 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
11627 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
11629 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
11631 IF(MOD(KFAGM,2).EQ.0) THEN
11639 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
11640 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
11641 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
11642 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
11644 ELSEIF(ISUB.EQ.1) THEN
11645 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
11646 EI=KCHG(IABS(MINT(15)),1)/3D0
11647 AI=SIGN(1D0,EI+0.1D0)
11649 EF=KCHG(IABS(KFL1(1)),1)/3D0
11650 AF=SIGN(1D0,EF+0.1D0)
11652 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
11653 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
11654 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
11655 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
11656 & (VI**2+AI**2)*VINT(114)*VF**2)
11657 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
11658 & 4D0*VI*AI*VINT(114)*VF*AF)
11659 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
11660 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
11661 WTMAX=2D0*(WT1+ABS(WT3))
11663 ELSEIF(ISUB.EQ.2) THEN
11664 C...Angular weight for W+/- -> 2 quarks/leptons.
11665 WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2
11668 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
11669 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
11670 C...-> gluon/gamma + 2 quarks/leptons.
11671 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11672 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
11673 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
11674 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11675 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
11676 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
11677 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11678 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
11679 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
11680 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11681 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
11682 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
11683 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
11684 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
11685 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
11686 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
11688 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
11689 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
11690 C...-> gluon/gamma + 2 quarks/leptons.
11691 WT=PKK(1,3)**2+PKK(2,4)**2
11692 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
11694 ELSEIF(ISUB.EQ.22) THEN
11695 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
11696 S34=P(IREF(IP,IORD),5)**2
11697 S56=P(IREF(IP,3-IORD),5)**2
11698 TI=PKK(1,3)+PKK(1,4)+S34
11699 UI=PKK(1,5)+PKK(1,6)+S56
11702 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
11703 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
11704 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
11705 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
11706 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
11707 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
11708 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
11709 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
11711 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
11712 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
11713 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
11714 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
11715 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
11716 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
11717 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
11720 ELSEIF(ISUB.EQ.23) THEN
11721 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
11722 D34=P(IREF(IP,IORD),5)**2
11723 D56=P(IREF(IP,3-IORD),5)**2
11724 DT=PKK(1,3)+PKK(1,4)+D34
11725 DU=PKK(1,5)+PKK(1,6)+D56
11726 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
11727 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
11728 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
11729 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
11730 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
11731 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
11732 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
11733 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
11734 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
11735 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
11737 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
11738 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
11739 C...(or H0, or A0).
11740 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
11741 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
11742 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
11743 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
11744 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
11746 ELSEIF(ISUB.EQ.25) THEN
11747 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
11748 D34=P(IREF(IP,IORD),5)**2
11749 D56=P(IREF(IP,3-IORD),5)**2
11750 DT=PKK(1,3)+PKK(1,4)+D34
11751 DU=PKK(1,5)+PKK(1,6)+D56
11752 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
11753 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
11754 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
11755 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
11756 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
11757 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
11758 & REAL(CBWW)*FGK(1,2,5,6,3,4))
11759 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
11760 WT=FGK135**2+(CCWW*FGK253)**2
11761 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
11762 & CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
11764 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
11765 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
11766 C...(or H0, or A0).
11767 WT=PKK(1,3)*PKK(2,4)
11768 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
11770 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
11771 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
11772 C...-> f + 2 quarks/leptons.
11773 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11774 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
11775 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
11776 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11777 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
11778 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
11779 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11780 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
11781 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
11782 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11783 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
11784 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
11785 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
11786 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
11787 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
11788 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
11789 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
11790 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
11792 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
11793 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
11794 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
11795 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
11796 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
11798 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
11800 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
11801 WT=16D0*PKK(3,5)*PKK(4,6)
11804 ELSEIF(ISUB.EQ.110) THEN
11805 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
11809 ELSEIF(ISUB.EQ.141) THEN
11810 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
11811 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
11812 C...Couplings of incoming flavour.
11813 KFAI=IABS(MINT(15))
11814 EI=KCHG(KFAI,1)/3D0
11815 AI=SIGN(1D0,EI+0.1D0)
11818 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
11819 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
11820 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
11821 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
11822 VPI=PARU(119+2*KFAIC)
11823 API=PARU(120+2*KFAIC)
11824 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
11825 VPI=PARJ(178+2*KFAIC)
11826 API=PARJ(179+2*KFAIC)
11828 VPI=PARJ(186+2*KFAIC)
11829 API=PARJ(187+2*KFAIC)
11831 C...Couplings of final flavour.
11833 EF=KCHG(KFAF,1)/3D0
11834 AF=SIGN(1D0,EF+0.1D0)
11837 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
11838 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
11839 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
11840 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
11841 VPF=PARU(119+2*KFAFC)
11842 APF=PARU(120+2*KFAFC)
11843 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
11844 VPF=PARJ(178+2*KFAFC)
11845 APF=PARJ(179+2*KFAFC)
11847 VPF=PARJ(186+2*KFAFC)
11848 APF=PARJ(187+2*KFAFC)
11850 C...Asymmetry and weight.
11851 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
11852 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
11853 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
11854 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
11855 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
11856 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
11857 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
11858 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
11859 WTMAX=2D0+ABS(ASYM)
11860 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
11861 C...Angular weight for f + fbar -> Z' -> W+ + W-.
11862 RM1=P(NSD(1)+1,5)**2/SH
11863 RM2=P(NSD(1)+2,5)**2/SH
11864 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
11865 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
11866 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
11868 WT=CFLAT+CCOS2*CTHE(1)**2
11869 WTMAX=CFLAT+MAX(0D0,CCOS2)
11870 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
11871 & IABS(KFL1(1)).EQ.37)) THEN
11872 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
11875 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
11876 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
11877 RM1=P(NSD(1)+1,5)**2/SH
11878 RM2=P(NSD(1)+2,5)**2/SH
11879 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
11880 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
11881 WTMAX=1D0+FLAM2/(8D0*RM1)
11882 ELSEIF(MZPWP.EQ.0) THEN
11883 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
11884 C...(W:s like if intermediate Z).
11885 D34=P(IREF(IP,IORD),5)**2
11886 D56=P(IREF(IP,3-IORD),5)**2
11887 DT=PKK(1,3)+PKK(1,4)+D34
11888 DU=PKK(1,5)+PKK(1,6)+D56
11889 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
11890 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
11891 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
11892 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
11893 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
11894 ELSEIF(MZPWP.EQ.1) THEN
11895 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
11896 C...(W:s approximately longitudinal, like if intermediate H).
11897 WT=16D0*PKK(3,5)*PKK(4,6)
11900 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
11901 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
11906 ELSEIF(ISUB.EQ.142) THEN
11907 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
11908 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
11909 KFAI=IABS(MINT(15))
11911 IF(KFAI.GT.10) KFAIC=2
11912 VI=PARU(129+2*KFAIC)
11913 AI=PARU(130+2*KFAIC)
11916 IF(KFAF.GT.10) KFAFC=2
11917 VF=PARU(129+2*KFAFC)
11918 AF=PARU(130+2*KFAFC)
11919 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
11920 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
11921 WTMAX=2D0+ABS(ASYM)
11922 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
11923 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
11924 RM1=P(NSD(1)+1,5)**2/SH
11925 RM2=P(NSD(1)+2,5)**2/SH
11926 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
11927 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
11928 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
11930 WT=CFLAT+CCOS2*CTHE(1)**2
11931 WTMAX=CFLAT+MAX(0D0,CCOS2)
11932 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
11933 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
11934 RM1=P(NSD(1)+1,5)**2/SH
11935 RM2=P(NSD(1)+2,5)**2/SH
11936 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
11937 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
11938 WTMAX=1D0+FLAM2/(8D0*RM1)
11939 ELSEIF(MZPWP.EQ.0) THEN
11940 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
11941 C...(W/Z like if intermediate W).
11942 D34=P(IREF(IP,IORD),5)**2
11943 D56=P(IREF(IP,3-IORD),5)**2
11944 DT=PKK(1,3)+PKK(1,4)+D34
11945 DU=PKK(1,5)+PKK(1,6)+D56
11946 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
11947 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
11948 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
11949 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
11950 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
11951 ELSEIF(MZPWP.EQ.1) THEN
11952 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
11953 C...(W/Z approximately longitudinal, like if intermediate H).
11954 WT=16D0*PKK(3,5)*PKK(4,6)
11957 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
11958 C...t + bbar -> t + W + bbar.
11963 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
11965 C...Isotropic decay of leptoquarks (assumed spin 0).
11969 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
11970 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
11972 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
11973 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
11974 WT=1D0+SIDE*CTHE(1)
11976 ELSEIF(IP.EQ.1) THEN
11977 RM1=P(NSD(1)+1,5)**2/SH
11978 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
11979 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
11981 C...W/Z decay assumed isotropic, since not known.
11986 ELSEIF(ISUB.EQ.149) THEN
11987 C...Isotropic decay of techni-eta.
11991 ELSEIF(ISUB.EQ.191) THEN
11992 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
11993 C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
11994 C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
11997 ELSEIF(IP.EQ.1) THEN
11998 C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
11999 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
12000 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
12001 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
12002 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
12003 KFAI=IABS(MINT(15))
12004 EI=KCHG(KFAI,1)/3D0
12005 AI=SIGN(1D0,EI+0.1D0)
12009 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
12010 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
12012 EF=KCHG(KFAF,1)/3D0
12013 AF=SIGN(1D0,EF+0.1D0)
12017 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
12018 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
12019 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
12020 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
12021 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
12022 WTMAX=4D0*MAX(ASAME,AFLIP)
12024 C...Isotropic decay of W/pi_tech produced in rho_tech decay.
12029 ELSEIF(ISUB.EQ.192) THEN
12030 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
12031 C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
12032 C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
12035 ELSEIF(IP.EQ.1) THEN
12036 C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
12037 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
12041 C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
12046 ELSEIF(ISUB.EQ.193) THEN
12047 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
12048 C...Angular weight for f + fbar -> omega_tech0 ->
12049 C...gamma pi_tech0 or Z0 pi_tech0.
12052 ELSEIF(IP.EQ.1) THEN
12053 C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
12054 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
12055 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
12056 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
12057 KFAI=IABS(MINT(15))
12058 EI=KCHG(KFAI,1)/3D0
12059 AI=SIGN(1D0,EI+0.1D0)
12063 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
12064 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
12066 EF=KCHG(KFAF,1)/3D0
12067 AF=SIGN(1D0,EF+0.1D0)
12071 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
12072 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
12073 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
12074 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
12075 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
12076 WTMAX=4D0*MAX(BSAME,BFLIP)
12078 C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
12083 C...Obtain correct angular distribution by rejection techniques.
12088 IF(WT.LT.PYR(0)*WTMAX) GOTO 340
12090 C...Construct massive four-vectors using angles chosen.
12091 500 DO 600 JT=1,JTMAX
12092 IF(KDCY(JT).EQ.0) GOTO 600
12097 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
12099 IF(KFL3(JT).EQ.0) THEN
12100 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
12101 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
12104 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
12105 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
12110 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12112 C...Fill in position of decay vertex.
12113 DO 540 I=NSD(JT)+1,N0
12121 C...Mark decayed resonances; trace history.
12125 IF(KCQM(JT).NE.0) THEN
12126 C...Do not kill colour flow through coloured resonance!
12130 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
12133 C...Add documentation lines.
12135 IDOC=MINT(83)+MINT(4)
12138 IF(KFL3(JT).NE.0) IHI=IHI+1
12139 DO 560 I=NSD(JT)+1,IHI
12141 I1=MINT(83)+MINT(4)+1
12143 IF(MSTP(128).GE.1) K(I,3)=ID
12144 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
12148 K(I1,3)=IREF(IP,JT+3)
12157 IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
12160 C...Do showering if any of the two/three products can shower.
12162 IF(MSTP(71).GE.1) THEN
12164 KFL1A=IABS(KFL1(JT))
12165 IF(KFL1A.LE.22) ISHOW1=1
12167 KFL2A=IABS(KFL2(JT))
12168 IF(KFL2A.LE.22) ISHOW2=1
12170 IF(KFL3(JT).NE.0) THEN
12171 KFL3A=IABS(KFL3(JT))
12172 IF(KFL3A.LE.22) ISHOW3=1
12174 IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN
12175 ELSEIF(KFL3(JT).EQ.0) THEN
12176 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
12180 IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN
12182 ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN
12185 PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2-
12186 & (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2-
12187 & (P(NSD1,3)+P(NSD2,3))**2))
12188 CALL PYSHOW(NSD1,NSD2,PMSHOW)
12192 IF(JT.EQ.1) NAFT1=N
12194 C...Check if decay products moved by shower.
12198 IF(NSHAFT.GT.NSHBEF) THEN
12199 IF(K(NSD1,1).GT.10) THEN
12200 DO 570 I=NSHBEF+1,NSHAFT
12201 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
12204 IF(K(NSD2,1).GT.10) THEN
12205 DO 580 I=NSHBEF+1,NSHAFT
12206 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
12207 & I.NE.NSD1) NSD2=I
12210 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
12211 DO 590 I=NSHBEF+1,NSHAFT
12212 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
12213 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
12218 C...Store decay products for further treatment.
12223 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
12227 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
12228 IREF(NP,7)=K(IREF(IP,JT),2)
12229 IREF(NP,8)=IREF(IP,JT)
12232 C...Fill information for 2 -> 1 -> 2.
12233 610 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
12234 MINT(7)=MINT(83)+6+2*ISET(ISUB)
12235 MINT(8)=MINT(83)+7+2*ISET(ISUB)
12241 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
12242 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
12243 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
12244 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
12245 VINT(47)=SQRT(VINT(48))
12248 C...Possibility of colour rearrangement in W+W- events.
12249 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
12250 IAKF1=IABS(KFL1(1))
12251 IAKF2=IABS(KFL1(2))
12252 IAKF3=IABS(KFL2(1))
12253 IAKF4=IABS(KFL2(2))
12254 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
12255 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
12256 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
12259 C...Loop back if needed.
12260 620 IF(IP.LT.NP) GOTO 150
12265 C*********************************************************************
12268 C...Initializes treatment of multiple interactions, selects kinematics
12269 C...of hardest interaction if low-pT physics included in run, and
12270 C...generates all non-hardest interactions.
12272 SUBROUTINE PYMULT(MMUL)
12274 C...Double precision and integer declarations.
12275 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12276 IMPLICIT INTEGER(I-N)
12277 INTEGER PYK,PYCHGE,PYCOMP
12279 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12280 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12281 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12282 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12283 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12284 COMMON/PYINT1/MINT(400),VINT(400)
12285 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12286 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12287 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
12288 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
12289 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
12290 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
12291 C...Local arrays and saved variables.
12292 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
12293 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
12295 C...Initialization of multiple interaction treatment.
12297 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
12305 C...Loop over phase space points: xT2 choice in 20 bins.
12308 NMUL(IXT2)=MSTP(83)
12310 DO 110 ITRY=1,MSTP(83)
12311 RSCA=0.05D0*((21-IXT2)-PYR(0))
12312 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
12313 XT2=MAX(0.01D0*VINT(149),XT2)
12316 C...Choose tau and y*. Calculate cos(theta-hat).
12317 IF(PYR(0).LE.COEF(ISUB,1)) THEN
12318 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
12319 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
12321 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
12327 IF(RYST.GT.COEF(ISUB,8)) MYST=2
12328 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
12329 CALL PYKMAP(2,MYST,PYR(0))
12330 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
12332 C...Calculate differential cross-section.
12333 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
12334 CALL PYSIGH(NCHN,SIGS)
12335 SIGM(IXT2)=SIGM(IXT2)+SIGS
12337 SIGSUM=SIGSUM+SIGM(IXT2)
12339 SIGSUM=SIGSUM/(20D0*MSTP(83))
12341 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
12342 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
12343 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
12344 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
12345 PARP(82)=0.9D0*PARP(82)
12346 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
12350 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
12351 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
12353 C...Start iteration to find k factor.
12354 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
12362 130 IF(IIT.EQ.0) THEN
12364 ELSEIF(IIT.EQ.1) THEN
12367 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
12370 C...Evaluate overlap integrals.
12371 IF(MSTP(82).EQ.2) THEN
12372 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
12375 IF(MSTP(82).EQ.3) DELTAB=0.02D0
12376 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
12381 IF(MSTP(82).EQ.3) THEN
12382 OV=EXP(-B**2)/PARU(2)
12385 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
12386 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
12387 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
12388 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
12390 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
12391 SP=SP+PARU(2)*B*DELTAB*PACC
12392 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
12393 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
12395 YK=PARU(1)*XK*SO/SP
12397 C...Continue iteration until convergence.
12407 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
12409 C...Store some results for subsequent use.
12414 C...Initialize iteration in xT2 for hardest interaction.
12415 ELSEIF(MMUL.EQ.2) THEN
12416 IF(MSTP(82).LE.0) THEN
12417 ELSEIF(MSTP(82).EQ.1) THEN
12419 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
12420 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
12421 & VINT(317)/(VINT(318)*VINT(320))
12422 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
12423 ELSEIF(MSTP(82).EQ.2) THEN
12425 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
12426 & VINT(149)*(1D0+VINT(149))
12428 XC2=4D0*CKIN(3)**2/VINT(2)
12429 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
12432 ELSEIF(MMUL.EQ.3) THEN
12433 C...Low-pT or multiple interactions (first semihard interaction):
12434 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
12435 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
12437 IF(MSTP(82).LE.0) THEN
12439 ELSEIF(MSTP(82).EQ.1) THEN
12440 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
12441 ELSEIF(MSTP(82).EQ.2) THEN
12442 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
12443 & VINT(149)))).GT.PYR(0)) XT2=1D0
12444 IF(XT2.GE.1D0) THEN
12445 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
12446 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
12449 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
12450 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
12453 XT2=MAX(0.01D0*VINT(149),XT2)
12455 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
12456 & PYR(0)*(1D0-XC2))-VINT(149)
12457 XT2=MAX(0.01D0*VINT(149),XT2)
12461 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
12462 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
12463 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
12464 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
12467 VINT(21)=0.01D0*VINT(149)
12470 VINT(25)=0.01D0*VINT(149)
12473 C...Multiple interactions (first semihard interaction).
12474 C...Choose tau and y*. Calculate cos(theta-hat).
12475 IF(PYR(0).LE.COEF(ISUB,1)) THEN
12476 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
12477 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
12479 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
12485 IF(RYST.GT.COEF(ISUB,8)) MYST=2
12486 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
12487 CALL PYKMAP(2,MYST,PYR(0))
12488 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
12490 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
12492 C...Store results of cross-section calculation.
12493 ELSEIF(MMUL.EQ.4) THEN
12496 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
12497 IF(ISET(ISUB).EQ.2)
12498 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
12499 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
12500 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
12501 & (XTS+VINT(149))))
12502 IRBIN=INT(1D0+20D0*RBIN)
12503 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
12504 NMUL(IRBIN)=NMUL(IRBIN)+1
12505 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
12508 C...Choose impact parameter.
12509 ELSEIF(MMUL.EQ.5) THEN
12511 145 IF(MSTP(82).EQ.3) THEN
12512 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
12516 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
12518 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
12519 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
12521 B2=-CQ2*LOG(PYR(0))
12523 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
12524 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
12525 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
12528 C...Multiple interactions (variable impact parameter) : reject with
12529 C...probability exp(-overlap*cross-section above pT/normalization).
12530 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
12531 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
12532 DO 150 IBIN=IRBIN+1,20
12533 RNCOR=RNCOR+NMUL(IBIN)
12534 SIGCOR=SIGCOR+SIGM(IBIN)
12536 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
12537 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
12538 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
12539 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
12540 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
12541 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
12542 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
12543 IF(VINT(150).LT.PYR(0)) GOTO 145
12547 C...Generate additional multiple semihard interactions.
12548 ELSEIF(MMUL.EQ.6) THEN
12558 C...Reconstruct strings in hard scattering.
12560 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
12561 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
12563 DO 180 I=MINT(84)+1,NMAX
12564 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
12565 IF(KCS.EQ.0) GOTO 180
12567 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170
12568 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170
12570 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
12572 IST=MOD(K(I,J+1),MSTU(5))
12574 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 170
12575 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170
12577 IF(J.EQ.1.OR.J.EQ.4) THEN
12587 C...Set up starting values for iteration in xT2.
12588 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
12589 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
12590 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
12591 & ISUBSV.NE.96)) THEN
12592 XT2=(1D0-VINT(141))*(1D0-VINT(142))
12595 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
12596 IF(ISET(ISUBSV).EQ.2)
12597 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
12598 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
12600 IF(MSTP(82).LE.1) THEN
12601 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
12602 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
12603 & VINT(317)/(VINT(318)*VINT(320))
12604 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
12606 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
12607 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
12611 VINT(143)=1D0-VINT(141)
12612 VINT(144)=1D0-VINT(142)
12614 C...Iterate downwards in xT2.
12615 190 IF(MSTP(82).LE.1) THEN
12616 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
12617 IF(XT2.LT.VINT(149)) GOTO 240
12619 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240
12620 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
12621 & LOG(PYR(0)))-VINT(149)
12622 IF(XT2.LE.0D0) GOTO 240
12623 XT2=MAX(0.01D0*VINT(149),XT2)
12627 C...Choose tau and y*. Calculate cos(theta-hat).
12628 IF(PYR(0).LE.COEF(ISUB,1)) THEN
12629 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
12630 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
12632 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
12638 IF(RYST.GT.COEF(ISUB,8)) MYST=2
12639 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
12640 CALL PYKMAP(2,MYST,PYR(0))
12641 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
12643 C...Check that x not used up. Accept or reject kinematical variables.
12644 X1M=SQRT(TAU)*EXP(VINT(22))
12645 X2M=SQRT(TAU)*EXP(-VINT(22))
12646 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 190
12647 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
12648 CALL PYSIGH(NCHN,SIGS)
12649 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
12650 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190
12652 C...Reset K, P and V vectors. Select some variables.
12661 PT=0.5D0*VINT(1)*SQRT(XT2)
12665 C...Add first parton to event record.
12668 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
12669 & 1+INT((2D0+PARJ(2))*PYR(0))
12670 P(N+1,1)=PT*COS(PHI)
12671 P(N+1,2)=PT*SIN(PHI)
12672 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
12673 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
12676 C...Add second parton to event record.
12679 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
12682 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
12683 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
12686 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
12687 C....Choose relevant string pieces to place gluons on.
12693 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
12694 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
12695 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
12696 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
12697 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
12705 C....Colour flow adjustments, new string pieces.
12706 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
12707 & MOD(K(IST1,4),MSTU(5))
12708 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
12709 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
12710 K(I,5)=MSTU(5)*IST1
12711 K(I,4)=MSTU(5)*IST2
12712 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
12713 & MOD(K(IST2,5),MSTU(5))
12714 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
12715 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
12718 KSTR(NSTR+1,2)=IST2
12722 C...String drawing and colour flow for gluon loop.
12723 ELSEIF(K(N+1,2).EQ.21) THEN
12724 K(N+1,4)=MSTU(5)*(N+2)
12725 K(N+1,5)=MSTU(5)*(N+2)
12726 K(N+2,4)=MSTU(5)*(N+1)
12727 K(N+2,5)=MSTU(5)*(N+1)
12734 C...String drawing and colour flow for qqbar pair.
12736 K(N+1,4)=MSTU(5)*(N+2)
12737 K(N+2,5)=MSTU(5)*(N+1)
12743 C...Update remaining energy; iterate.
12745 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
12746 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
12747 IF(MSTU(21).GE.1) RETURN
12749 MINT(31)=MINT(31)+1
12750 VINT(151)=VINT(151)+VINT(41)
12751 VINT(152)=VINT(152)+VINT(42)
12752 VINT(143)=VINT(143)-VINT(41)
12753 VINT(144)=VINT(144)-VINT(42)
12754 IF(MINT(31).LT.240) GOTO 190
12762 C...Format statements for printout.
12763 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
12764 &'actions for MSTP(82) =',I2,' ******')
12765 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
12766 &D9.2,' mb: rejected')
12767 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
12768 &D9.2,' mb: accepted')
12773 C*********************************************************************
12776 C...Adds on target remnants (one or two from each side) and
12777 C...includes primordial kT for hadron beams.
12779 SUBROUTINE PYREMN(IPU1,IPU2)
12781 C...Double precision and integer declarations.
12782 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12783 IMPLICIT INTEGER(I-N)
12784 INTEGER PYK,PYCHGE,PYCOMP
12786 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12787 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12788 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12789 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12790 COMMON/PYINT1/MINT(400),VINT(400)
12791 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
12793 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
12794 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
12796 C...Find event type and remaining energy.
12799 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
12800 VINT(143)=1D0-VINT(141)
12801 VINT(144)=1D0-VINT(142)
12804 C...Define initial partons.
12809 IF(JT.EQ.1) IPU=IPU1
12810 IF(JT.EQ.2) IPU=IPU2
12817 IF(MINT(47).EQ.1) THEN
12821 ELSEIF(ISUB.EQ.95) THEN
12826 C...No primordial kT, or chosen according to truncated Gaussian or
12827 C...exponential, or (for photon) predetermined or power law.
12828 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
12829 IF(MSTP(91).LE.0) THEN
12831 ELSEIF(MSTP(91).EQ.1) THEN
12832 PT=PARP(91)*SQRT(-LOG(PYR(0)))
12836 PT=-PARP(92)*LOG(RPT1*RPT2)
12838 IF(PT.GT.PARP(93)) GOTO 120
12839 ELSEIF(MINT(106+JT).EQ.3) THEN
12840 PTA=SQRT(VINT(282+JT))
12842 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
12843 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
12844 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
12847 PTB=-PARP(99)*LOG(RPT1*RPT2)
12849 IF(PTB.GT.PARP(100)) GOTO 120
12850 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
12851 PT=PT*0.8D0**MINT(57)
12852 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
12853 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
12854 IF(MSTP(93).LE.0) THEN
12856 ELSEIF(MSTP(93).EQ.1) THEN
12857 PT=PARP(99)*SQRT(-LOG(PYR(0)))
12858 ELSEIF(MSTP(93).EQ.2) THEN
12861 PT=-PARP(99)*LOG(RPT1*RPT2)
12862 ELSEIF(MSTP(93).EQ.3) THEN
12865 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
12869 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
12870 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
12872 IF(PT.GT.PARP(100)) GOTO 120
12880 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
12883 IF(MINT(47).EQ.1) RETURN
12885 C...Kinematics construction for initial partons.
12888 IF(ISUB.EQ.95) THEN
12892 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
12893 & (P(I1,2)+P(I2,2))**2
12894 SHR=SQRT(MAX(0D0,SHS))
12895 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
12896 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
12897 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
12898 P(I2,4)=SHR-P(I1,4)
12901 C...Transform partons to overall CM-frame.
12902 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
12903 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
12904 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
12905 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
12906 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
12907 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
12908 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
12909 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
12910 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
12911 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
12914 C...Optionally fix up x and Q2 definitions for leptoproduction.
12916 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
12917 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
12918 IF(IDISXQ.EQ.1) THEN
12920 C...Find where incoming and outgoing leptons/partons are sitting.
12922 IF(MINT(42).EQ.1) LESD=2
12923 LPIN=MINT(83)+3-LESD
12925 LQIN=MINT(84)+3-LESD
12926 LEOUT=MINT(84)+2+LESD
12927 LQOUT=MINT(84)+5-LESD
12928 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
12929 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
12931 DO 140 I=MINT(84)+5,N
12932 IF(K(I,2).EQ.94) THEN
12939 IF(LESD.EQ.1) LQBG=IPU2
12941 C...Calculate actual and wanted momentum transfer.
12944 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
12945 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
12946 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
12947 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
12948 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
12949 P(N+1,1)=FAC*P(LEOUT,1)
12950 P(N+1,2)=FAC*P(LEOUT,2)
12951 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
12952 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
12953 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
12956 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
12957 QNEW(J)=P(LEIN,J)-P(N+1,J)
12960 C...Boost outgoing electron and daughters.
12961 IF(LSCMS.EQ.0) THEN
12963 P(LEOUT,J)=P(N+1,J)
12967 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
12969 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
12971 DBE(J)=PINV*P(N+2,J)
12975 190 IORIG=K(IORIG,3)
12976 IF(IORIG.GT.LEOUT) GOTO 190
12977 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
12978 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
12982 C...Copy shower initiator and all outgoing partons.
12986 P(NCOP,J)=P(LQBG,J)
12988 DO 240 I=MINT(84)+1,N
12990 IF(K(I,1).GT.10) GOTO 240
12991 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
12995 220 IORIG=K(IORIG,3)
12996 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
12998 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
13011 C...Calculate relative rescaling factors.
13015 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
13018 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
13021 C...Transfer extra three-momentum of current.
13024 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
13026 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
13029 C...Iterate change of initiator momentum to get energy right.
13032 PEEX=-P(N+1,4)-QNEW(4)
13033 PEMV=-P(N+1,3)/P(N+1,4)
13036 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
13038 IF(ABS(PEMV).LT.1D-10) THEN
13040 MINT(57)=MINT(57)+1
13044 P(N+1,3)=P(N+1,3)+PZCH
13045 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)
13047 P(I,3)=P(I,3)+V(I,1)*PZCH
13048 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
13050 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
13052 C...Modify momenta in event record.
13053 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
13054 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
13055 IF(ABS(HBE).GE.1D0) THEN
13057 MINT(57)=MINT(57)+1
13061 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
13070 C...Check minimum invariant mass of remnant system(s).
13071 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
13072 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
13073 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
13074 PMIN(0)=SQRT(PMS(0))
13076 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
13077 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
13079 IF(MINT(44+JT).EQ.1) GOTO 340
13080 MINT(105)=MINT(102+JT)
13081 MINT(109)=MINT(106+JT)
13082 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
13083 IF(MINT(51).NE.0) THEN
13084 MINT(57)=MINT(57)+1
13087 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
13088 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
13089 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
13090 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
13091 & P(MINT(83)+JT+2,2)**2)
13093 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
13094 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
13097 MINT(57)=MINT(57)+1
13101 C...Loop over two remnants; skip if none there.
13105 IF(MINT(44+JT).EQ.1) GOTO 410
13106 IF(JT.EQ.1) IPU=IPU1
13107 IF(JT.EQ.2) IPU=IPU2
13109 C...Store first remnant parton.
13121 P(I,5)=PYMASS(K(I,2))
13123 C...First parton colour connections and kinematics.
13124 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
13127 K(I,4)=MSTU(5)*IPU+IPU
13128 K(I,5)=MSTU(5)*IPU+IPU
13129 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
13130 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
13131 ELSEIF(KCOL.NE.0) THEN
13133 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
13135 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
13137 IF(KFLCH(JT).EQ.0) THEN
13138 P(I,1)=-P(MINT(83)+JT+2,1)
13139 P(I,2)=-P(MINT(83)+JT+2,2)
13140 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13141 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
13145 C...When extra remnant parton or hadron: store extra remnant.
13157 P(I,5)=PYMASS(K(I,2))
13159 C...Find parton colour connections of extra remnant.
13160 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
13163 K(I,4)=MSTU(5)*IPU+IPU
13164 K(I,5)=MSTU(5)*IPU+IPU
13165 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
13166 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
13167 ELSEIF(KCOL.NE.0) THEN
13169 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
13171 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
13174 C...Relative transverse momentum when two remnants.
13177 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
13178 IF(IABS(MINT(10+JT)).LT.20) THEN
13182 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
13183 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
13185 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
13186 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
13187 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
13188 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13190 C...Meson or baryon; photon as meson. For splitup below.
13192 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
13194 C***Relative distribution for electron into two electrons. Temporary!
13195 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
13199 C...Relative distribution of electron energy into electron plus parton.
13200 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
13203 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
13205 C...Relative distribution of energy for particle into two jets.
13206 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
13207 CHIK=PARP(92+2*IMB)
13208 IF(MSTP(92).LE.1) THEN
13209 IF(IMB.EQ.1) CHI(JT)=PYR(0)
13210 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
13211 ELSEIF(MSTP(92).EQ.2) THEN
13212 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
13213 ELSEIF(MSTP(92).EQ.3) THEN
13214 CUT=2D0*0.3D0/VINT(1)
13215 380 CHI(JT)=PYR(0)**2
13216 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
13217 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
13218 ELSEIF(MSTP(92).EQ.4) THEN
13219 CUT=2D0*0.3D0/VINT(1)
13220 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
13221 390 CHIR=CUT*CUTR**PYR(0)
13222 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
13223 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
13225 CUT=2D0*0.3D0/VINT(1)
13226 CUTA=CUT**(1D0-PARP(98))
13227 CUTB=(1D0+CUT)**(1D0-PARP(98))
13228 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
13229 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
13230 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
13233 C...Relative distribution of energy for particle into jet plus particle.
13235 IF(MSTP(94).LE.1) THEN
13236 IF(IMB.EQ.1) CHI(JT)=PYR(0)
13237 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
13238 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
13239 ELSEIF(MSTP(94).EQ.2) THEN
13240 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
13241 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
13242 ELSEIF(MSTP(94).EQ.3) THEN
13243 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
13246 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
13251 C...Construct total transverse mass; reject if too large.
13252 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
13253 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
13254 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
13255 IF(LOOP.LT.10) THEN
13259 MINT(57)=MINT(57)+1
13263 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
13264 VINT(158+JT)=CHI(JT)
13266 C...Subdivide longitudinal momentum according to value selected above.
13267 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
13268 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
13269 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
13270 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
13271 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
13276 C...Check if longitudinal boosts needed - if so pick two systems.
13277 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
13278 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
13279 IF(PDEV.LE.1D-6*VINT(1)) RETURN
13280 IF(ISN(1).EQ.0) THEN
13283 ELSEIF(ISN(2).EQ.0) THEN
13286 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
13289 ELSEIF(VINT(143).GT.0.2D0) THEN
13292 ELSEIF(VINT(144).GT.0.2D0) THEN
13295 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
13304 C...E+-pL wanted for system to be modified.
13305 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
13309 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
13310 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
13313 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
13314 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
13318 SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL))
13319 SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
13320 RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3))
13322 RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3))
13324 BER=(RKR**2-1D0)/(RKR**2+1D0)
13325 BEL=-(RKL**2-1D0)/(RKL**2+1D0)
13326 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
13327 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
13331 DO 450 I=MINT(84)+1,NS
13332 IF(K(I,1).GT.10) GOTO 450
13335 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
13337 IF(IORIG.GT.LPIN) GOTO 430
13338 IF(INCL.EQ.0) GOTO 450
13340 PSYS(0,J)=PSYS(0,J)+P(I,J)
13343 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
13344 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
13345 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
13348 C...Construct longitudinal boosts.
13352 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
13353 IF(DSQLAM.LE.1D-6*DPMTB) THEN
13355 MINT(57)=MINT(57)+1
13358 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
13359 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
13360 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
13361 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
13362 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
13363 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
13364 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
13366 C...Perform longitudinal boosts.
13367 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
13369 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
13370 ELSEIF(IR.EQ.1) THEN
13371 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
13372 ELSEIF(IDISXQ.EQ.1) THEN
13376 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
13378 IF(IORIG.GT.LPIN) GOTO 460
13379 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
13382 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
13384 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
13386 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
13387 ELSEIF(IL.EQ.2) THEN
13388 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
13389 ELSEIF(IDISXQ.EQ.1) THEN
13393 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
13395 IF(IORIG.GT.LPIN) GOTO 480
13396 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
13399 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
13402 C...Final check that energy-momentum conservation worked.
13405 DO 500 I=MINT(84)+1,N
13406 IF(K(I,1).GT.10) GOTO 500
13410 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
13411 IF(PDEV.GT.1D-4*VINT(1)) THEN
13413 MINT(57)=MINT(57)+1
13417 C...Calculate rotation and boost from overall CM frame to
13418 C...hadronic CM frame in leptoproduction.
13420 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
13423 IF(MINT(42).EQ.1) LESD=2
13424 LPIN=MINT(83)+3-LESD
13426 C...Sum upp momenta of everything not lepton or photon to define boost.
13431 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
13432 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
13433 IF(K(I,2).EQ.22) GOTO 530
13435 PSUM(J)=PSUM(J)+P(I,J)
13438 VINT(223)=-PSUM(1)/PSUM(4)
13439 VINT(224)=-PSUM(2)/PSUM(4)
13440 VINT(225)=-PSUM(3)/PSUM(4)
13442 C...Boost incoming hadron to hadronic CM frame to determine rotations.
13448 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
13449 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
13450 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
13452 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
13454 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
13461 C*********************************************************************
13464 C...Handles diffractive and elastic scattering.
13468 C...Double precision and integer declarations.
13469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13470 IMPLICIT INTEGER(I-N)
13471 INTEGER PYK,PYCHGE,PYCOMP
13473 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13474 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13475 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13476 COMMON/PYINT1/MINT(400),VINT(400)
13477 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
13479 C...Reset K, P and V vectors. Store incoming particles.
13480 DO 110 JT=1,MSTP(126)+10
13500 P(I,J)=VINT(285+5*JT+J)
13505 C...Subprocess; kinematics.
13506 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
13507 PZ=SQRT(SQLAM)/(2D0*VINT(1))
13510 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
13513 C...Elastically scattered particle. (Except elastic GVMD states.)
13514 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
13515 & MINT(106+JT).NE.3)) THEN
13520 P(N,3)=PZ*(-1)**(JT+1)
13522 P(N,5)=SQRT(VINT(62+JT))
13524 C...Decay rho from elastic scattering of gamma with sin**2(theta)
13525 C...distribution of decay products (in rho rest frame).
13526 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
13528 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
13532 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
13533 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
13534 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
13535 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
13536 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
13537 140 CTHE=2D0*PYR(0)-1D0
13538 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
13539 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
13541 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
13544 C...Diffracted particle: low-mass system to two particles.
13545 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
13551 PMMAS=SQRT(VINT(62+JT))
13554 IF(NTRY.LT.20) THEN
13555 MINT(105)=MINT(102+JT)
13556 MINT(109)=MINT(106+JT)
13557 CALL PYSPLI(KFH,21,KFL1,KFL2)
13558 CALL PYKFDI(KFL1,0,KFL3,KF1)
13559 IF(KF1.EQ.0) GOTO 150
13560 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
13561 IF(KF2.EQ.0) GOTO 150
13568 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
13573 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
13574 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
13577 P(N-1,4)=SQRT(PM1**2+PZP**2)
13578 P(N,4)=SQRT(PM2**2+PZP**2)
13579 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
13581 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
13582 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
13584 C...Diffracted particle: valence quark kicked out.
13585 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
13592 MINT(105)=MINT(102+JT)
13593 MINT(109)=MINT(106+JT)
13594 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
13595 P(N-1,5)=PYMASS(K(N-1,2))
13596 P(N,5)=PYMASS(K(N,2))
13597 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
13598 & 4D0*P(N-1,5)**2*P(N,5)**2
13599 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
13600 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
13601 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
13602 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
13603 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
13605 C...Diffracted particle: gluon kicked out.
13614 MINT(105)=MINT(102+JT)
13615 MINT(109)=MINT(106+JT)
13616 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
13618 P(N-2,5)=PYMASS(K(N-2,2))
13620 P(N,5)=PYMASS(K(N,2))
13621 C...Energy distribution for particle into two jets.
13623 IF(MOD(KFH/1000,10).NE.0) IMB=2
13624 CHIK=PARP(92+2*IMB)
13625 IF(MSTP(92).LE.1) THEN
13626 IF(IMB.EQ.1) CHI=PYR(0)
13627 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
13628 ELSEIF(MSTP(92).EQ.2) THEN
13629 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
13630 ELSEIF(MSTP(92).EQ.3) THEN
13631 CUT=2D0*0.3D0/VINT(1)
13633 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
13635 ELSEIF(MSTP(92).EQ.4) THEN
13636 CUT=2D0*0.3D0/VINT(1)
13637 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
13638 180 CHIR=CUT*CUTR**PYR(0)
13639 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
13640 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
13642 CUT=2D0*0.3D0/VINT(1)
13643 CUTA=CUT**(1D0-PARP(98))
13644 CUTB=(1D0+CUT)**(1D0-PARP(98))
13645 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
13646 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
13647 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
13649 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
13650 & VINT(62+JT)) GOTO 160
13651 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
13652 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
13653 & (2D0*VINT(62+JT))
13654 PEI=SQRT(PZI**2+SQM)
13655 PQQP=(1D0-CHI)*(PEI+PZI)
13656 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
13657 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
13658 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
13659 P(N-1,3)=P(N-1,4)*(-1)**JT
13660 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
13661 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
13664 C...Documentation lines.
13666 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
13667 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
13668 & MINT(106+JT).EQ.3)) K(I+2,2)=10*(KFH/10)
13670 P(I+2,3)=PZ*(-1)**(JT+1)
13672 P(I+2,5)=SQRT(VINT(62+JT))
13675 C...Rotate outgoing partons/particles using cos(theta).
13676 IF(VINT(23).LT.0.9D0) THEN
13677 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13679 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
13685 C*********************************************************************
13688 C...Set up a DIS process as gamma* + f -> f, with beam remnant
13689 C...and showering added consecutively. Photon flux by the PYGAGA
13690 C...routine (if at all).
13694 C...Double precision and integer declarations.
13695 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13696 IMPLICIT INTEGER(I-N)
13697 INTEGER PYK,PYCHGE,PYCOMP
13698 C...Parameter statement to help give large particle numbers.
13699 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
13701 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13702 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13704 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13705 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13706 COMMON/PYINT1/MINT(400),VINT(400)
13707 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
13711 C...Choice of subprocess, number of documentation lines
13719 IF(MINT(107).EQ.4) ISIDE=2
13721 C...Reset K, P and V vectors. Store incoming particles
13722 DO 120 JT=1,MSTP(126)+20
13735 P(I,J)=VINT(285+5*JT+J)
13740 C...Store incoming partons in hadronic CM-frame
13745 K(I,3)=MINT(83)+2+JT
13747 IF(MINT(15).EQ.22) THEN
13748 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
13749 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
13750 P(MINT(84)+1,5)=-SQRT(VINT(307))
13751 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
13752 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
13756 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
13757 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
13758 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
13759 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
13760 P(MINT(84)+1,5)=-SQRT(VINT(308))
13764 SIDESG=(-1D0)**(ISIDE-1)
13766 C...Copy incoming partons to documentation lines.
13777 C...Second copy for partons before ISR shower, since no such.
13787 C...Define initial partons.
13790 IF(NTRY.GT.100) THEN
13795 C...Scattered quark in hadronic CM frame.
13800 P(IPU3,5)=PYMASS(KFRES)
13801 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
13802 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
13806 K(I,3)=MINT(83)+4+ISIDE
13814 C...No primordial kT, or chosen according to truncated Gaussian or
13815 C...exponential, or (for photon) predetermined or power law.
13816 220 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
13817 IF(MSTP(91).LE.0) THEN
13819 ELSEIF(MSTP(91).EQ.1) THEN
13820 PT=PARP(91)*SQRT(-LOG(PYR(0)))
13824 PT=-PARP(92)*LOG(RPT1*RPT2)
13826 IF(PT.GT.PARP(93)) GOTO 220
13827 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
13828 PTA=SQRT(VINT(282+ISIDE))
13830 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
13831 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
13832 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
13835 PTB=-PARP(99)*LOG(RPT1*RPT2)
13837 IF(PTB.GT.PARP(100)) GOTO 220
13838 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
13839 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
13840 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
13841 IF(MSTP(93).LE.0) THEN
13843 ELSEIF(MSTP(93).EQ.1) THEN
13844 PT=PARP(99)*SQRT(-LOG(PYR(0)))
13845 ELSEIF(MSTP(93).EQ.2) THEN
13848 PT=-PARP(99)*LOG(RPT1*RPT2)
13849 ELSEIF(MSTP(93).EQ.3) THEN
13852 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
13856 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
13857 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
13859 IF(PT.GT.PARP(100)) GOTO 220
13865 P(IPU3,1)=PT*COS(PHI)
13866 P(IPU3,2)=PT*SIN(PHI)
13867 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
13868 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13869 PCP=P(IPU3,4)+ABS(P(IPU3,3))
13871 C...Find one or two beam remnants.
13872 MINT(105)=MINT(102+ISIDE)
13873 MINT(109)=MINT(106+ISIDE)
13874 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
13875 IF(MINT(51).NE.0) THEN
13880 C...Store first remnant parton, with colour info and kinematics.
13884 K(I,3)=MINT(83)+ISIDE
13885 P(I,5)=PYMASS(K(I,2))
13886 KCOL=KCHG(PYCOMP(KFLSP),2)
13889 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
13890 K(I,KFLS+3)=MSTU(5)*IPU3
13891 K(IPU3,6-KFLS)=MSTU(5)*I
13894 IF(KFLCH.EQ.0) THEN
13897 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13899 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
13900 PRP=P(I,4)+ABS(P(I,3))
13902 C...When extra remnant parton or hadron: store extra remnant.
13907 K(I,3)=MINT(83)+ISIDE
13908 P(I,5)=PYMASS(K(I,2))
13909 KCOL=KCHG(PYCOMP(KFLCH),2)
13912 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
13913 K(I,KFLS+3)=MSTU(5)*IPU3
13914 K(IPU3,6-KFLS)=MSTU(5)*I
13918 C...Relative transverse momentum when two remnants.
13921 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
13922 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
13923 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
13924 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
13925 P(I,1)=-P(IPU3,1)-P(I-1,1)
13926 P(I,2)=-P(IPU3,2)-P(I-1,2)
13927 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13929 C...Relative distribution of energy for particle into jet plus particle.
13931 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
13932 IF(MSTP(94).LE.1) THEN
13933 IF(IMB.EQ.1) CHI=PYR(0)
13934 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
13935 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
13936 ELSEIF(MSTP(94).EQ.2) THEN
13937 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
13938 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
13939 ELSEIF(MSTP(94).EQ.3) THEN
13940 CALL PYZDIS(1,0,PMS(4),ZZ)
13943 CALL PYZDIS(1000,0,PMS(4),ZZ)
13947 C...Construct total transverse mass; reject if too large.
13948 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
13949 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
13950 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
13951 IF(LOOP.LT.10) GOTO 370
13954 VINT(158+ISIDE)=CHI
13956 C...Subdivide longitudinal momentum according to value selected above.
13957 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
13959 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
13960 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
13962 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
13963 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
13967 C...Boost current and remnant systems to correct frame.
13968 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 200
13969 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
13970 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
13972 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
13974 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
13975 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
13976 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
13977 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
13979 C...Let current quark shower; recoil but no showering by colour partner.
13980 QMAX=SQRT(VINT(309-ISIDE))
13985 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
13992 C*********************************************************************
13995 C...Handles the documentation of the process in MSTI and PARI,
13996 C...and also computes cross-sections based on accumulated statistics.
14000 C...Double precision and integer declarations.
14001 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14002 IMPLICIT INTEGER(I-N)
14003 INTEGER PYK,PYCHGE,PYCOMP
14005 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14006 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14007 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14008 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14009 COMMON/PYINT1/MINT(400),VINT(400)
14010 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14011 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14012 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
14015 C...Calculate Monte Carlo estimates of cross-sections.
14017 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
14018 NGEN(0,3)=NGEN(0,3)+1
14021 IF(I.EQ.96.OR.I.EQ.97) THEN
14023 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
14024 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
14025 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
14026 & DBLE(NGEN(96,2)))
14027 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
14029 ELSEIF(NGEN(I,2).EQ.0) THEN
14030 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
14033 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
14036 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
14039 C...Rescale to known low-pT cross-section for standard QCD processes.
14040 IF(MSUB(95).EQ.1) THEN
14041 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
14042 & XSEC(68,3)+XSEC(95,3)
14043 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
14044 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
14046 XSEC(11,3)=FAC*XSEC(11,3)
14047 XSEC(12,3)=FAC*XSEC(12,3)
14048 XSEC(13,3)=FAC*XSEC(13,3)
14049 XSEC(28,3)=FAC*XSEC(28,3)
14050 XSEC(53,3)=FAC*XSEC(53,3)
14051 XSEC(68,3)=FAC*XSEC(68,3)
14052 XSEC(95,3)=FAC*XSEC(95,3)
14053 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
14057 C...Save information for gamma-p and gamma-gamma.
14058 IF(MINT(121).GT.1) THEN
14064 C...Reset information on hard interaction.
14070 C...Copy integer valued information from MINT into MSTI.
14074 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
14076 C...Store cross-section variables in PARI.
14078 PARI(2)=XSEC(0,3)/MINT(5)
14081 VINT(98)=VINT(98)+VINT(100)
14082 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
14084 C...Store kinematics variables in PARI.
14087 IF(ISUB.NE.95) THEN
14095 PARI(35)=PARI(33)-PARI(34)
14102 PARI(42)=2D0*VINT(47)/VINT(1)
14105 C...Store information on scattered partons in PARI.
14106 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
14109 PARI(36+IS)=P(I,3)/VINT(1)
14110 PARI(38+IS)=P(I,4)/VINT(1)
14111 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
14112 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
14113 & SQRT(PR),1D20)),P(I,3))
14114 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
14115 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
14116 & SQRT(PR),1D20)),P(I,3))
14117 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14118 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
14119 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
14123 C...Store sum up transverse and longitudinal momenta.
14124 PARI(65)=2D0*PARI(17)
14125 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
14126 DO 150 I=MSTP(126)+1,N
14127 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
14128 PT=SQRT(P(I,1)**2+P(I,2)**2)
14129 PARI(69)=PARI(69)+PT
14130 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
14131 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
14143 C...Store various other pieces of information into PARI.
14151 C...Store information on lepton -> lepton + gamma in PYGAGA.
14154 PARI(101)=VINT(301)
14155 PARI(102)=VINT(302)
14157 PARI(I)=VINT(I+202)
14160 C...Set information for PYTABU.
14161 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
14164 ELSEIF(ISET(ISUB).EQ.5) THEN
14175 C*********************************************************************
14178 C...Performs transformations between different coordinate frames.
14180 SUBROUTINE PYFRAM(IFRAME)
14182 C...Double precision and integer declarations.
14183 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14184 IMPLICIT INTEGER(I-N)
14185 INTEGER PYK,PYCHGE,PYCOMP
14187 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14188 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14189 COMMON/PYINT1/MINT(400),VINT(400)
14190 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
14192 C...Check that transformation can and should be done.
14193 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
14194 &MINT(91).EQ.1)) THEN
14195 IF(IFRAME.EQ.MINT(6)) RETURN
14197 WRITE(MSTU(11),5000) IFRAME,MINT(6)
14201 IF(MINT(6).EQ.1) THEN
14202 C...Transform from fixed target or user specified frame to
14203 C...overall CM frame.
14204 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
14205 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
14206 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
14207 ELSEIF(MINT(6).EQ.3) THEN
14208 C...Transform from hadronic CM frame in DIS to overall CM frame.
14209 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
14213 IF(IFRAME.EQ.1) THEN
14214 C...Transform from overall CM frame to fixed target or user specified
14216 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
14217 ELSEIF(IFRAME.EQ.3) THEN
14218 C...Transform from overall CM frame to hadronic CM frame in DIS.
14219 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
14220 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
14221 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
14224 C...Set information about new frame.
14228 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
14229 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
14235 C*********************************************************************
14238 C...Calculates full and partial widths of resonances.
14240 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
14242 C...Double precision and integer declarations.
14243 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14244 IMPLICIT INTEGER(I-N)
14245 INTEGER PYK,PYCHGE,PYCOMP
14246 C...Parameter statement to help give large particle numbers.
14247 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
14249 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14250 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14251 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
14252 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14253 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14254 COMMON/PYINT1/MINT(400),VINT(400)
14255 COMMON/PYINT4/MWID(500),WIDS(500,5)
14256 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
14257 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
14259 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
14260 &/PYINT4/,/PYMSSM/,/PYSSMT/
14261 C...Local arrays and saved variables.
14262 DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
14263 &WID2SV(3,2),WDTPP(0:200),WDTEP(0:200,0:5)
14264 SAVE MOFSV,WIDWSV,WID2SV
14265 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
14267 C...Compressed code and sign; mass.
14274 C...Reset width information.
14282 C...Not to be treated as a resonance: return.
14283 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
14292 C...Treatment as a resonance based on tabulated branching ratios.
14293 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
14294 C...Loop over possible decay channels; skip irrelevant ones.
14295 DO 120 I=1,MDCY(KC,3)
14297 IF(MDME(IDC,1).LT.0) GOTO 120
14299 C...Read out decay products and nominal masses.
14302 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
14306 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
14312 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
14316 C...Naive partial width and alternative threshold factors.
14317 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
14318 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
14319 & PM1+PM2+PM3.GE.SHR) THEN
14321 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
14322 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
14323 & 4D0*PM1**2*PM2**2))/SH
14324 ELSEIF(MDME(IDC,2).EQ.52) THEN
14325 PMA=MAX(PM1,PM2,PM3)
14326 PMC=MIN(PM1,PM2,PM3)
14327 PMB=PM1+PM2+PM3-PMA-PMC
14328 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
14333 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
14334 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
14335 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
14336 & ((SHR-PMA)**2-(PMB+PMC)**2)*
14337 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
14338 & ((1D0-PMBCN)*PMBCN*SH)
14339 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
14340 WDTP(I)=WDTP(I)*SQRT(
14341 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
14342 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
14343 ELSEIF(MDME(IDC,2).EQ.53) THEN
14344 PMA=MAX(PM1,PM2,PM3)
14345 PMC=MIN(PM1,PM2,PM3)
14346 PMB=PM1+PM2+PM3-PMA-PMC
14347 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
14352 FACACT=SQRT(MAX(0D0,
14353 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
14354 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
14355 & ((SHR-PMA)**2-(PMB+PMC)**2)*
14356 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
14357 & ((1D0-PMBCN)*PMBCN*SH)
14358 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
14362 PMBCN=PMBC**2/PMR**2
14363 FACNOM=SQRT(MAX(0D0,
14364 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
14365 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
14366 & ((PMR-PMA)**2-(PMB+PMC)**2)*
14367 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
14368 & ((1D0-PMBCN)*PMBCN*PMR**2)
14369 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
14371 WDTP(0)=WDTP(0)+WDTP(I)
14373 C...Calculate secondary width (at most two identical/opposite).
14375 IF(MDME(IDC,1).GT.0) THEN
14376 IF(KFD2.EQ.KFD1) THEN
14377 IF(KCHG(KFC1,3).EQ.0) THEN
14379 ELSEIF(KFD1.GT.0) THEN
14385 WID2=WID2*WIDS(KFC3,2)
14386 ELSEIF(KFD3.LT.0) THEN
14387 WID2=WID2*WIDS(KFC3,3)
14389 ELSEIF(KFD2.EQ.-KFD1) THEN
14392 WID2=WID2*WIDS(KFC3,2)
14393 ELSEIF(KFD3.LT.0) THEN
14394 WID2=WID2*WIDS(KFC3,3)
14396 ELSEIF(KFD3.EQ.KFD1) THEN
14397 IF(KCHG(KFC1,3).EQ.0) THEN
14399 ELSEIF(KFD1.GT.0) THEN
14405 WID2=WID2*WIDS(KFC2,2)
14406 ELSEIF(KFD2.LT.0) THEN
14407 WID2=WID2*WIDS(KFC2,3)
14409 ELSEIF(KFD3.EQ.-KFD1) THEN
14412 WID2=WID2*WIDS(KFC2,2)
14413 ELSEIF(KFD2.LT.0) THEN
14414 WID2=WID2*WIDS(KFC2,3)
14416 ELSEIF(KFD3.EQ.KFD2) THEN
14417 IF(KCHG(KFC2,3).EQ.0) THEN
14419 ELSEIF(KFD2.GT.0) THEN
14425 WID2=WID2*WIDS(KFC1,2)
14426 ELSEIF(KFD1.LT.0) THEN
14427 WID2=WID2*WIDS(KFC1,3)
14429 ELSEIF(KFD3.EQ.-KFD2) THEN
14432 WID2=WID2*WIDS(KFC1,2)
14433 ELSEIF(KFD1.LT.0) THEN
14434 WID2=WID2*WIDS(KFC1,3)
14443 WID2=WID2*WIDS(KFC2,2)
14445 WID2=WID2*WIDS(KFC2,3)
14448 WID2=WID2*WIDS(KFC3,2)
14449 ELSEIF(KFD3.LT.0) THEN
14450 WID2=WID2*WIDS(KFC3,3)
14454 C...Store effective widths according to case.
14455 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14456 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14457 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14458 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14468 C...Here begins detailed dynamical calculation of resonance widths.
14469 C...Shared treatment of Higgs states.
14472 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
14477 C...Common electroweak and strong constants.
14480 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
14483 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
14485 RADC=1D0+AS/PARU(1)
14489 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14490 RADCT=1D0-2.5D0*AS/PARU(1)
14491 DO 130 I=1,MDCY(KC,3)
14493 IF(MDME(IDC,1).LT.0) GOTO 130
14494 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14495 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14496 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
14498 IF(I.GE.4.AND.I.LE.7) THEN
14499 C...t -> W + q; including approximate QCD correction factor.
14500 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
14501 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14502 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14505 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
14508 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
14510 ELSEIF(I.EQ.9) THEN
14512 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14513 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
14515 IF(KFLR.LT.0) WID2=WIDS(37,3)
14517 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
14518 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
14521 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
14524 KFC1=PYCOMP(KFDP(IDC,1))
14525 KFC2=PYCOMP(KFDP(IDC,2))
14526 PMNCHI=PMAS(KFC1,1)
14527 PMSTOP=PMAS(KFC2,1)
14528 IF(SHR.GT.PMNCHI+PMSTOP) THEN
14530 AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB)
14531 AR=-ET*ZMIX(IZ,1)*TANW
14532 BL=T3L*(ZMIX(IZ,2)-ZMIX(IZ,1)*TANW)-AR
14534 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
14535 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
14536 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
14537 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
14538 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*((FL**2+FR**2)*
14539 & (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH
14541 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
14543 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
14546 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
14548 KFC1=PYCOMP(KFDP(IDC,1))
14549 KFC2=PYCOMP(KFDP(IDC,2))
14550 PMNCHI=PMAS(KFC1,1)
14551 PMSTOP=PMAS(KFC2,1)
14552 IF(SHR.GT.PMNCHI+PMSTOP) THEN
14555 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
14556 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
14557 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((FL**2+FR**2)*
14558 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*FL*FR)/SH
14560 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
14562 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
14565 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
14566 C...t -> ~gravitino + ~t
14568 KFC1=PYCOMP(KFDP(IDC,1))
14569 XMGR2=PMAS(KFC1,1)**2
14570 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
14571 KFC2=PYCOMP(KFDP(IDC,2))
14573 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
14576 WDTP(0)=WDTP(0)+WDTP(I)
14577 IF(MDME(IDC,1).GT.0) THEN
14578 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14579 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14580 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14581 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14585 ELSEIF(KFLA.EQ.7) THEN
14587 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14588 DO 140 I=1,MDCY(KC,3)
14590 IF(MDME(IDC,1).LT.0) GOTO 140
14591 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14592 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14593 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
14595 IF(I.GE.4.AND.I.LE.7) THEN
14597 WDTP(I)=FAC*VCKM(I-3,4)*
14598 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14599 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14602 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
14603 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
14606 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
14607 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
14610 IF(KFLR.LT.0) WID2=WIDS(24,2)
14611 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
14613 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14614 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
14617 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
14620 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
14623 WDTP(0)=WDTP(0)+WDTP(I)
14624 IF(MDME(IDC,1).GT.0) THEN
14625 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14626 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14627 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14628 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14632 ELSEIF(KFLA.EQ.8) THEN
14634 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14635 DO 150 I=1,MDCY(KC,3)
14637 IF(MDME(IDC,1).LT.0) GOTO 150
14638 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14639 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14640 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
14642 IF(I.GE.4.AND.I.LE.7) THEN
14644 WDTP(I)=FAC*VCKM(4,I-3)*
14645 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14646 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14649 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
14652 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
14654 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
14656 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14657 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
14660 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
14663 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
14666 WDTP(0)=WDTP(0)+WDTP(I)
14667 IF(MDME(IDC,1).GT.0) THEN
14668 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14669 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14670 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14671 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14675 ELSEIF(KFLA.EQ.17) THEN
14677 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14678 DO 160 I=1,MDCY(KC,3)
14680 IF(MDME(IDC,1).LT.0) GOTO 160
14681 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14682 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14683 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
14686 C...tau' -> W + nu'_tau.
14687 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14688 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14691 WID2=WID2*WIDS(18,2)
14694 WID2=WID2*WIDS(18,3)
14696 ELSEIF(I.EQ.5) THEN
14697 C...tau' -> H + nu'_tau.
14698 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14699 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
14702 WID2=WID2*WIDS(18,2)
14705 WID2=WID2*WIDS(18,3)
14708 WDTP(0)=WDTP(0)+WDTP(I)
14709 IF(MDME(IDC,1).GT.0) THEN
14710 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14711 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14712 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14713 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14717 ELSEIF(KFLA.EQ.18) THEN
14718 C...nu'_tau neutrino.
14719 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14720 DO 170 I=1,MDCY(KC,3)
14722 IF(MDME(IDC,1).LT.0) GOTO 170
14723 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14724 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14725 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
14728 C...nu'_tau -> W + tau'.
14729 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14730 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14733 WID2=WID2*WIDS(17,2)
14736 WID2=WID2*WIDS(17,3)
14738 ELSEIF(I.EQ.3) THEN
14739 C...nu'_tau -> H + tau'.
14740 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14741 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
14744 WID2=WID2*WIDS(17,2)
14747 WID2=WID2*WIDS(17,3)
14750 WDTP(0)=WDTP(0)+WDTP(I)
14751 IF(MDME(IDC,1).GT.0) THEN
14752 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14753 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14754 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14755 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14759 ELSEIF(KFLA.EQ.21) THEN
14761 C***Note that widths are not given in dimensional quantities here.
14762 DO 180 I=1,MDCY(KC,3)
14764 IF(MDME(IDC,1).LT.0) GOTO 180
14765 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
14766 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
14767 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
14770 C...QCD -> q + qbar
14771 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
14772 IF(I.EQ.6) WID2=WIDS(6,1)
14773 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
14775 WDTP(0)=WDTP(0)+WDTP(I)
14776 IF(MDME(IDC,1).GT.0) THEN
14777 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14778 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14779 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14780 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14784 ELSEIF(KFLA.EQ.22) THEN
14786 C***Note that widths are not given in dimensional quantities here.
14787 DO 190 I=1,MDCY(KC,3)
14789 IF(MDME(IDC,1).LT.0) GOTO 190
14790 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
14791 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
14792 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
14795 C...QED -> q + qbar.
14798 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
14799 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
14800 IF(I.EQ.6) WID2=WIDS(6,1)
14801 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
14802 ELSEIF(I.LE.12) THEN
14803 C...QED -> l+ + l-.
14804 EF=KCHG(9+2*(I-8),1)/3D0
14805 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
14806 IF(I.EQ.12) WID2=WIDS(17,1)
14808 WDTP(0)=WDTP(0)+WDTP(I)
14809 IF(MDME(IDC,1).GT.0) THEN
14810 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14811 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14812 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14813 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14817 ELSEIF(KFLA.EQ.23) THEN
14820 XWC=1D0/(16D0*XW*XW1)
14821 FAC=(AEM*XWC/3D0)*SHR
14823 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
14828 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
14830 IF(KFI.GT.20) KFI=IABS(MINT(16))
14836 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
14837 IF(MSTP(43).EQ.3) VINT(112)=
14838 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
14839 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
14840 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
14842 DO 210 I=1,MDCY(KC,3)
14844 IF(MDME(IDC,1).LT.0) GOTO 210
14845 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
14846 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
14847 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
14852 AF=SIGN(1D0,EF+0.1D0)
14855 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
14856 IF(I.EQ.6) WID2=WIDS(6,1)
14857 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
14858 ELSEIF(I.LE.16) THEN
14859 C...Z0 -> l+ + l-, nu + nubar
14861 AF=SIGN(1D0,EF+0.1D0)
14864 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
14866 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
14867 IF(ICASE.EQ.1) THEN
14868 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
14870 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
14871 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
14872 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
14873 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
14874 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
14875 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
14876 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
14877 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
14879 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
14880 IF(MDME(IDC,1).GT.0) THEN
14881 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
14882 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
14883 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14884 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
14885 & WDTE(I,MDME(IDC,1))
14886 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14887 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14889 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
14890 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
14891 & VINT(111)+FGGF*WID2
14892 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
14893 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
14894 & VINT(114)+FZZF*WID2
14898 IF(MINT(61).GE.1) ICASE=3-ICASE
14899 IF(ICASE.EQ.2) GOTO 200
14901 ELSEIF(KFLA.EQ.24) THEN
14903 FAC=(AEM/(24D0*XW))*SHR
14904 DO 220 I=1,MDCY(KC,3)
14906 IF(MDME(IDC,1).LT.0) GOTO 220
14907 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
14908 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
14909 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
14912 C...W+/- -> q + qbar'
14913 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
14915 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
14916 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
14917 IF(I.GE.13) WID2=WID2*WIDS(7,3)
14919 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
14920 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
14921 IF(I.GE.13) WID2=WID2*WIDS(7,2)
14923 ELSEIF(I.LE.20) THEN
14924 C...W+/- -> l+/- + nu
14927 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
14929 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
14932 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
14933 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
14934 WDTP(0)=WDTP(0)+WDTP(I)
14935 IF(MDME(IDC,1).GT.0) THEN
14936 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14937 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14938 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14939 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14943 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
14944 C...h0 (or H0, or A0):
14945 IF(MSTP(49).EQ.0) THEN
14946 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
14948 FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR
14950 DO 260 I=1,MDCY(KFHIGG,3)
14951 IDC=I+MDCY(KFHIGG,2)-1
14952 IF(MDME(IDC,1).LT.0) GOTO 260
14953 KFC1=PYCOMP(KFDP(IDC,1))
14954 KFC2=PYCOMP(KFDP(IDC,2))
14955 RM1=PMAS(KFC1,1)**2/SH
14956 RM2=PMAS(KFC2,1)**2/SH
14957 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
14963 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SH)*
14964 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
14965 C...A0 behaves like beta, ho and H0 like beta**3.
14966 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
14967 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
14968 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
14969 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
14971 IF(I.EQ.6) WID2=WIDS(6,1)
14972 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
14974 ELSEIF(I.LE.12) THEN
14976 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))
14977 C...A0 behaves like beta, ho and H0 like beta**3.
14978 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
14979 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
14980 & PARU(153+10*IHIGG)**2
14981 IF(I.EQ.12) WID2=WIDS(17,1)
14983 ELSEIF(I.EQ.13) THEN
14984 C...h0 -> g + g; quark loop contribution only
14987 DO 230 J=1,2*MSTP(1)
14988 EPS=(2D0*PMAS(J,1))**2/SH
14989 C...Loop integral; function of eps=4m^2/shat; different for A0.
14990 IF(EPS.LE.1D0) THEN
14991 IF(EPS.GT.1D-4) THEN
14993 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
14995 RLN=LOG(4D0/EPS-2D0)
14997 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
14998 PHIIM=0.5D0*PARU(1)*RLN
15000 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
15003 IF(IHIGG.LE.2) THEN
15004 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
15005 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
15007 ETAREJ=-0.5D0*EPS*PHIRE
15008 ETAIMJ=-0.5D0*EPS*PHIIM
15010 C...Couplings (=1 for standard model Higgs).
15011 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
15012 IF(MOD(J,2).EQ.1) THEN
15013 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
15014 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
15016 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
15017 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
15023 ETA2=ETARE**2+ETAIM**2
15024 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
15026 ELSEIF(I.EQ.14) THEN
15027 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
15031 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
15033 IF(J.LE.2*MSTP(1)) THEN
15035 EPS=(2D0*PMAS(J,1))**2/SH
15036 ELSEIF(J.LE.3*MSTP(1)) THEN
15037 JL=2*(J-2*MSTP(1))-1
15038 EJ=KCHG(10+JL,1)/3D0
15039 EPS=(2D0*PMAS(10+JL,1))**2/SH
15040 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
15041 EPS=(2D0*PMAS(24,1))**2/SH
15043 EPS=(2D0*PMAS(37,1))**2/SH
15045 C...Loop integral; function of eps=4m^2/shat.
15046 IF(EPS.LE.1D0) THEN
15047 IF(EPS.GT.1D-4) THEN
15049 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
15051 RLN=LOG(4D0/EPS-2D0)
15053 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
15054 PHIIM=0.5D0*PARU(1)*RLN
15056 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
15059 IF(J.LE.3*MSTP(1)) THEN
15060 C...Fermion loops: loop integral different for A0; charges.
15061 IF(IHIGG.LE.2) THEN
15062 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
15063 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
15065 PHIPRE=-0.5D0*EPS*PHIRE
15066 PHIPIM=-0.5D0*EPS*PHIIM
15068 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
15070 EJH=PARU(151+10*IHIGG)
15071 ELSEIF(J.LE.2*MSTP(1)) THEN
15073 EJH=PARU(152+10*IHIGG)
15076 EJH=PARU(153+10*IHIGG)
15078 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
15079 ETAREJ=EJC*EJH*PHIPRE
15080 ETAIMJ=EJC*EJH*PHIPIM
15081 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
15082 C...W loops: loop integral and charges.
15083 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
15084 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
15085 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
15086 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
15087 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
15090 C...Charged H loops: loop integral and charges.
15091 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
15092 & PARU(158+10*IHIGG+2*(IHIGG/3))
15093 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
15094 ETAIMJ=-EPS**2*PHIIM*FACHHH
15099 ETA2=ETARE**2+ETAIM**2
15100 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
15102 ELSEIF(I.EQ.15) THEN
15103 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
15107 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
15109 IF(J.LE.2*MSTP(1)) THEN
15111 AJ=SIGN(1D0,EJ+0.1D0)
15113 EPS=(2D0*PMAS(J,1))**2/SH
15114 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
15115 ELSEIF(J.LE.3*MSTP(1)) THEN
15116 JL=2*(J-2*MSTP(1))-1
15117 EJ=KCHG(10+JL,1)/3D0
15118 AJ=SIGN(1D0,EJ+0.1D0)
15120 EPS=(2D0*PMAS(10+JL,1))**2/SH
15121 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
15123 EPS=(2D0*PMAS(24,1))**2/SH
15124 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
15126 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
15127 IF(EPS.LE.1D0) THEN
15129 IF(EPS.GT.1D-4) THEN
15130 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
15132 RLN=LOG(4D0/EPS-2D0)
15134 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
15135 PHIIM=0.5D0*PARU(1)*RLN
15136 PSIRE=0.5D0*ROOT*RLN
15137 PSIIM=-0.5D0*ROOT*PARU(1)
15139 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
15141 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
15144 IF(EPSP.LE.1D0) THEN
15145 ROOT=SQRT(1D0-EPSP)
15146 IF(EPSP.GT.1D-4) THEN
15147 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
15149 RLN=LOG(4D0/EPSP-2D0)
15151 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
15152 PHIIMP=0.5D0*PARU(1)*RLN
15153 PSIREP=0.5D0*ROOT*RLN
15154 PSIIMP=-0.5D0*ROOT*PARU(1)
15156 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
15158 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
15161 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
15162 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
15163 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
15164 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
15165 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
15166 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
15167 IF(J.LE.3*MSTP(1)) THEN
15168 C...Fermion loops: loop integral different for A0; charges.
15169 IF(IHIGG.EQ.3) FXYRE=0D0
15170 IF(IHIGG.EQ.3) FXYIM=0D0
15171 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
15173 EJH=PARU(151+10*IHIGG)
15174 ELSEIF(J.LE.2*MSTP(1)) THEN
15176 EJH=PARU(152+10*IHIGG)
15179 EJH=PARU(153+10*IHIGG)
15181 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
15182 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
15183 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
15184 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
15185 C...W loops: loop integral and charges.
15186 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
15187 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
15188 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
15189 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
15190 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
15191 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
15194 C...Charged H loops: loop integral and charges.
15195 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
15196 & PARU(158+10*IHIGG+2*(IHIGG/3))
15197 ETAREJ=FACHHH*FXYRE
15198 ETAIMJ=FACHHH*FXYIM
15203 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
15204 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
15207 ELSEIF(I.LE.17) THEN
15208 C...h0 -> Z0 + Z0, W+ + W-
15209 PM1=PMAS(IABS(KFDP(IDC,1)),1)
15210 PG1=PMAS(IABS(KFDP(IDC,1)),2)
15211 IF(MINT(62).GE.1) THEN
15212 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
15213 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
15214 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
15215 MOFSV(IHIGG,I-15)=0
15216 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
15220 MOFSV(IHIGG,I-15)=1
15221 RMAS=SQRT(MAX(0D0,SH))
15222 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
15224 WIDWSV(IHIGG,I-15)=WIDW
15225 WID2SV(IHIGG,I-15)=WID2
15228 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
15229 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
15233 WIDW=WIDWSV(IHIGG,I-15)
15234 WID2=WID2SV(IHIGG,I-15)
15237 WDTP(I)=FAC*WIDW/(2D0*(18-I))
15238 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
15239 & PARU(138+I+10*IHIGG)**2
15240 WID2=WID2*WIDS(7+I,1)
15242 ELSEIF(I.EQ.18.AND.KFLA.EQ.35) THEN
15243 C***H0 -> Z0 + h0 (not yet implemented).
15245 ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN
15247 WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2*
15248 & SQRT(MAX(0D0,1D0-4D0*RM1))
15251 ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN
15253 WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2*
15254 & SQRT(MAX(0D0,1D0-4D0*RM1))
15257 ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN
15259 WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0,
15260 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15261 WID2=WIDS(23,2)*WIDS(25,2)
15265 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
15268 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
15269 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
15270 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
15275 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
15277 IF(KFC2.EQ.KFC1) THEN
15281 IF(KFDP(IDC,1).LT.0) KSGN1=3
15283 IF(KFDP(IDC,2).LT.0) KSGN2=3
15284 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
15287 WDTP(0)=WDTP(0)+WDTP(I)
15288 IF(MDME(IDC,1).GT.0) THEN
15289 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15290 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15291 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15292 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15296 ELSEIF(KFLA.EQ.32) THEN
15299 XWC=1D0/(16D0*XW*XW1)
15300 FAC=(AEM*XWC/3D0)*SHR
15303 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
15311 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15312 KFAI=IABS(MINT(15))
15313 EI=KCHG(KFAI,1)/3D0
15314 AI=SIGN(1D0,EI+0.1D0)
15317 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
15318 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
15319 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
15320 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
15321 VPI=PARU(119+2*KFAIC)
15322 API=PARU(120+2*KFAIC)
15323 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
15324 VPI=PARJ(178+2*KFAIC)
15325 API=PARJ(179+2*KFAIC)
15327 VPI=PARJ(186+2*KFAIC)
15328 API=PARJ(187+2*KFAIC)
15332 SQMZP=PMAS(32,1)**2
15334 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
15335 & MSTP(44).EQ.7) VINT(111)=1D0
15336 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
15337 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
15338 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
15339 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
15340 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
15341 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
15342 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
15343 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
15344 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
15345 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
15346 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
15348 DO 280 I=1,MDCY(KC,3)
15350 IF(MDME(IDC,1).LT.0) GOTO 280
15351 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15352 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15353 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 280
15357 C...Z'0 -> q + qbar
15359 AF=SIGN(1D0,EF+0.1D0)
15362 VPF=PARU(123-2*MOD(I,2))
15363 APF=PARU(124-2*MOD(I,2))
15364 ELSEIF(I.LE.4) THEN
15365 VPF=PARJ(182-2*MOD(I,2))
15366 APF=PARJ(183-2*MOD(I,2))
15368 VPF=PARJ(190-2*MOD(I,2))
15369 APF=PARJ(191-2*MOD(I,2))
15372 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
15373 & PYHFTH(SH,SH*RM1,1D0)
15374 IF(I.EQ.6) WID2=WIDS(6,1)
15375 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
15376 ELSEIF(I.LE.16) THEN
15377 C...Z'0 -> l+ + l-, nu + nubar
15379 AF=SIGN(1D0,EF+0.1D0)
15382 VPF=PARU(127-2*MOD(I,2))
15383 APF=PARU(128-2*MOD(I,2))
15384 ELSEIF(I.LE.12) THEN
15385 VPF=PARJ(186-2*MOD(I,2))
15386 APF=PARJ(187-2*MOD(I,2))
15388 VPF=PARJ(194-2*MOD(I,2))
15389 APF=PARJ(195-2*MOD(I,2))
15392 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
15394 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
15395 IF(ICASE.EQ.1) THEN
15396 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
15397 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
15398 & APF**2*(1D0-4D0*RM1))*BE34
15399 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15400 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
15401 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
15402 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
15403 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
15404 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
15405 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
15406 ELSEIF(MINT(61).EQ.2) THEN
15407 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
15408 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
15409 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
15410 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
15411 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
15413 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
15416 ELSEIF(I.EQ.17) THEN
15418 WDTPZP=PARU(129)**2*XW1**2*
15419 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15420 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
15421 IF(ICASE.EQ.1) THEN
15424 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15425 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
15426 ELSEIF(MINT(61).EQ.2) THEN
15435 ELSEIF(I.EQ.18) THEN
15437 CZC=2D0*(1D0-2D0*XW)
15438 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
15439 IF(ICASE.EQ.1) THEN
15440 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
15441 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
15442 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15443 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
15444 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
15445 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
15446 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
15447 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
15448 ELSEIF(MINT(61).EQ.2) THEN
15450 FGZF=0.25D0*PARU(142)*CZC*BE34C
15451 FGZPF=0.25D0*PARU(143)*CZC*BE34C
15452 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
15453 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
15454 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
15457 ELSEIF(I.EQ.19) THEN
15458 C...Z'0 -> Z0 + gamma.
15459 ELSEIF(I.EQ.20) THEN
15461 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15462 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
15463 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
15464 IF(ICASE.EQ.1) THEN
15467 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15468 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
15469 ELSEIF(MINT(61).EQ.2) THEN
15477 WID2=WIDS(23,2)*WIDS(25,2)
15478 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
15479 C...Z' -> h0 + A0 or H0 + A0.
15480 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15488 IF(ICASE.EQ.1) THEN
15489 WDTPZ=CZAH**2*BE34C
15490 WDTP(I)=FAC*CZPAH**2*BE34C
15491 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15492 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
15493 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
15495 ELSEIF(MINT(61).EQ.2) THEN
15500 FZZPF=CZAH*CZPAH*BE34C
15501 FZPZPF=CZPAH**2*BE34C
15503 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
15504 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
15506 IF(ICASE.EQ.1) THEN
15507 VINT(117)=VINT(117)+FAC*WDTPZ
15508 WDTP(0)=WDTP(0)+WDTP(I)
15510 IF(MDME(IDC,1).GT.0) THEN
15511 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
15512 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
15513 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15514 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
15515 & WDTE(I,MDME(IDC,1))
15516 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15517 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15519 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
15520 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
15521 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
15522 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
15524 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
15526 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
15527 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
15528 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
15530 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
15531 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
15535 IF(MINT(61).GE.1) ICASE=3-ICASE
15536 IF(ICASE.EQ.2) GOTO 270
15538 ELSEIF(KFLA.EQ.34) THEN
15540 FAC=(AEM/(24D0*XW))*SHR
15541 DO 290 I=1,MDCY(KC,3)
15543 IF(MDME(IDC,1).LT.0) GOTO 290
15544 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15545 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15546 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 290
15550 C...W'+/- -> q + qbar'
15551 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
15552 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
15554 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
15555 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
15556 IF(I.GE.13) WID2=WID2*WIDS(7,3)
15558 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
15559 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
15560 IF(I.GE.13) WID2=WID2*WIDS(7,2)
15562 ELSEIF(I.LE.20) THEN
15563 C...W'+/- -> l+/- + nu
15564 FCOF=PARU(133)**2+PARU(134)**2
15566 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
15568 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
15571 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
15572 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15573 ELSEIF(I.EQ.21) THEN
15574 C...W'+/- -> W+/- + Z0
15575 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
15576 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15577 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
15578 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
15579 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
15580 ELSEIF(I.EQ.23) THEN
15581 C...W'+/- -> W+/- + h0
15582 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15583 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
15584 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
15585 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
15587 WDTP(0)=WDTP(0)+WDTP(I)
15588 IF(MDME(IDC,1).GT.0) THEN
15589 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15590 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15591 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15592 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15596 ELSEIF(KFLA.EQ.37) THEN
15598 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
15599 DO 300 I=1,MDCY(KC,3)
15601 IF(MDME(IDC,1).LT.0) GOTO 300
15602 KFC1=PYCOMP(KFDP(IDC,1))
15603 KFC2=PYCOMP(KFDP(IDC,2))
15604 RM1=PMAS(KFC1,1)**2/SH
15605 RM2=PMAS(KFC2,1)**2/SH
15606 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
15609 C...H+/- -> q + qbar'
15610 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
15611 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
15612 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
15613 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
15614 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15616 IF(I.EQ.3) WID2=WIDS(6,2)
15617 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
15619 IF(I.EQ.3) WID2=WIDS(6,3)
15620 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
15622 ELSEIF(I.LE.8) THEN
15623 C...H+/- -> l+/- + nu
15624 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
15625 & (1D0-RM1-RM2)-4D0*RM1*RM2)*
15626 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15628 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
15630 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
15632 ELSEIF(I.EQ.9) THEN
15633 C...H+/- -> W+/- + h0.
15634 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
15635 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15636 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
15637 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
15641 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
15644 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
15645 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
15646 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
15651 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
15654 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
15656 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
15657 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
15659 WDTP(0)=WDTP(0)+WDTP(I)
15660 IF(MDME(IDC,1).GT.0) THEN
15661 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15662 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15663 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15664 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15668 ELSEIF(KFLA.EQ.38) THEN
15670 FAC=(SH/PARP(46)**2)*SHR
15671 DO 310 I=1,MDCY(KC,3)
15673 IF(MDME(IDC,1).LT.0) GOTO 310
15674 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15675 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15676 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
15679 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
15680 IF(I.EQ.2) WID2=WIDS(6,1)
15682 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
15684 WDTP(0)=WDTP(0)+WDTP(I)
15685 IF(MDME(IDC,1).GT.0) THEN
15686 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15687 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15688 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15689 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15693 ELSEIF(KFLA.EQ.39) THEN
15694 C...LQ (leptoquark).
15695 FAC=(AEM/4D0)*PARU(151)*SHR
15696 DO 320 I=1,MDCY(KC,3)
15698 IF(MDME(IDC,1).LT.0) GOTO 320
15699 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15700 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15701 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
15702 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15704 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
15705 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
15706 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
15707 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
15708 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
15709 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
15710 WDTP(0)=WDTP(0)+WDTP(I)
15711 IF(MDME(IDC,1).GT.0) THEN
15712 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15713 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15714 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15715 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15719 ELSEIF(KFLA.EQ.40) THEN
15721 FAC=(AEM/(12D0*XW))*SHR
15722 DO 330 I=1,MDCY(KC,3)
15724 IF(MDME(IDC,1).LT.0) GOTO 330
15725 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15726 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15727 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
15732 ELSEIF(I.LE.9) THEN
15736 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
15737 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15739 IF(I.EQ.4) WID2=WIDS(6,3)
15740 IF(I.EQ.5) WID2=WIDS(7,3)
15741 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
15742 IF(I.EQ.9) WID2=WIDS(17,3)
15744 IF(I.EQ.4) WID2=WIDS(6,2)
15745 IF(I.EQ.5) WID2=WIDS(7,2)
15746 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
15747 IF(I.EQ.9) WID2=WIDS(17,2)
15749 WDTP(0)=WDTP(0)+WDTP(I)
15750 IF(MDME(IDC,1).GT.0) THEN
15751 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15752 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15753 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15754 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15758 ELSEIF(KFLA.EQ.51.OR.KFLA.EQ.53) THEN
15759 C...Techni-pi0 and techni-pi0':
15760 FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
15761 DO 340 I=1,MDCY(KC,3)
15763 IF(MDME(IDC,1).LT.0) GOTO 340
15764 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
15765 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
15768 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
15770 C...pi_tech -> g + g
15772 FACP=(AS/(4D0*PARU(1))*PARP(144)/PARP(142))**2
15773 & /(8D0*PARU(1))*SH*SHR
15774 IF(KFLA.EQ.51) THEN
15775 FACP=FACP*PARP(149)
15777 FACP=FACP*PARP(150)
15781 C...pi_tech -> f + fbar.
15783 IKA=IABS(KFDP(IDC,1))
15784 IF(IKA.LT.10) FCOF=3D0*RADC
15787 IF(IKA.GE.4.AND.IKA.LE.6) THEN
15788 FCOF=FCOF*PARP(141+IKA)**2
15789 HM1=PYMRUN(KFDP(IDC,1),SH)
15790 HM2=PYMRUN(KFDP(IDC,2),SH)
15791 ELSEIF(IKA.EQ.15) THEN
15792 FCOF=FCOF*PARP(148)**2
15794 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
15795 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15797 WDTP(0)=WDTP(0)+WDTP(I)
15798 IF(MDME(IDC,1).GT.0) THEN
15799 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15800 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15801 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15802 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15806 ELSEIF(KFLA.EQ.52) THEN
15808 FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
15809 DO 350 I=1,MDCY(KC,3)
15811 IF(MDME(IDC,1).LT.0) GOTO 350
15812 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
15813 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
15815 IF(I.EQ.3) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
15819 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
15821 C...pi_tech -> f + f'.
15823 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
15824 C...pi_tech+ -> W b b~
15825 IF(I.EQ.3.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
15827 XMT2=PMAS(6,1)**2/SH
15828 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*PARP(147)**2
15829 KFC3=PYCOMP(KFDP(IDC,3))
15830 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
15832 T0 = (1D0-CHECK**2)*
15833 & (XMT2*(6.*XMT2**2+3.*XMT2*RM1-4.*RM1**2)-
15834 & (5.*XMT2**2+2.*XMT2*RM1-8.*RM1**2))/(4.*XMT2**2)
15835 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4.*RM1**2)
15836 & -3.*XMT2**2*(XMT2+RM1))/(2.0*XMT2**3)
15837 T3 = RM1**2/XMT2**3*(3.0*XMT2-4.0*RM1+4.0*XMT2*RM1)
15838 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
15847 IKA=IABS(KFDP(IDC,1))
15848 IF(IKA.LT.10) FCOF=3D0*RADC
15851 IF(I.GE.1.AND.I.LE.3) THEN
15852 FCOF=FCOF*PARP(144+I)**2
15853 HM1=PYMRUN(KFDP(IDC,1),SH)
15854 HM2=PYMRUN(KFDP(IDC,2),SH)
15855 ELSEIF(I.EQ.6) THEN
15856 FCOF=FCOF*PARP(148)**2
15858 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
15859 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15861 WDTP(0)=WDTP(0)+WDTP(I)
15862 IF(MDME(IDC,1).GT.0) THEN
15863 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15864 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15865 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15866 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15870 ELSEIF(KFLA.EQ.54) THEN
15872 ALPRHT=2.91D0*(3D0/PARP(144))
15873 FAC=(ALPRHT/12D0)*SHR
15874 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
15878 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
15880 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
15881 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
15882 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
15883 DO 360 I=1,MDCY(KC,3)
15885 IF(MDME(IDC,1).LT.0) GOTO 360
15886 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15887 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15888 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
15891 C...rho_tech0 -> W+ + W-.
15892 WDTP(I)=FAC*PARP(141)**4*
15893 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15895 ELSEIF(I.EQ.2) THEN
15896 C...rho_tech0 -> W+ + pi_tech-.
15897 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
15898 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
15899 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15900 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
15901 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**3
15902 WID2=WIDS(24,2)*WIDS(52,3)
15903 ELSEIF(I.EQ.3) THEN
15904 C...rho_tech0 -> pi_tech+ + W-.
15905 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
15906 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
15907 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15908 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
15909 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**3
15910 WID2=WIDS(52,2)*WIDS(24,3)
15911 ELSEIF(I.EQ.4) THEN
15912 C...rho_tech0 -> pi_tech+ + pi_tech-.
15913 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
15914 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15916 ELSEIF(I.EQ.5) THEN
15917 C...rho_tech0 -> gamma + pi_tech0
15918 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15919 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
15922 ELSEIF(I.EQ.6) THEN
15923 C...rho_tech0 -> gamma + pi_tech0'
15924 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15925 & (1D0-PARJ(174)**2)/24D0/PARJ(172)**2*SHR**3
15927 ELSEIF(I.EQ.7) THEN
15928 C...rho_tech0 -> Z0 + pi_tech0
15929 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15930 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
15932 WID2=WIDS(23,2)*WIDS(51,2)
15933 ELSEIF(I.EQ.8) THEN
15934 C...rho_tech0 -> Z0 + pi_tech0'
15935 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15936 & (1D0-PARJ(174)**2)/24D0/PARJ(172)**2*(1D0-2D0*XW)**2/4D0/
15938 WID2=WIDS(23,2)*WIDS(53,2)
15940 C...rho_tech0 -> f + fbar.
15945 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
15949 IF(IA.GE.17) WID2=WIDS(IA,1)
15952 AI=SIGN(1D0,EI+0.1D0)
15956 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
15957 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
15958 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
15959 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
15961 WDTP(0)=WDTP(0)+WDTP(I)
15962 IF(MDME(IDC,1).GT.0) THEN
15963 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15964 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15965 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15966 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15970 ELSEIF(KFLA.EQ.55) THEN
15972 ALPRHT=2.91D0*(3D0/PARP(144))
15973 FAC=(ALPRHT/12D0)*SHR
15977 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
15979 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
15980 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
15981 DO 370 I=1,MDCY(KC,3)
15983 IF(MDME(IDC,1).LT.0) GOTO 370
15984 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15985 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15986 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
15989 C...rho_tech+ -> W+ + Z0.
15990 WDTP(I)=FAC*PARP(141)**4*
15991 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15993 WID2=WIDS(24,2)*WIDS(23,2)
15995 WID2=WIDS(24,3)*WIDS(23,2)
15997 ELSEIF(I.EQ.2) THEN
15998 C...rho_tech+ -> W+ + pi_tech0.
15999 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
16000 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
16001 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16002 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
16003 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**3
16005 WID2=WIDS(24,2)*WIDS(51,2)
16007 WID2=WIDS(24,3)*WIDS(51,2)
16009 ELSEIF(I.EQ.3) THEN
16010 C...rho_tech+ -> pi_tech+ + Z0.
16011 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
16012 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
16013 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16014 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
16015 & (1D0-PARP(141)**2)/4D0/XW/XW1/24D0/PARJ(173)**2*SHR**3+
16016 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16017 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
16020 WID2=WIDS(52,2)*WIDS(23,2)
16022 WID2=WIDS(52,3)*WIDS(23,2)
16024 ELSEIF(I.EQ.4) THEN
16025 C...rho_tech+ -> pi_tech+ + pi_tech0.
16026 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
16027 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16029 WID2=WIDS(52,2)*WIDS(51,2)
16031 WID2=WIDS(52,3)*WIDS(51,2)
16033 ELSEIF(I.EQ.5) THEN
16034 C...rho_tech+ -> pi_tech+ + gamma
16035 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16036 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
16043 ELSEIF(I.EQ.6) THEN
16044 C...rho_tech+ -> W+ + pi_tech0'
16045 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16046 & (1D0-PARJ(174)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3
16048 WID2=WIDS(24,2)*WIDS(53,2)
16050 WID2=WIDS(24,3)*WIDS(53,2)
16053 C...rho_tech+ -> f + fbar'.
16057 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
16059 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
16060 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
16061 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
16063 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
16064 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
16065 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
16070 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16072 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16075 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16076 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16078 WDTP(0)=WDTP(0)+WDTP(I)
16079 IF(MDME(IDC,1).GT.0) THEN
16080 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16081 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16082 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16083 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16087 ELSEIF(KFLA.EQ.56) THEN
16089 ALPRHT=2.91D0*(3D0/PARP(144))
16090 FAC=(ALPRHT/12D0)*SHR
16091 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*PARP(143)-1D0)**2
16094 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
16096 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
16097 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
16098 DO 380 I=1,MDCY(KC,3)
16100 IF(MDME(IDC,1).LT.0) GOTO 380
16101 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16102 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16103 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
16106 C...omega_tech0 -> gamma + pi_tech0.
16107 WDTP(I)=AEM/24D0/PARJ(172)**2*(1D0-PARP(141)**2)*
16108 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
16110 ELSEIF(I.EQ.2) THEN
16111 C...omega_tech0 -> Z0 + pi_tech0
16112 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16113 & (1D0-PARP(141)**2)/24D0/PARJ(172)**2*(1D0-2D0*XW)**2/4D0/
16115 WID2=WIDS(23,2)*WIDS(51,2)
16116 ELSEIF(I.EQ.3) THEN
16117 C...omega_tech0 -> gamma + pi_tech0'
16118 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16119 & (2D0*PARP(143)-1D0)**2*(1D0-PARJ(174)**2)/24D0/PARJ(172)**2*
16122 ELSEIF(I.EQ.4) THEN
16123 C...omega_tech0 -> Z0 + pi_tech0'
16124 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16125 & (2D0*PARP(143)-1D0)**2*(1D0-PARJ(174)**2)/24D0/PARJ(172)**2*
16127 WID2=WIDS(23,2)*WIDS(51,2)
16128 ELSEIF(I.EQ.5) THEN
16129 C...omega_tech0 -> W+ + pi_tech-
16130 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16131 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3+
16132 & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARJ(175)**2*
16133 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16134 WID2=WIDS(24,2)*WIDS(52,3)
16135 ELSEIF(I.EQ.6) THEN
16136 C...omega_tech0 -> pi_tech+ + W-
16137 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16138 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3+
16139 & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARJ(175)**2*
16140 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16141 WID2=WIDS(24,3)*WIDS(52,2)
16142 ELSEIF(I.EQ.7) THEN
16143 C...omega_tech0 -> W+ + W-.
16144 WDTP(I)=FAC*PARP(141)**4*PARJ(175)**2*
16145 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16147 ELSEIF(I.EQ.8) THEN
16148 C...omega_tech0 -> pi_tech+ + pi_tech-.
16149 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*PARJ(175)**2*
16150 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16153 C...omega_tech0 -> f + fbar.
16158 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
16162 IF(IA.GE.17) WID2=WIDS(IA,1)
16165 AI=SIGN(1D0,EI+0.1D0)
16169 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
16170 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
16171 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
16172 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
16174 WDTP(0)=WDTP(0)+WDTP(I)
16175 IF(MDME(IDC,1).GT.0) THEN
16176 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16177 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16178 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16179 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16183 ELSEIF(KFLA.EQ.61) THEN
16185 FAC=(1D0/(8D0*PARU(1)))*SHR
16186 DO 372 I=1,MDCY(KC,3)
16188 IF(MDME(IDC,1).LT.0) GOTO 372
16189 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16190 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16191 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 372
16194 C...H_L++/-- -> l+/- + l'+/-
16195 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
16196 & (IABS(KFDP(IDC,2))-9)/2)**2
16197 C***Should be factor 4 below ???
16198 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
16199 ELSEIF(I.EQ.7) THEN
16200 C...H_L++/-- -> W_L+/- + W_L+/-
16201 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
16202 & (3D0*RM1+0.25D0/RM1-1D0)
16203 WID2=WIDS(24,4+(1-KFLS)/2)
16206 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16207 WDTP(0)=WDTP(0)+WDTP(I)
16208 IF(MDME(IDC,1).GT.0) THEN
16209 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16210 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16211 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16212 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16216 ELSEIF(KFLA.EQ.62) THEN
16218 FAC=(1D0/(8D0*PARU(1)))*SHR
16219 DO 373 I=1,MDCY(KC,3)
16221 IF(MDME(IDC,1).LT.0) GOTO 373
16222 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16223 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16224 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 373
16227 C...H_R++/-- -> l+/- + l'+/-
16228 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
16229 & (IABS(KFDP(IDC,2))-9)/2)**2
16230 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
16231 ELSEIF(I.EQ.7) THEN
16232 C...H_R++/-- -> W_R+/- + W_R+/-
16233 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
16234 WID2=WIDS(63,4+(1-KFLS)/2)
16237 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16238 WDTP(0)=WDTP(0)+WDTP(I)
16239 IF(MDME(IDC,1).GT.0) THEN
16240 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16241 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16242 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16243 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16247 ELSEIF(KFLA.EQ.63) THEN
16249 FAC=(AEM/(24D0*XW))*SHR
16250 DO 374 I=1,MDCY(KC,3)
16252 IF(MDME(IDC,1).LT.0) GOTO 374
16253 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16254 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16255 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 374
16258 C...W_R+/- -> q + qbar'
16259 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
16261 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
16263 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
16265 ELSEIF(I.LE.12) THEN
16266 C...W_R+/- -> l+/- + nu_R
16269 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16270 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16271 WDTP(0)=WDTP(0)+WDTP(I)
16272 IF(MDME(IDC,1).GT.0) THEN
16273 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16274 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16275 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16276 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16280 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
16281 C...d* excited quark.
16282 FAC=(SH/PARU(155)**2)*SHR
16283 DO 390 I=1,MDCY(KC,3)
16285 IF(MDME(IDC,1).LT.0) GOTO 390
16286 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16287 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16288 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
16292 WDTP(I)=FAC*AS*PARU(159)**2/3D0
16294 ELSEIF(I.EQ.2) THEN
16295 C...d* -> gamma + d.
16296 QF=-PARU(157)/2D0+PARU(158)/6D0
16297 WDTP(I)=FAC*AEM*QF**2/4D0
16299 ELSEIF(I.EQ.3) THEN
16301 QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
16302 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
16303 & (1D0-RM1)**2*(2D0+RM1)
16305 ELSEIF(I.EQ.4) THEN
16307 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
16308 & (1D0-RM1)**2*(2D0+RM1)
16309 IF(KFLR.GT.0) WID2=WIDS(24,3)
16310 IF(KFLR.LT.0) WID2=WIDS(24,2)
16312 WDTP(0)=WDTP(0)+WDTP(I)
16313 IF(MDME(IDC,1).GT.0) THEN
16314 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16315 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16316 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16317 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16321 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
16322 C...u* excited quark.
16323 FAC=(SH/PARU(155)**2)*SHR
16324 DO 400 I=1,MDCY(KC,3)
16326 IF(MDME(IDC,1).LT.0) GOTO 400
16327 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16328 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16329 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 400
16333 WDTP(I)=FAC*AS*PARU(159)**2/3D0
16335 ELSEIF(I.EQ.2) THEN
16336 C...u* -> gamma + u.
16337 QF=PARU(157)/2D0+PARU(158)/6D0
16338 WDTP(I)=FAC*AEM*QF**2/4D0
16340 ELSEIF(I.EQ.3) THEN
16342 QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
16343 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
16344 & (1D0-RM1)**2*(2D0+RM1)
16346 ELSEIF(I.EQ.4) THEN
16348 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
16349 & (1D0-RM1)**2*(2D0+RM1)
16350 IF(KFLR.GT.0) WID2=WIDS(24,2)
16351 IF(KFLR.LT.0) WID2=WIDS(24,3)
16353 WDTP(0)=WDTP(0)+WDTP(I)
16354 IF(MDME(IDC,1).GT.0) THEN
16355 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16356 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16357 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16358 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16362 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
16363 C...e* excited lepton.
16364 FAC=(SH/PARU(155)**2)*SHR
16365 DO 410 I=1,MDCY(KC,3)
16367 IF(MDME(IDC,1).LT.0) GOTO 410
16368 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16369 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16370 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
16373 C...e* -> gamma + e.
16374 QF=-PARU(157)/2D0-PARU(158)/2D0
16375 WDTP(I)=FAC*AEM*QF**2/4D0
16377 ELSEIF(I.EQ.2) THEN
16379 QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
16380 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
16381 & (1D0-RM1)**2*(2D0+RM1)
16383 ELSEIF(I.EQ.3) THEN
16385 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
16386 & (1D0-RM1)**2*(2D0+RM1)
16387 IF(KFLR.GT.0) WID2=WIDS(24,3)
16388 IF(KFLR.LT.0) WID2=WIDS(24,2)
16390 WDTP(0)=WDTP(0)+WDTP(I)
16391 IF(MDME(IDC,1).GT.0) THEN
16392 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16393 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16394 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16395 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16399 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
16400 C...nu*_e excited neutrino.
16401 FAC=(SH/PARU(155)**2)*SHR
16402 DO 420 I=1,MDCY(KC,3)
16404 IF(MDME(IDC,1).LT.0) GOTO 420
16405 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16406 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16407 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
16410 C...nu*_e -> Z0 + nu*_e.
16411 QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
16412 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
16413 & (1D0-RM1)**2*(2D0+RM1)
16415 ELSEIF(I.EQ.2) THEN
16416 C...nu*_e -> W+ + e.
16417 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
16418 & (1D0-RM1)**2*(2D0+RM1)
16419 IF(KFLR.GT.0) WID2=WIDS(24,2)
16420 IF(KFLR.LT.0) WID2=WIDS(24,3)
16422 WDTP(0)=WDTP(0)+WDTP(I)
16423 IF(MDME(IDC,1).GT.0) THEN
16424 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16425 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16426 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16427 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16439 C***********************************************************************
16442 C...Calculates full and partial widths of resonances.
16443 C....copy of PYWIDT, used for techniparticle widths
16445 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
16447 C...Double precision and integer declarations.
16448 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16449 IMPLICIT INTEGER(I-N)
16450 INTEGER PYK,PYCHGE,PYCOMP
16451 C...Parameter statement to help give large particle numbers.
16452 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
16454 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16455 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16456 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
16457 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16458 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16459 COMMON/PYINT1/MINT(400),VINT(400)
16460 COMMON/PYINT4/MWID(500),WIDS(500,5)
16461 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
16462 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
16464 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16465 &/PYINT4/,/PYMSSM/,/PYSSMT/
16466 C...Local arrays and saved variables.
16467 DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
16469 SAVE MOFSV,WIDWSV,WID2SV
16470 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
16472 C...Compressed code and sign; mass.
16479 C...Reset width information.
16487 C...Common electroweak and strong constants.
16490 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16493 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16495 RADC=1D0+AS/PARU(1)
16497 IF(KFLA.EQ.23) THEN
16500 XWC=1D0/(16D0*XW*XW1)
16501 FAC=(AEM*XWC/3D0)*SHR
16503 DO 210 I=1,MDCY(KC,3)
16505 IF(MDME(IDC,1).LT.0) GOTO 210
16506 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16507 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16508 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
16513 AF=SIGN(1D0,EF+0.1D0)
16516 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16517 IF(I.EQ.6) WID2=WIDS(6,1)
16518 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16519 ELSEIF(I.LE.16) THEN
16520 C...Z0 -> l+ + l-, nu + nubar
16522 AF=SIGN(1D0,EF+0.1D0)
16525 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16527 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16528 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16530 WDTP(0)=WDTP(0)+WDTP(I)
16531 IF(MDME(IDC,1).GT.0) THEN
16532 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16533 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16534 & WDTE(I,MDME(IDC,1))
16535 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16536 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16541 ELSEIF(KFLA.EQ.24) THEN
16543 FAC=(AEM/(24D0*XW))*SHR
16544 DO 220 I=1,MDCY(KC,3)
16546 IF(MDME(IDC,1).LT.0) GOTO 220
16547 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16548 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16549 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16552 C...W+/- -> q + qbar'
16553 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16555 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16556 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16557 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16559 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16560 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16561 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16563 ELSEIF(I.LE.20) THEN
16564 C...W+/- -> l+/- + nu
16567 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16569 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16572 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16573 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16574 WDTP(0)=WDTP(0)+WDTP(I)
16575 IF(MDME(IDC,1).GT.0) THEN
16576 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16577 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16578 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16579 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16587 C***********************************************************************
16590 C...Calculates partial width and differential cross-section maxima
16591 C...of channels/processes not allowed on mass-shell, and selects
16592 C...masses in such channels/processes.
16594 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
16596 C...Double precision and integer declarations.
16597 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16598 IMPLICIT INTEGER(I-N)
16599 INTEGER PYK,PYCHGE,PYCOMP
16601 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16602 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16603 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
16604 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16605 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16606 COMMON/PYINT1/MINT(400),VINT(400)
16607 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16608 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
16609 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16612 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
16613 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
16614 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:200),
16617 C...Find if particles equal, maximum mass, matrix elements, etc.
16623 IF(KFD(1).EQ.KFD(2)) MEQL=1
16625 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
16626 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
16632 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
16635 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
16636 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
16637 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
16638 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
16639 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
16640 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
16643 C...Find where Breit-Wigners are required, else select discrete masses.
16645 KFCA=PYCOMP(KFD(I))
16647 PMD(I)=PMAS(KFCA,1)
16648 PGD(I)=PMAS(KFCA,2)
16653 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
16656 RMG(I)=(PMG(I)/PMMX)**2
16662 C...Find allowed mass range and Breit-Wigner parameters.
16664 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
16666 PMU(I)=PMMX-PARP(42)
16667 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
16668 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
16669 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
16671 IF(MLM.EQ.2) ILM=3-I
16672 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
16673 IF(MBW(3-I).EQ.0) THEN
16674 PMU(I)=PMMX-PMD(3-I)
16676 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
16678 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
16679 & MIN(PMU(I),CKIN(NOFF+2*ILM))
16680 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
16681 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
16682 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
16683 IF(MBW(I).EQ.1) THEN
16684 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
16685 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
16686 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
16689 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
16691 IF(MLM.EQ.2) ILM=3-I
16692 PML(I)=MAX(CKIN(48+I),PARP(42))
16693 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
16694 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
16695 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
16696 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
16697 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
16698 IF(MBW(I).EQ.1) THEN
16699 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
16700 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
16701 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
16706 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
16708 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
16713 C...Calculation of partial width of resonance.
16714 IF(MOFSH.EQ.1) THEN
16716 C..If only one integration, pick that to be the inner.
16717 IF(MBW(1).EQ.0) THEN
16723 ELSEIF(MBW(2).EQ.0) THEN
16727 C...Start outer loop of integration.
16728 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
16729 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
16730 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
16736 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
16737 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
16738 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
16742 C...Start inner loop of integration.
16744 PMU1=MIN(PMU(1),PMMX-PM2)
16745 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
16746 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
16747 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
16748 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
16756 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
16757 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
16760 C...Evaluate function value - inner loop.
16761 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16762 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
16763 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
16764 & RM2**2+10D0*RM1*RM2)
16765 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
16768 C...Go to next position in inner loop.
16774 ELSEIF(NPT1.LE.8) THEN
16776 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
16778 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
16779 INX1(NPT1)=INX1(ISH1)
16782 ELSEIF(NPT1.LT.100) THEN
16785 IF(ISH1.GT.NPT1) ISH1=2
16786 IF(ISH1.EQ.ISN1) GOTO 160
16787 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
16788 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
16790 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
16791 INX1(NPT1)=INX1(ISH1)
16796 C...Calculate integral over inner loop.
16799 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
16800 & (XPT1(INX1(IPT1))-XPT1(IPT1))
16802 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
16803 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
16804 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
16807 C...Go to next position in outer loop.
16813 ELSEIF(NPT2.LE.8) THEN
16815 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
16817 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
16818 INX2(NPT2)=INX2(ISH2)
16821 ELSEIF(NPT2.LT.100) THEN
16824 IF(ISH2.GT.NPT2) ISH2=2
16825 IF(ISH2.EQ.ISN2) GOTO 200
16826 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
16827 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
16829 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
16830 INX2(NPT2)=INX2(ISH2)
16835 C...Calculate integral over outer loop.
16838 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
16839 & (XPT2(INX2(IPT2))-XPT2(IPT2))
16841 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
16842 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
16847 C...Save result; second integration for user-selected mass range.
16848 IF(LOOP.EQ.1) WIDW=FSUM2
16850 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
16851 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
16858 C...Select two decay product masses of a resonance.
16859 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
16861 IF(MBW(I).EQ.0) GOTO 230
16862 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
16864 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
16865 RMG(I)=(PMG(I)/PMMX)**2
16867 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
16868 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
16870 C...Weight with matrix element (if none known, use beta factor).
16871 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
16873 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
16874 ELSEIF(MMED.EQ.2) THEN
16875 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
16876 & RMG(2)**2+10D0*RMG(1)*RMG(2))
16877 ELSEIF(MMED.EQ.3) THEN
16878 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
16882 IF(WTBE.LT.PYR(0)) GOTO 220
16886 C...Find suitable set of masses for initialization of 2 -> 2 processes.
16887 ELSEIF(MOFSH.EQ.3) THEN
16888 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
16889 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
16891 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
16893 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
16897 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
16898 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
16899 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
16904 C...Evaluate importance of excluded tails of Breit-Wigners.
16905 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
16906 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
16910 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
16914 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
16915 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
16917 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
16918 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
16919 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
16920 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
16922 C...Pick one particle to be the lighter (if improves efficiency).
16923 ELSEIF(MOFSH.EQ.4) THEN
16924 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
16925 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
16926 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
16928 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
16930 IF(MBW(I).EQ.0) GOTO 270
16932 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
16934 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
16936 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
16937 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
16938 IF(RBR.LT.0.8D0) THEN
16939 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
16940 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
16941 ELSEIF(RBR.LT.0.9D0) THEN
16942 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
16943 ELSEIF(RBR.LT.1.5D0) THEN
16944 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
16946 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
16947 & (PMV**2-PML(I)**2))))
16950 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
16951 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
16952 IF(MINT(48).EQ.1) THEN
16953 NGEN(0,1)=NGEN(0,1)+1
16954 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
16964 C...Give weight for selected mass distribution.
16967 IF(MBW(I).EQ.0) GOTO 280
16969 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
16971 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
16972 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
16973 & (PMD(I)*PGD(I))**2)/PARU(1)
16977 FI0=(ATV-ATL(I))/PARU(1)
16978 FI1=PMV**2-PML(I)**2
16979 FI2=2D0*LOG(PMV/PML(I))
16980 FI3=1D0/PML(I)**2-1D0/PMV**2
16981 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
16982 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
16983 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
16986 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
16988 VINT(80)=VINT(80)*FI0
16990 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
16996 C***********************************************************************
16999 C...Handles the possibility of colour reconnection in W+W- events,
17000 C...Based on the main scenarios of the Sjostrand and Khoze study:
17001 C...I, II, II', intermediate and instantaneous; plus one model
17002 C...along the lines of the Gustafson and Hakkinen: GH.
17003 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
17004 C...is as if first resonance is W+ and second W-.
17006 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
17008 C...Double precision and integer declarations.
17009 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17010 IMPLICIT INTEGER(I-N)
17011 INTEGER PYK,PYCHGE,PYCOMP
17012 C...Parameter value; number of points in MC integration.
17013 PARAMETER (NPT=100)
17015 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17016 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17017 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17018 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17019 COMMON/PYINT1/MINT(400),VINT(400)
17020 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
17022 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
17023 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
17024 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
17025 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
17026 &TMC(20),IJOIN(100)
17028 C...Functions to give four-product and to do determinants.
17029 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)
17030 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
17031 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
17032 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
17034 C...Only allow fraction of recoupling for GH, intermediate and
17036 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
17037 IF(PYR(0).GT.PARP(120)) RETURN
17041 C...Common part for scenarios I, II, II', and GH.
17042 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
17043 &MSTP(115).EQ.5) THEN
17045 C...Read out frequently-used parameters.
17049 IF(ISUB.EQ.22) PMW=PMAS(23,1)
17051 IF(ISUB.EQ.22) PGW=PMAS(23,2)
17058 C...Find range of decay products of the W's.
17059 C...Background: the W's are stored in IW1 and IW2.
17060 C...Their direct decay products in NSD1+1 through NSD1+4.
17061 C...Products after shower (if any) in NSD1+5 through NAFT1
17062 C...for first W and in NAFT1+1 through N for the second.
17063 IF(NAFT1.GT.NSD1+4) THEN
17070 IF(N.GT.NAFT1) THEN
17078 C...Rearrange parton shower products along strings.
17080 CALL PYPREP(NSD1+1)
17082 C...Find partons pointing back to W+ and W-; store them with quark
17083 C...end of string first.
17089 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
17090 IF(IABS(K(I,2)).GE.22) GOTO 120
17091 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
17092 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
17102 IF(K(I,1).EQ.1) ISGP=0
17103 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
17104 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
17114 IF(K(I,1).EQ.1) ISGM=0
17118 C...Boost to W+W- rest frame (not strictly needed).
17120 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
17122 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
17123 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
17124 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
17126 C...Select decay vertices of W+ and W-.
17127 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
17128 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
17129 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
17130 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
17133 XP(J)=TP*P(IW1,J)/P(IW1,4)
17134 XM(J)=TM*P(IW2,J)/P(IW2,4)
17137 C...Begin scenario I specifics.
17138 IF(MSTP(115).EQ.1) THEN
17140 C...Reconstruct velocity and direction of W+ string pieces.
17142 IF(K(INP(IIP),2).LT.0) GOTO 170
17145 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
17146 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
17150 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
17151 DIRP(IIP,J)=V1(J)-V2(J)
17153 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
17155 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
17157 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
17161 C...Reconstruct velocity and direction of W- string pieces.
17163 IF(K(INM(IIM),2).LT.0) GOTO 200
17166 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
17167 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
17171 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
17172 DIRM(IIM,J)=V1(J)-V2(J)
17174 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
17176 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
17178 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
17182 C...Loop over number of space-time points.
17187 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
17188 R=SQRT(-LOG(PYR(0)))
17190 X=BLOWR*RHAD*R*COS(PHI)
17191 Y=BLOWR*RHAD*R*SIN(PHI)
17192 R=SQRT(-LOG(PYR(0)))
17194 Z=BLOWR*RHAD*R*COS(PHI)
17195 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
17197 C...Weight for sample distribution.
17198 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
17199 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
17201 C...Loop over W+ string pieces and find one with largest weight.
17209 IF(K(INP(IIP),2).LT.0) GOTO 220
17210 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
17211 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
17213 XB(J)=XD(J)+BEDG*BETP(IIP,J)
17215 XB(4)=BETP(IIP,4)*(XD(4)-BED)
17216 SR2=XB(1)**2+XB(2)**2+XB(3)**2
17217 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
17218 & DIRP(IIP,3)*XB(3))**2
17219 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
17221 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
17222 IF(WTP.GT.WTMAXP) THEN
17228 C...Loop over W- string pieces and find one with largest weight.
17236 IF(K(INM(IIM),2).LT.0) GOTO 240
17237 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
17238 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
17240 XB(J)=XD(J)+BEDG*BETM(IIM,J)
17242 XB(4)=BETM(IIM,4)*(XD(4)-BED)
17243 SR2=XB(1)**2+XB(2)**2+XB(3)**2
17244 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
17245 & DIRM(IIM,3)*XB(3))**2
17246 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
17248 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
17249 IF(WTM.GT.WTMAXM) THEN
17255 C...Result of integration.
17257 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
17258 WT=WTMAXP*WTMAXM/WTSMP
17266 RES=BLOWR**3*BLOWT*SUM/NPT
17268 C...Decide whether to reconnect and, if so, where.
17270 PREC=1D0-EXP(-FACT*RES)
17271 IF(PREC.GT.PYR(0)) THEN
17276 IF(RSUM.LE.0D0) GOTO 270
17282 C...Begin scenario II and II' specifics.
17283 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
17285 C...Loop through all string pieces, one from W+ and one from W-.
17289 IF(K(INP(IIP),2).LT.0) GOTO 340
17293 IF(K(INM(IIM),2).LT.0) GOTO 330
17297 C...Find endpoint velocity vectors.
17299 V1P(J)=P(I1P,J)/P(I1P,4)
17300 V2P(J)=P(I2P,J)/P(I2P,4)
17301 V1M(J)=P(I1M,J)/P(I1M,4)
17302 V2M(J)=P(I2M,J)/P(I2M,4)
17305 C...Define q matrix and find t.
17307 Q(1,J)=V2P(J)-V1P(J)
17308 Q(2,J)=-(V2M(J)-V1M(J))
17309 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
17310 Q(4,J)=V1P(J)-V1M(J)
17312 T=-DETER(1,2,3)/DETER(1,2,4)
17314 C...Find alpha and beta; i.e. coordinates of crossing point.
17317 S13=Q(3,1)+Q(4,1)*T
17320 S23=Q(3,2)+Q(4,2)*T
17321 DEN=S11*S22-S12*S21
17322 ALP=(S12*S23-S22*S13)/DEN
17323 BET=(S21*S13-S11*S23)/DEN
17325 C...Check if solution acceptable.
17327 IF(T.LT.GTMAX) IANSW=0
17328 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
17329 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
17331 C...Find point of crossing and check that not inconsistent.
17333 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
17334 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
17336 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
17337 & (XPP(3)-XMM(3))**2
17338 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
17339 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
17340 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
17342 C...Find string eigentimes at crossing.
17343 IF(IANSW.EQ.1) THEN
17344 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
17345 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
17346 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
17347 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
17353 C...Order crossings by time. End loop over crossings.
17354 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
17356 DO 310 I1=NCROSS,1,-1
17357 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
17377 C...Loop over crossings; find first (if any) acceptable one.
17379 IF(NCROSS.GE.1) THEN
17381 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
17382 IF(PNFRAG.GT.PYR(0)) THEN
17383 C...Scenario II: only compare with fragmentation time.
17384 IF(MSTP(115).EQ.2) THEN
17389 C...Scenario II': also require that string length decreases.
17397 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
17398 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
17399 IF(ELNEW.LT.ELOLD) THEN
17411 C...Begin scenario GH specifics.
17412 ELSEIF(MSTP(115).EQ.5) THEN
17414 C...Loop through all string pieces, one from W+ and one from W-.
17418 IF(K(INP(IIP),2).LT.0) GOTO 380
17422 IF(K(INM(IIM),2).LT.0) GOTO 370
17426 C...Look for largest decrease of (exponent of) Lambda measure.
17427 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
17428 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
17429 ELDIF=ELNEW/MAX(1D-10,ELOLD)
17430 IF(ELDIF.LT.ELMIN) THEN
17442 C...Common for scenarios I, II, II' and GH: reconnect strings.
17446 DO 390 IS=1,NNP+NNM
17450 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
17452 ELSEIF(IS.LE.IIP+NNM) THEN
17453 I=INM(IS-IIP-NNM+IIM)
17458 IF(K(I,2).LT.0) THEN
17459 CALL PYJOIN(NJOIN,IJOIN)
17464 C...Restore original event record if no reconnection.
17466 DO 400 I=NSD1+1,NOLD
17467 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
17468 K(I,4)=MOD(K(I,4),MSTU(5)**2)
17469 K(I,5)=MOD(K(I,5),MSTU(5)**2)
17478 C...Boost back system.
17479 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
17480 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
17481 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
17482 & BEWW(1),BEWW(2),BEWW(3))
17484 C...Common part for intermediate and instantaneous scenarios.
17485 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
17488 C...Remove old shower products and reset showering ones.
17490 DO 420 I=NSD1+1,NSD1+4
17492 K(I,4)=MOD(K(I,4),MSTU(5)**2)
17493 K(I,5)=MOD(K(I,5),MSTU(5)**2)
17496 C...Identify quark-antiquark pairs.
17500 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
17503 C...Reconnect strings.
17506 CALL PYJOIN(2,IJOIN)
17509 CALL PYJOIN(2,IJOIN)
17511 C...Do new parton showers in intermediate scenario.
17512 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
17515 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
17516 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
17519 C...Do new parton showers in instantaneous scenario.
17520 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
17521 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
17522 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
17523 PPM=SQRT(MAX(0D0,PPM2))
17524 CALL PYSHOW(IQ1,IQ4,PPM)
17525 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
17526 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
17527 PPM=SQRT(MAX(0D0,PPM2))
17528 CALL PYSHOW(IQ3,IQ2,PPM)
17535 C***********************************************************************
17538 C...Checks generated variables against pre-set kinematical limits;
17539 C...also calculates limits on variables used in generation.
17541 SUBROUTINE PYKLIM(ILIM)
17543 C...Double precision and integer declarations.
17544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17545 IMPLICIT INTEGER(I-N)
17546 INTEGER PYK,PYCHGE,PYCOMP
17548 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17550 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17551 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
17552 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17553 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17554 COMMON/PYINT1/MINT(400),VINT(400)
17555 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17556 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
17559 C...Common kinematical expressions.
17563 IF(ISUB.EQ.96) GOTO 100
17567 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
17568 CKIN09=MAX(CKIN(9),CKIN(13))
17569 CKIN10=MIN(CKIN(10),CKIN(14))
17570 CKIN11=MAX(CKIN(11),CKIN(15))
17571 CKIN12=MIN(CKIN(12),CKIN(16))
17573 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
17574 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
17575 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
17576 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
17581 RM3=SQM3/(TAU*VINT(2))
17582 RM4=SQM4/(TAU*VINT(2))
17583 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17586 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
17587 &PTHMIN=MAX(CKIN(3),CKIN(5))
17590 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
17591 C...pre-set kinematical limits.
17596 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
17597 X1=SQRT(TAUE)*EXP(YST)
17598 X2=SQRT(TAUE)*EXP(-YST)
17600 IF(MINT(47).NE.1) THEN
17601 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
17602 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
17603 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
17604 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
17606 IF(MINT(45).NE.1) THEN
17607 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
17609 IF(MINT(46).NE.1) THEN
17610 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
17612 IF(MINT(45).EQ.2) THEN
17613 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
17615 IF(MINT(46).EQ.2) THEN
17616 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
17618 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
17619 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
17620 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
17621 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
17622 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
17623 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
17624 Y3=YST+0.5D0*LOG(EXPY3)
17625 Y4=YST+0.5D0*LOG(EXPY4)
17630 STH=SQRT(MAX(0D0,1D0-CTH**2))
17631 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
17632 & CTH)**2-4D0*RM3))
17633 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
17634 & CTH)**2-4D0*RM4))
17635 IF(STH.GE.1D-10) THEN
17636 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
17638 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
17640 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
17641 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
17642 ETALAR=MAX(ETA3,ETA4)
17643 ETASMA=MIN(ETA3,ETA4)
17645 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
17646 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
17647 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
17648 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
17650 RPTS=4D0*VINT(71)**2/SH
17651 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
17652 RM34=MAX(1D-20,2D0*RM3*RM4)
17653 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
17654 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
17655 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
17656 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
17657 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
17658 IF(PTH.LT.PTHMIN) MINT(51)=1
17659 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
17660 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
17661 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
17662 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
17663 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
17664 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
17665 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
17666 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
17667 IF(THA.LT.CKIN(35)) MINT(51)=1
17668 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
17669 IF(UHA.LT.CKIN(37)) MINT(51)=1
17670 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
17672 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
17673 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
17674 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
17677 C...Additional cuts on W2 (approximately) in DIS.
17678 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
17680 IF(IABS(MINT(12)).LT.20) XBJ=X1
17682 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
17683 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
17684 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
17687 ELSEIF(ILIM.EQ.1) THEN
17688 C...Calculate limits on tau
17689 C...0) due to definition
17692 C...1) due to limits on subsystem mass
17693 TAUMN1=CKIN(1)**2/VINT(2)
17695 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
17696 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
17697 TM3=SQRT(SQM3+PTHMIN**2)
17698 TM4=SQRT(SQM4+PTHMIN**2)
17700 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
17701 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
17703 C...3) due to limits on pT-hat and cos(theta-hat)
17704 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
17705 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
17707 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
17708 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
17709 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
17711 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
17712 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
17713 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
17714 C...4) due to limits on x1 and x2
17715 TAUMN4=CKIN(21)*CKIN(23)
17716 TAUMX4=CKIN(22)*CKIN(24)
17717 C...5) due to limits on xF
17719 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
17720 C...6) due to limits on that and uhat
17721 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
17723 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
17724 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
17726 C...Net effect of all separate limits.
17727 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
17728 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
17729 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
17732 ELSEIF(MINT(47).EQ.5) THEN
17733 VINT(31)=MIN(VINT(31),1D0-2D-10)
17734 ELSEIF(MINT(47).GE.6) THEN
17735 VINT(31)=MIN(VINT(31),1D0-1D-10)
17737 IF(VINT(31).LE.VINT(11)) MINT(51)=1
17739 ELSEIF(ILIM.EQ.2) THEN
17740 C...Calculate limits on y*
17742 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
17744 C...0) due to kinematics
17747 C...1) due to explicit limits
17750 C...2) due to limits on x1
17751 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
17752 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
17753 C...3) due to limits on x2
17754 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
17755 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
17756 C...4) due to limits on xF
17757 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
17758 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
17759 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
17760 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
17761 C...5) due to simultaneous limits on y-large and y-small
17762 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
17763 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
17764 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
17765 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
17766 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
17767 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
17768 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
17770 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
17771 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
17772 RZMX=BE34*MIN(CKIN(28),CTHLIM)
17773 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
17774 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
17775 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
17776 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
17777 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
17778 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
17780 C...Net effect of all separate limits.
17781 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
17782 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
17783 IF(MINT(47).EQ.1) THEN
17786 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
17787 VINT(12)=(1D0-1D-9)*YSTMX0
17788 VINT(32)=(1D0+1D-9)*YSTMX0
17789 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
17790 VINT(12)=-(1D0+1D-9)*YSTMX0
17791 VINT(32)=-(1D0-1D-9)*YSTMX0
17792 ELSEIF(MINT(47).EQ.5) THEN
17793 YSTEE=LOG((1D0-1D-10)/TAURT)
17794 VINT(12)=MAX(VINT(12),-YSTEE)
17795 VINT(32)=MIN(VINT(32),YSTEE)
17797 IF(VINT(32).LE.VINT(12)) MINT(51)=1
17799 ELSEIF(ILIM.EQ.3) THEN
17800 C...Calculate limits on cos(theta-hat)
17802 C...0) due to definition
17807 C...1) due to explicit limits
17808 CTNMN1=MIN(0D0,CKIN(27))
17809 CTNMX1=MIN(0D0,CKIN(28))
17810 CTPMN1=MAX(0D0,CKIN(27))
17811 CTPMX1=MAX(0D0,CKIN(28))
17812 C...2) due to limits on pT-hat
17813 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
17817 IF(CKIN(4).GE.0D0) THEN
17818 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
17819 & (BE34**2*TAU*VINT(2))))
17822 C...3) due to limits on y-large and y-small
17823 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
17824 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
17825 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
17826 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
17827 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
17828 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
17829 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
17830 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
17831 C...4) due to limits on that
17837 IF(CKIN(35).GT.0D0) THEN
17838 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
17839 IF(CTLIM.GT.0D0) THEN
17846 IF(CKIN(36).GT.0D0) THEN
17847 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
17848 IF(CTLIM.LT.0D0) THEN
17855 C...5) due to limits on uhat
17860 IF(CKIN(37).GT.0D0) THEN
17861 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
17862 IF(CTLIM.LT.0D0) THEN
17869 IF(CKIN(38).GT.0D0) THEN
17870 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
17871 IF(CTLIM.GT.0D0) THEN
17879 C...Net effect of all separate limits.
17880 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
17881 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
17882 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
17883 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
17884 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
17886 ELSEIF(ILIM.EQ.4) THEN
17887 C...Calculate limits on tau'
17888 C...0) due to kinematics
17890 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
17891 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
17892 TAPMN0=(SQRT(TAU)+PQRAT)**2
17895 C...1) due to explicit limits
17896 TAPMN1=CKIN(31)**2/VINT(2)
17898 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
17900 C...Net effect of all separate limits.
17901 VINT(16)=MAX(TAPMN0,TAPMN1)
17902 VINT(36)=MIN(TAPMX0,TAPMX1)
17903 IF(MINT(47).EQ.1) THEN
17906 ELSEIF(MINT(47).EQ.5) THEN
17907 VINT(36)=MIN(VINT(36),1D0-2D-10)
17908 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
17909 VINT(36)=MIN(VINT(36),1D0-1D-10)
17911 IF(VINT(36).LE.VINT(16)) MINT(51)=1
17916 C...Special case for low-pT and multiple interactions:
17917 C...effective kinematical limits for tau, y*, cos(theta-hat).
17918 100 IF(ILIM.EQ.0) THEN
17919 ELSEIF(ILIM.EQ.1) THEN
17920 IF(MSTP(82).LE.1) THEN
17921 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
17924 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
17927 ELSEIF(ILIM.EQ.2) THEN
17928 VINT(12)=0.5D0*LOG(VINT(21))
17930 ELSEIF(ILIM.EQ.3) THEN
17931 IF(MSTP(82).LE.1) THEN
17932 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
17933 & (VINT(21)*VINT(2))
17935 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
17936 & (VINT(21)*VINT(2))
17938 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
17947 C*********************************************************************
17950 C...Maps a uniform distribution into a distribution of a kinematical
17951 C...variable according to one of the possibilities allowed. It is
17952 C...assumed that kinematical limits have been set by a PYKLIM call.
17954 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
17956 C...Double precision and integer declarations.
17957 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17958 IMPLICIT INTEGER(I-N)
17959 INTEGER PYK,PYCHGE,PYCOMP
17961 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17962 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17963 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17964 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17965 COMMON/PYINT1/MINT(400),VINT(400)
17966 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17967 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
17969 C...Convert VVAR to tau variable.
17975 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
17978 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
17982 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
17984 ELSEIF(MVAR.EQ.1) THEN
17985 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
17986 ELSEIF(MVAR.EQ.2) THEN
17987 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
17988 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
17989 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
17990 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
17991 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
17992 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
17993 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
17994 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
17995 ELSEIF(MINT(47).EQ.5) THEN
17996 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
17997 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
17998 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
18000 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
18001 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
18002 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
18004 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
18006 C...Convert VVAR to y* variable.
18007 ELSEIF(IVAR.EQ.2) THEN
18011 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
18012 IF(MINT(47).EQ.1) THEN
18014 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
18015 YST=-0.5D0*LOG(TAUE)
18016 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
18017 YST=0.5D0*LOG(TAUE)
18018 ELSEIF(MVAR.EQ.1) THEN
18019 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
18020 ELSEIF(MVAR.EQ.2) THEN
18021 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
18022 ELSEIF(MVAR.EQ.3) THEN
18023 AUPP=ATAN(EXP(YSTMAX))
18024 ALOW=ATAN(EXP(YSTMIN))
18025 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
18026 ELSEIF(MVAR.EQ.4) THEN
18027 YST0=-0.5D0*LOG(TAUE)
18028 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
18029 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
18030 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
18032 YST0=-0.5D0*LOG(TAUE)
18033 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
18034 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
18035 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
18037 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
18039 C...Convert VVAR to cos(theta-hat) variable.
18040 ELSEIF(IVAR.EQ.3) THEN
18041 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
18043 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
18044 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
18052 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18053 VCTN=VVAR*(ANEG+APOS)/ANEG
18054 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
18056 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18057 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
18059 ELSEIF(MVAR.EQ.2) THEN
18060 RMNMIN=MAX(RM34,RSQM-CTNMIN)
18061 RMNMAX=MAX(RM34,RSQM-CTNMAX)
18062 RMPMIN=MAX(RM34,RSQM-CTPMIN)
18063 RMPMAX=MAX(RM34,RSQM-CTPMAX)
18064 ANEG=LOG(RMNMIN/RMNMAX)
18065 APOS=LOG(RMPMIN/RMPMAX)
18066 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18067 VCTN=VVAR*(ANEG+APOS)/ANEG
18068 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
18070 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18071 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
18073 ELSEIF(MVAR.EQ.3) THEN
18074 RMNMIN=MAX(RM34,RSQM+CTNMIN)
18075 RMNMAX=MAX(RM34,RSQM+CTNMAX)
18076 RMPMIN=MAX(RM34,RSQM+CTPMIN)
18077 RMPMAX=MAX(RM34,RSQM+CTPMAX)
18078 ANEG=LOG(RMNMAX/RMNMIN)
18079 APOS=LOG(RMPMAX/RMPMIN)
18080 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18081 VCTN=VVAR*(ANEG+APOS)/ANEG
18082 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
18084 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18085 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
18087 ELSEIF(MVAR.EQ.4) THEN
18088 RMNMIN=MAX(RM34,RSQM-CTNMIN)
18089 RMNMAX=MAX(RM34,RSQM-CTNMAX)
18090 RMPMIN=MAX(RM34,RSQM-CTPMIN)
18091 RMPMAX=MAX(RM34,RSQM-CTPMAX)
18092 ANEG=1D0/RMNMAX-1D0/RMNMIN
18093 APOS=1D0/RMPMAX-1D0/RMPMIN
18094 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18095 VCTN=VVAR*(ANEG+APOS)/ANEG
18096 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
18098 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18099 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
18101 ELSEIF(MVAR.EQ.5) THEN
18102 RMNMIN=MAX(RM34,RSQM+CTNMIN)
18103 RMNMAX=MAX(RM34,RSQM+CTNMAX)
18104 RMPMIN=MAX(RM34,RSQM+CTPMIN)
18105 RMPMAX=MAX(RM34,RSQM+CTPMAX)
18106 ANEG=1D0/RMNMIN-1D0/RMNMAX
18107 APOS=1D0/RMPMIN-1D0/RMPMAX
18108 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18109 VCTN=VVAR*(ANEG+APOS)/ANEG
18110 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
18112 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18113 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
18116 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
18117 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
18120 C...Convert VVAR to tau' variable.
18121 ELSEIF(IVAR.EQ.4) THEN
18125 IF(MINT(47).EQ.1) THEN
18127 ELSEIF(MVAR.EQ.1) THEN
18128 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
18129 ELSEIF(MVAR.EQ.2) THEN
18130 AUPP=(1D0-TAU/TAUPMX)**4
18131 ALOW=(1D0-TAU/TAUPMN)**4
18132 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
18133 ELSEIF(MINT(47).EQ.5) THEN
18134 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
18135 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
18136 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
18138 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
18139 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
18140 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
18142 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
18144 C...Selection of extra variables needed in 2 -> 3 process:
18145 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
18146 C...Since no options are available, the functions of PYKLIM
18147 C...and PYKMAP are joint for these choices.
18148 ELSEIF(IVAR.EQ.5) THEN
18150 C...Read out total energy and particle masses.
18153 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
18154 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
18156 SHP=VINT(26)*VINT(2)
18160 PM3=SQRT(VINT(21))*VINT(1)
18161 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
18168 C...Specify coefficients of pT choice; upper and lower limits.
18169 IF(MPTPK.EQ.1) THEN
18177 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
18179 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
18181 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
18183 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
18186 C...Select transverse momenta according to
18187 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
18190 IF(HMX.LT.1.0001D0*HMN) THEN
18196 IF(RPT.LT.HWT1) THEN
18197 PTS1=PTSMN1+PYR(0)*HDE
18198 ELSEIF(RPT.LT.HWT1+HWT2) THEN
18199 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
18201 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
18203 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
18204 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
18207 IF(HMX.LT.1.0001D0*HMN) THEN
18213 IF(RPT.LT.HWT1) THEN
18214 PTS2=PTSMN2+PYR(0)*HDE
18215 ELSEIF(RPT.LT.HWT1+HWT2) THEN
18216 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
18218 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
18220 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
18221 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
18223 C...Select azimuthal angles and check pT choice.
18224 PHI1=PARU(2)*PYR(0)
18225 PHI2=PARU(2)*PYR(0)
18227 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
18228 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
18229 & CKIN(56)**2)) THEN
18234 C...Calculate transverse masses and check phase space not closed.
18241 PM12=(PMT1+PMT2)**2
18242 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
18247 C...Select rapidity for particle 3 and check phase space not closed.
18248 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
18249 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
18250 IF(Y3MAX.LT.1D-6) THEN
18254 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
18258 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
18261 PMS12=PE12**2-PZ12**2
18262 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
18263 IF(SQL12.LT.1D-6*SHP) THEN
18267 PMM1=PMS12+PMS1-PMS2
18268 PMM2=PMS12+PMS2-PMS1
18269 TFAC=-SHPR/(2D0*PMS12)
18270 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
18271 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
18272 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
18273 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
18275 C...Construct relative mirror weights and make choice.
18276 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
18280 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
18281 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
18283 WTP=WTPU/(WTPU+WTNU)
18284 WTN=WTNU/(WTPU+WTNU)
18286 IF(WTN.GT.PYR(0)) EPS=-1D0
18288 C...Store result of variable choice and associated weights.
18298 IF(EPS.GT.0D0) THEN
18307 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
18308 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
18309 VINT(219)=0.5D0*(PMS12-PTS3)
18316 C***********************************************************************
18319 C...Differential matrix elements for all included subprocesses
18320 C...Note that what is coded is (disregarding the COMFAC factor)
18321 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
18322 C...when d(sigma-hat) is given in the zero-width limit, the delta
18323 C...function in tau is replaced by a (modified) Breit-Wigner:
18324 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
18325 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
18326 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
18327 C...i.e., dimensionless quantities
18328 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
18329 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
18330 C...(2pi)^4 delta^4(P - sum p_i)
18331 C...COMFAC contains the factor pi/s (or equivalent) and
18332 C...the conversion factor from GeV^-2 to mb
18334 SUBROUTINE PYSIGH(NCHN,SIGS)
18336 C...Double precision and integer declarations
18337 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18338 IMPLICIT INTEGER(I-N)
18339 INTEGER PYK,PYCHGE,PYCOMP
18340 C...Parameter statement to help give large particle numbers.
18341 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
18343 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18344 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18345 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18346 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
18347 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18348 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18349 COMMON/PYINT1/MINT(400),VINT(400)
18350 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18351 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
18352 COMMON/PYINT4/MWID(500),WIDS(500,5)
18353 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18354 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
18355 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
18357 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
18358 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
18360 C...Local arrays and complex variables
18361 DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200),
18362 &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
18363 COMPLEX A004,A204,A114,A00U,A20U,A11U
18364 COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
18365 &COULCK,COULCP,COULCD,COULCR,COULCS
18366 REAL A00L,A11L,A20L,COULXX
18367 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
18368 COMPLEX*16 DAA,DZZ,DAZ
18370 C...Reset number of channels and cross-section
18374 C...Convert H or A process into equivalent h one
18379 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
18380 &ISUB.LE.190)) THEN
18382 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
18384 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
18385 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
18386 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
18387 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
18388 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
18389 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
18390 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
18391 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
18392 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
18396 C...Convert almost equivalent SUSY processes into each other
18397 C...Extract differences in flavours and couplings
18398 IF(ISUB.GE.200.AND.ISUB.LE.301) THEN
18400 C...Sleptons and sneutrinos
18401 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
18402 KFID=MOD(KFPR(ISUB,1),KSUSY1)
18405 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
18406 KFID=MOD(KFPR(ISUB,1),KSUSY1)
18409 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
18410 KFID=MOD(KFPR(ISUB,1),KSUSY1)
18412 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
18413 IF(ISUB.EQ.210) THEN
18415 ELSEIF(ISUB.EQ.211) THEN
18417 ELSEIF(ISUB.EQ.212) THEN
18421 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
18422 IF(ISUB.EQ.213) THEN
18423 KFID=MOD(KFPR(ISUB,1),KSUSY1)
18425 ELSEIF(ISUB.EQ.214) THEN
18432 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
18433 IF(ISUB.EQ.216) THEN
18436 ELSEIF(ISUB.EQ.217) THEN
18439 ELSEIF(ISUB.EQ.218) THEN
18442 ELSEIF(ISUB.EQ.219) THEN
18445 ELSEIF(ISUB.EQ.220) THEN
18448 ELSEIF(ISUB.EQ.221) THEN
18451 ELSEIF(ISUB.EQ.222) THEN
18454 ELSEIF(ISUB.EQ.223) THEN
18457 ELSEIF(ISUB.EQ.224) THEN
18460 ELSEIF(ISUB.EQ.225) THEN
18467 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
18468 IF(ISUB.EQ.226) THEN
18471 ELSEIF(ISUB.EQ.227) THEN
18474 ELSEIF(ISUB.EQ.228) THEN
18480 C...Neutralino + chargino
18481 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
18482 IF(ISUB.EQ.229) THEN
18485 ELSEIF(ISUB.EQ.230) THEN
18488 ELSEIF(ISUB.EQ.231) THEN
18491 ELSEIF(ISUB.EQ.232) THEN
18494 ELSEIF(ISUB.EQ.233) THEN
18497 ELSEIF(ISUB.EQ.234) THEN
18500 ELSEIF(ISUB.EQ.235) THEN
18503 ELSEIF(ISUB.EQ.236) THEN
18509 C...Gluino + neutralino
18510 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
18511 IF(ISUB.EQ.237) THEN
18513 ELSEIF(ISUB.EQ.238) THEN
18515 ELSEIF(ISUB.EQ.239) THEN
18517 ELSEIF(ISUB.EQ.240) THEN
18522 C...Gluino + chargino
18523 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
18524 IF(ISUB.EQ.241) THEN
18526 ELSEIF(ISUB.EQ.242) THEN
18531 C...Squark + neutralino
18532 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
18534 IF(MOD(ISUB,2).NE.0) ILR=1
18535 IF(ISUB.LE.247) THEN
18537 ELSEIF(ISUB.LE.249) THEN
18539 ELSEIF(ISUB.LE.251) THEN
18541 ELSEIF(ISUB.LE.253) THEN
18547 C...Squark + chargino
18548 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
18549 IF(ISUB.LE.255) THEN
18551 ELSEIF(ISUB.LE.257) THEN
18554 IF(MOD(ISUB,2).EQ.0) THEN
18562 C...Squark + gluino
18563 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
18568 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
18570 IF(ISUB.EQ.262) ILR=1
18572 ELSEIF(ISUB.EQ.265) THEN
18576 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
18578 IF(ISUB.LE.273) THEN
18579 IF(ISUB.EQ.273) ILR=1
18582 ELSEIF(ISUB.LE.276) THEN
18583 IF(ISUB.EQ.276) ILR=1
18586 ELSEIF(ISUB.LE.278) THEN
18587 IF(ISUB.EQ.278) ILR=1
18591 IF(ISUB.EQ.280) ILR=1
18596 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
18598 IF(ISUB.LE.283) THEN
18599 IF(ISUB.EQ.283) ILR=1
18602 ELSEIF(ISUB.LE.286) THEN
18603 IF(ISUB.EQ.286) ILR=1
18606 ELSEIF(ISUB.LE.288) THEN
18607 IF(ISUB.EQ.288) ILR=1
18610 ELSEIF(ISUB.LE.290) THEN
18611 IF(ISUB.EQ.290) ILR=1
18614 ELSEIF(ISUB.LE.293) THEN
18615 IF(ISUB.EQ.293) ILR=1
18618 ELSEIF(ISUB.EQ.296) THEN
18622 C...Squark + gluino
18623 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
18628 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
18629 IF(ISUB.EQ.297) THEN
18630 RKF=.5D0*PARU(195)**2
18631 ELSEIF(ISUB.EQ.298) THEN
18632 RKF=.5D0*(1D0-PARU(195)**2)
18636 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
18637 IF(ISUB.EQ.299) THEN
18639 ELSEIF(ISUB.EQ.300) THEN
18644 ELSEIF(ISUB.EQ.301) THEN
18649 ELSEIF(ISUB.GE.361.AND.ISUB.LE.379) THEN
18652 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
18653 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
18654 CSXI=COS(ASIN(PARP(141)))
18655 CSXIP=COS(ASIN(PARJ(174)))
18656 QUPD=2D0*PARP(143)-1D0
18657 C... rho_tech0 -> W_L W_L
18658 IF(ISUB.EQ.361) THEN
18662 C... rho_tech0 -> W_L pi_tech-
18663 ELSEIF(ISUB.EQ.362) THEN
18667 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
18668 C... pi_tech pi_tech
18669 ELSEIF(ISUB.EQ.363) THEN
18673 CAB2=(1D0-PARP(141)**2)**2
18674 C... rho_tech0/omega_tech -> gamma pi_tech
18675 ELSEIF(ISUB.EQ.364) THEN
18682 C... gamma pi_tech'
18683 ELSEIF(ISUB.EQ.365) THEN
18692 ELSEIF(ISUB.EQ.366) THEN
18697 VRGP=-QUPD*CSXI*TANW
18701 ELSEIF(ISUB.EQ.367) THEN
18706 VOGP=-QUPD*CSXIP*TANW
18710 ELSEIF(ISUB.EQ.368) THEN
18714 VOGP=CSXI/(2D0*SQRT(PARU(102)))
18718 C... rho_tech+ -> W_L Z_L
18719 ELSEIF(ISUB.EQ.370) THEN
18724 ELSEIF(ISUB.EQ.371) THEN
18728 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
18730 ELSEIF(ISUB.EQ.372) THEN
18734 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
18735 C... pi_tech+ pi_tech0
18736 ELSEIF(ISUB.EQ.373) THEN
18740 CAB2=(1D0-PARP(141)**2)**2
18741 C... gamma pi_tech+
18742 ELSEIF(ISUB.EQ.374) THEN
18748 ELSEIF(ISUB.EQ.375) THEN
18752 VRGP=-QUPD*CSXI*TANW
18753 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
18755 ELSEIF(ISUB.EQ.376) THEN
18760 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
18762 ELSEIF(ISUB.EQ.377) THEN
18767 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
18772 C...Read kinematical variables and limits
18790 C...Derive kinematical quantities
18792 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
18793 X(1)=SQRT(TAUE)*EXP(YST)
18794 X(2)=SQRT(TAUE)*EXP(-YST)
18795 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
18796 IF(X(1).GT.1D0-1D-7) RETURN
18797 ELSEIF(MINT(45).EQ.3) THEN
18798 X(1)=MIN(1D0-1.1D-10,X(1))
18800 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
18801 IF(X(2).GT.1D0-1D-7) RETURN
18802 ELSEIF(MINT(46).EQ.3) THEN
18803 X(2)=MIN(1D0-1.1D-10,X(2))
18805 SH=MAX(1D0,TAU*VINT(2))
18810 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18811 RPTS=4D0*VINT(71)**2/SH
18812 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
18813 RM34=MAX(1D-20,2D0*RM3*RM4)
18815 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
18816 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
18817 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
18818 IF(ISTSB.EQ.0) THEN
18820 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
18821 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
18823 C...Kinematics with incoming masses tricky: now depends on how
18824 C...subprocess has been set up w.r.t. order of incoming partons.
18826 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
18828 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
18829 IF(ISUB.EQ.35) THEN
18833 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18834 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
18835 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
18837 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
18839 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
18846 C...Choice of Q2 scale: hard, parton distributions, parton showers
18847 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
18849 ELSEIF(ISTSB.EQ.8) THEN
18850 IF(MINT(107).EQ.4) Q2=VINT(307)
18851 IF(MINT(108).EQ.4) Q2=VINT(308)
18852 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
18854 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
18856 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
18857 IF(MSTP(32).EQ.1) THEN
18858 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
18859 ELSEIF(MSTP(32).EQ.2) THEN
18860 Q2=SQPTH+0.5D0*(SQM3+SQM4)
18861 ELSEIF(MSTP(32).EQ.3) THEN
18863 ELSEIF(MSTP(32).EQ.4) THEN
18865 ELSEIF(MSTP(32).EQ.5) THEN
18867 ELSEIF(MSTP(32).EQ.6) THEN
18869 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
18871 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
18872 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
18873 & (SQPTH+0.5D0*(SQM3+SQM4))
18874 ELSEIF(MSTP(32).EQ.7) THEN
18875 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
18876 ELSEIF(MSTP(32).EQ.8) THEN
18877 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
18878 ELSEIF(MSTP(32).EQ.9) THEN
18879 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
18880 ELSEIF(MSTP(32).EQ.10) THEN
18883 IF(ISTSB.EQ.9) Q2=SQPTH
18884 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
18885 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
18888 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
18890 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
18891 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
18892 IF(ISUB.EQ.352) Q2SF=PMAS(63,1)**2
18893 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
18894 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
18895 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
18896 IF(MSTP(39).EQ.3) Q2SF=SH
18897 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
18898 IF(MSTP(39).EQ.5) Q2SF=PMAS(KFHIGG,1)**2
18903 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
18904 IF(MSTP(69).GE.2) Q2SF=VINT(2)
18905 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
18906 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
18908 IF(MINT(43).EQ.3) XBJ=X(1)
18909 IF(MSTP(22).EQ.1) THEN
18911 ELSEIF(MSTP(22).EQ.2) THEN
18912 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
18913 ELSEIF(MSTP(22).EQ.3) THEN
18914 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
18916 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
18919 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
18920 &ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.ISUBSV.EQ.144)) THEN
18922 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
18923 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
18924 &ISUBSV.NE.68)) THEN
18928 C...Store derived kinematical quantities
18935 IF(ISTSB.NE.8) VINT(48)=SQPTH
18936 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
18937 VINT(50)=TAUP*VINT(2)
18938 VINT(49)=SQRT(MAX(0D0,VINT(50)))
18942 VINT(53)=SQRT(Q2SF)
18944 VINT(55)=SQRT(Q2PS)
18946 C...Calculate parton distributions
18947 IF(ISTSB.LE.0) GOTO 152
18948 IF(MINT(47).GE.2) THEN
18949 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
18951 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
18952 IF(ISUB.EQ.99) THEN
18953 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
18956 MINT(105)=MINT(102+I)
18957 MINT(109)=MINT(106+I)
18958 VINT(120)=VINT(2+I)
18960 C.... Store side in MINT(124)
18963 IF(MSTP(57).LE.1) THEN
18964 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
18966 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
18969 XSFX(I,KFL)=XPQ(KFL)
18974 C...Calculate alpha_em, alpha_strong and K-factor
18977 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
18978 &1D0-(PMAS(24,1)/PMAS(23,1))**2
18980 XWC=1D0/(16D0*XW*XW1)
18982 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
18983 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
18986 IF(MSTP(33).EQ.1) THEN
18988 ELSEIF(MSTP(33).EQ.2) THEN
18990 FACA=PARP(32)/PARP(31)
18991 ELSEIF(MSTP(33).EQ.3) THEN
18993 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
18994 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
19001 C...Set flags for allowed reacting partons/leptons
19006 IF(MINT(44+I).EQ.1) THEN
19007 KFAC(I,MINT(10+I))=1
19008 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
19009 KFAC(I,MINT(10+I))=1
19015 KFAC(I,J)=KFIN(I,J)
19016 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
19017 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
19022 C...Lower and upper limit for fermion flavour loops
19028 IF(KFAC(1,-J).EQ.1) MMIN1=-J
19029 IF(KFAC(1,J).EQ.1) MMAX1=J
19030 IF(KFAC(2,-J).EQ.1) MMIN2=-J
19031 IF(KFAC(2,J).EQ.1) MMAX2=J
19033 MMINA=MIN(MMIN1,MMIN2)
19034 MMAXA=MAX(MMAX1,MMAX2)
19036 C...Common resonance mass and width combinations
19039 SQMH=PMAS(KFHIGG,1)**2
19040 GMMZ=PMAS(23,1)*PMAS(23,2)
19041 GMMW=PMAS(24,1)*PMAS(24,2)
19042 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
19047 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
19050 C...Phase space integral in tau
19051 COMFAC=PARU(1)*PARU(5)/VINT(2)
19052 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
19053 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
19054 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
19055 ATAU1=LOG(TAUMAX/TAUMIN)
19056 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
19057 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
19058 IF(MINT(72).GE.1) THEN
19061 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
19063 IF(ATAUD.GT.1D-10) H1=H1+
19064 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
19065 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
19067 IF(ATAUD.GT.1D-10) H1=H1+
19068 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
19070 IF(MINT(72).EQ.2) THEN
19073 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
19075 IF(ATAUD.GT.1D-10) H1=H1+
19076 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
19077 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
19079 IF(ATAUD.GT.1D-10) H1=H1+
19080 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
19082 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
19083 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
19084 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
19085 & MAX(2D-10,1D0-TAU)
19086 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
19087 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
19088 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
19089 & MAX(1D-10,1D0-TAU)
19091 COMFAC=COMFAC*ATAU1/(TAU*H1)
19094 C...Phase space integral in y*
19095 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
19097 AYST0=YSTMAX-YSTMIN
19098 IF(AYST0.LT.1D-10) THEN
19101 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
19103 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
19104 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
19105 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
19106 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
19107 IF(MINT(45).EQ.3) THEN
19108 YST0=-0.5D0*LOG(TAUE)
19109 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
19110 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
19111 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
19112 & MAX(1D-10,1D0-EXP(YST-YST0))
19114 IF(MINT(46).EQ.3) THEN
19115 YST0=-0.5D0*LOG(TAUE)
19116 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
19117 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
19118 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
19119 & MAX(1D-10,1D0-EXP(-YST-YST0))
19121 COMFAC=COMFAC*AYST0/H2
19125 C...2 -> 1 processes: reduction in angular part of phase space integral
19126 C...for case of decaying resonance
19127 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
19128 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
19129 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
19130 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
19131 & KFPR(ISUB,1).EQ.39) THEN
19132 COMFAC=COMFAC*0.5D0*ACTH0
19134 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
19135 & CTPMAX**3-CTPMIN**3)
19139 C...2 -> 2 processes: angular part of phase space integral
19140 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19141 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
19142 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
19143 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
19144 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
19145 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
19146 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
19147 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
19148 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
19149 H3=COEF(ISUBSV,13)+
19150 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
19151 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
19152 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
19153 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
19154 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
19156 C...2 -> 2 processes: take into account final state Breit-Wigners
19157 COMFAC=COMFAC*VINT(80)
19160 C...2 -> 3, 4 processes: phace space integral in tau'
19161 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19162 ATAUP1=LOG(TAUPMX/TAUPMN)
19163 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
19164 H4=COEF(ISUBSV,18)+
19165 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
19166 IF(MINT(47).EQ.5) THEN
19167 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
19168 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
19169 ELSEIF(MINT(47).GE.6) THEN
19170 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
19171 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
19173 COMFAC=COMFAC*ATAUP1/H4
19176 C...2 -> 3, 4 processes: effective W/Z parton distributions
19177 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
19178 IF(1D0-TAU/TAUP.GT.1D-4) THEN
19179 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
19181 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
19186 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
19187 IF(ISTSB.EQ.5) THEN
19188 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
19189 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
19192 C...Phase space integral for low-pT and multiple interactions
19193 IF(ISTSB.EQ.9) THEN
19194 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
19195 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
19196 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
19197 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
19198 COMFAC=COMFAC*ATAU1/H1
19199 AYST0=YSTMAX-YSTMIN
19200 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
19201 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
19202 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
19203 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
19204 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
19205 COMFAC=COMFAC*AYST0/H2
19206 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
19207 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
19208 C...introduced to make cross-section finite for xT2 -> 0
19209 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
19213 C...Real gamma + gamma: include factor 2 when different nature
19214 152 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
19215 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
19217 C...Extra factors to include the effects of
19218 C...longitudinal resolved photons.
19220 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1) THEN
19223 IF(MSTP(16).EQ.0) THEN
19224 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
19225 & XY=VINT(304+ISDE)
19227 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
19228 & XY=VINT(308+ISDE)
19230 Q2GA=VINT(306+ISDE)
19231 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
19232 & Q2GA.GT.0D0) THEN
19234 IF(MSTP(17).EQ.1) THEN
19235 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
19236 ELSEIF(MSTP(17).EQ.2) THEN
19237 REDUCE=4D0*Q2GA/(Q2+Q2GA)
19238 ELSEIF(MSTP(17).EQ.3) THEN
19239 PMVIRT=PMAS(PYCOMP(113),1)
19240 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
19241 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
19242 PMVIRT=PMAS(PYCOMP(113),1)
19243 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
19244 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
19245 PMVIRT=PMAS(PYCOMP(113),1)
19246 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
19247 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
19248 PMVSMN=4D0*PARP(15)**2
19249 PMVSMX=4D0*VINT(154)**2
19250 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
19251 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
19252 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
19253 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
19254 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
19255 PMVIRT=PMAS(PYCOMP(113),1)
19256 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
19257 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
19258 PMVIRT=PMAS(PYCOMP(113),1)
19259 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
19260 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
19261 PMVSMN=4D0*PARP(15)**2
19262 PMVSMX=4D0*VINT(154)**2
19263 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
19264 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
19265 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
19268 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
19269 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
19270 & (1D0-2D0*BEAMAS**2/Q2GA))
19271 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
19276 COMFAC=COMFAC*VINT(314+ISDE)
19279 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
19280 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
19281 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
19282 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
19283 IF(MSTP(46).LE.4) THEN
19284 HDTLH=LOG(PMAS(25,1)/PARP(44))
19285 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
19286 HDTNR=-1D0/18D0+HDTLH/6D0
19288 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
19289 HDTLQ=LOG(PARP(45)/PARP(44))
19290 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
19291 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
19294 C...Calculate lowest and next-to-lowest order partial wave amplitudes
19295 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
19299 HDTLS=LOG(SH/PARP(44)**2)
19300 A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
19301 & CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
19302 & (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1)))
19303 A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
19304 & CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
19305 & (20D0/9D0)*HDTLS),SNGL(PARU(1)))
19306 A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))*
19307 & CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0))
19309 C...Unitarize partial wave amplitudes with Pade or K-matrix method
19310 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
19311 A00U=A00L/(1.-A004/A00L)
19312 A20U=A20L/(1.-A204/A20L)
19313 A11U=A11L/(1.-A114/A11L)
19315 A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004)))
19316 A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204)))
19317 A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114)))
19321 C...Supersymmetric processes - all of type 2 -> 2 :
19322 C...correct final-state Breit-Wigners from fixed to running width.
19323 IF(ISUB.GE.200.AND.ISUB.LE.301.AND.MSTP(42).GT.0) THEN
19325 KFLW=KFPR(ISUBSV,I)
19327 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160
19328 IF(I.EQ.1) SQMI=SQM3
19329 IF(I.EQ.2) SQMI=SQM4
19330 SQMS=PMAS(KCW,1)**2
19331 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
19332 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
19333 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
19334 GMMI=SQRT(SQMI)*WDTP(0)
19335 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
19336 COMFAC=COMFAC*(HBWI/HBWS)
19340 C...A: 2 -> 1, tree diagrams
19342 IF(ISUB.LE.10) THEN
19344 C...f + fbar -> gamma*/Z0
19346 CALL PYWIDT(23,SH,WDTP,WDTE)
19348 FACZ=4D0*COMFAC*3D0
19351 DO 180 I=MMINA,MMAXA
19352 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
19353 EI=KCHG(IABS(I),1)/3D0
19357 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
19359 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
19364 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
19365 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
19366 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
19367 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
19370 ELSEIF(ISUB.EQ.2) THEN
19371 C...f + fbar' -> W+/-
19372 CALL PYWIDT(24,SH,WDTP,WDTE)
19374 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
19375 HP=AEM/(24D0*XW)*SH
19376 DO 200 I=MMIN1,MMAX1
19377 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
19379 DO 190 J=MMIN2,MMAX2
19380 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
19382 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
19383 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19385 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19387 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19392 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
19393 SIGH(NCHN)=HI*FACBW*HF
19397 ELSEIF(ISUB.EQ.3) THEN
19398 C...f + fbar -> h0 (or H0, or A0)
19399 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19401 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
19402 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19404 HP=AEM/(8D0*XW)*SH/SQMW*SH
19405 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19406 DO 210 I=MMINA,MMAXA
19407 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
19409 RMQ=PYMRUN(IA,SH)**2/SH
19411 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
19412 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19414 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19415 IF(IA.GT.10) IKFI=3
19416 HI=HI*PARU(150+10*IHIGG+IKFI)**2
19422 SIGH(NCHN)=HI*FACBW*HF
19425 ELSEIF(ISUB.EQ.4) THEN
19426 C...gamma + W+/- -> W+/-
19428 ELSEIF(ISUB.EQ.5) THEN
19430 CALL PYWIDT(25,SH,WDTP,WDTE)
19432 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
19433 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
19434 HP=AEM/(8D0*XW)*SH/SQMW*SH
19435 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19437 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
19438 DO 230 I=MMIN1,MMAX1
19439 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230
19440 DO 220 J=MMIN2,MMAX2
19441 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220
19442 EI=KCHG(IABS(I),1)/3D0
19445 EJ=KCHG(IABS(J),1)/3D0
19452 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
19456 ELSEIF(ISUB.EQ.6) THEN
19457 C...Z0 + W+/- -> W+/-
19459 ELSEIF(ISUB.EQ.7) THEN
19462 ELSEIF(ISUB.EQ.8) THEN
19464 CALL PYWIDT(25,SH,WDTP,WDTE)
19466 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
19467 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
19468 HP=AEM/(8D0*XW)*SH/SQMW*SH
19469 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19471 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
19472 DO 250 I=MMIN1,MMAX1
19473 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250
19474 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
19475 DO 240 J=MMIN2,MMAX2
19476 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240
19477 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
19478 IF(EI*EJ.GT.0D0) GOTO 240
19483 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
19487 C...B: 2 -> 2, tree diagrams
19489 ELSEIF(ISUB.EQ.10) THEN
19490 C...f + f' -> f + f' (gamma/Z/W exchange)
19491 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
19492 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
19493 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
19494 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
19495 DO 270 I=MMIN1,MMAX1
19496 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
19498 DO 260 J=MMIN2,MMAX2
19499 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
19501 C...Electroweak couplings
19502 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
19503 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
19505 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
19506 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
19509 C...gamma/Z exchange, only gamma exchange, or only Z exchange
19510 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
19511 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
19512 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
19513 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
19514 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
19515 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
19516 ELSEIF(MSTP(21).EQ.2) THEN
19517 FACNCF=FACGGF*EI**2*EJ**2
19519 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
19520 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
19529 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
19530 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
19531 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
19532 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
19533 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
19544 ELSEIF(ISUB.LE.20) THEN
19545 IF(ISUB.EQ.11) THEN
19546 C...f + f' -> f + f' (g exchange)
19547 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
19548 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
19549 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
19550 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
19551 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
19552 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
19553 IF(MSTP(5).GE.1) THEN
19554 C...Modifications from contact interactions (compositeness)
19555 FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
19556 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
19557 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
19558 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
19559 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
19560 FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
19561 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
19563 DO 290 I=MMIN1,MMAX1
19565 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290
19566 DO 280 J=MMIN2,MMAX2
19568 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280
19573 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
19576 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
19579 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
19580 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
19587 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
19588 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
19589 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
19591 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
19592 SIGH(NCHN)=0.5D0*FACCI2*RATCII
19598 ELSEIF(ISUB.EQ.12) THEN
19599 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
19600 CALL PYWIDT(21,SH,WDTP,WDTE)
19601 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
19602 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19603 IF(MSTP(5).EQ.1) THEN
19604 C...Modifications from contact interactions (compositeness)
19607 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
19608 & WDTE(I,2)+WDTE(I,4))
19610 ELSEIF(MSTP(5).GE.2) THEN
19611 FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
19612 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19614 DO 310 I=MMINA,MMAXA
19615 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19616 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
19621 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
19628 ELSEIF(ISUB.EQ.13) THEN
19629 C...f + fbar -> g + g (q + qbar -> g + g only)
19630 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
19632 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
19634 DO 320 I=MMINA,MMAXA
19635 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19636 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
19641 SIGH(NCHN)=0.5D0*FACGG1
19646 SIGH(NCHN)=0.5D0*FACGG2
19649 ELSEIF(ISUB.EQ.14) THEN
19650 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
19651 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
19652 DO 330 I=MMINA,MMAXA
19653 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19654 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
19655 EI=KCHG(IABS(I),1)/3D0
19660 SIGH(NCHN)=FACGG*EI**2
19663 ELSEIF(ISUB.EQ.15) THEN
19664 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
19665 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
19666 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19670 RADC4=1D0+PYALPS(SQM4)/PARU(1)
19671 DO 340 I=1,MIN(16,MDCY(23,3))
19673 IF(MDME(IDC,1).LT.0) GOTO 340
19675 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
19679 AF=SIGN(1D0,EF+0.1D0)
19681 ELSEIF(I.LE.16) THEN
19683 AF=SIGN(1D0,EF+0.1D0)
19686 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
19687 IF(4D0*RM1.LT.1D0) THEN
19689 IF(I.LE.8) FCOF=3D0*RADC4
19690 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
19692 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
19693 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
19694 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
19695 & AF**2*(1D0-4D0*RM1))*BE34
19699 C...Propagators: as simulated in PYOFSH and as desired
19700 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
19704 CALL PYWIDT(23,SQM4,WDTP,WDTE)
19706 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
19707 HFGG=HFGG*HFAEM*VINT(111)/SQM4
19708 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
19709 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
19710 C...Loop over flavours; consider full gamma/Z structure
19711 DO 350 I=MMINA,MMAXA
19712 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19713 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
19714 EI=KCHG(IABS(I),1)/3D0
19721 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
19722 & (VI**2+AI**2)*HFZZ)/HBW4
19725 ELSEIF(ISUB.EQ.16) THEN
19726 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
19727 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
19728 C...Propagators: as simulated in PYOFSH and as desired
19729 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
19730 CALL PYWIDT(24,SQM4,WDTP,WDTE)
19731 GMMWC=SQRT(SQM4)*WDTP(0)
19732 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
19733 FACWG=FACWG*HBW4C/HBW4
19734 DO 370 I=MMIN1,MMAX1
19736 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370
19737 DO 360 J=MMIN2,MMAX2
19739 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360
19740 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
19741 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19742 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
19743 FCKM=VCKM((IA+1)/2,(JA+1)/2)
19748 SIGH(NCHN)=FACWG*FCKM*WIDSC
19752 ELSEIF(ISUB.EQ.17) THEN
19753 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
19755 ELSEIF(ISUB.EQ.18) THEN
19756 C...f + fbar -> gamma + gamma
19757 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
19758 DO 380 I=MMINA,MMAXA
19759 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
19760 EI=KCHG(IABS(I),1)/3D0
19762 IF(IABS(I).LE.10) FCOI=FACA/3D0
19767 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
19770 ELSEIF(ISUB.EQ.19) THEN
19771 C...f + fbar -> gamma + (gamma*/Z0)
19772 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
19773 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19777 RADC4=1D0+PYALPS(SQM4)/PARU(1)
19778 DO 390 I=1,MIN(16,MDCY(23,3))
19780 IF(MDME(IDC,1).LT.0) GOTO 390
19782 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
19786 AF=SIGN(1D0,EF+0.1D0)
19788 ELSEIF(I.LE.16) THEN
19790 AF=SIGN(1D0,EF+0.1D0)
19793 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
19794 IF(4D0*RM1.LT.1D0) THEN
19796 IF(I.LE.8) FCOF=3D0*RADC4
19797 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
19799 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
19800 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
19801 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
19802 & AF**2*(1D0-4D0*RM1))*BE34
19806 C...Propagators: as simulated in PYOFSH and as desired
19807 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
19811 CALL PYWIDT(23,SQM4,WDTP,WDTE)
19813 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
19814 HFGG=HFGG*HFAEM*VINT(111)/SQM4
19815 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
19816 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
19817 C...Loop over flavours; consider full gamma/Z structure
19818 DO 400 I=MMINA,MMAXA
19819 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
19820 EI=KCHG(IABS(I),1)/3D0
19824 IF(IABS(I).LE.10) FCOI=FACA/3D0
19829 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
19830 & (VI**2+AI**2)*HFZZ)/HBW4
19833 ELSEIF(ISUB.EQ.20) THEN
19834 C...f + fbar' -> gamma + W+/-
19835 FACGW=COMFAC*0.5D0*AEM**2/XW
19836 C...Propagators: as simulated in PYOFSH and as desired
19837 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
19838 CALL PYWIDT(24,SQM4,WDTP,WDTE)
19839 GMMWC=SQRT(SQM4)*WDTP(0)
19840 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
19841 FACGW=FACGW*HBW4C/HBW4
19842 C...Anomalous couplings
19843 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
19846 IF(MSTP(5).GE.1) THEN
19847 TERM2=PARU(153)*(TH-UH)/(TH+UH)
19848 TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
19849 & (4D0*SQMW))/(TH+UH)**2
19851 DO 420 I=MMIN1,MMAX1
19853 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420
19854 DO 410 J=MMIN2,MMAX2
19856 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410
19857 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
19858 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19860 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19861 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
19863 FACWR=UH/(TH+UH)-1D0/3D0
19864 FCKM=VCKM((IA+1)/2,(JA+1)/2)
19871 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
19876 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
19881 ELSEIF(ISUB.LE.30) THEN
19882 IF(ISUB.EQ.21) THEN
19883 C...f + fbar -> gamma + h0
19885 ELSEIF(ISUB.EQ.22) THEN
19886 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
19887 C...Kinematics dependence
19888 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
19889 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
19890 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19896 RADC3=1D0+PYALPS(SQM3)/PARU(1)
19897 RADC4=1D0+PYALPS(SQM4)/PARU(1)
19898 DO 450 I=1,MIN(16,MDCY(23,3))
19900 IF(MDME(IDC,1).LT.0) GOTO 450
19902 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
19903 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
19906 AF=SIGN(1D0,EF+0.1D0)
19908 ELSEIF(I.LE.16) THEN
19910 AF=SIGN(1D0,EF+0.1D0)
19913 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
19914 IF(4D0*RM1.LT.1D0) THEN
19916 IF(I.LE.8) FCOF=3D0*RADC3
19917 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
19919 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
19920 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
19921 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
19922 & AF**2*(1D0-4D0*RM1))*BE34
19925 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
19926 IF(4D0*RM1.LT.1D0) THEN
19928 IF(I.LE.8) FCOF=3D0*RADC4
19929 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
19931 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
19932 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
19933 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
19934 & AF**2*(1D0-4D0*RM1))*BE34
19938 C...Propagators: as simulated in PYOFSH and as desired
19939 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
19940 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
19944 CALL PYWIDT(23,SQM3,WDTP,WDTE)
19946 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
19948 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
19949 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
19950 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
19955 CALL PYWIDT(23,SQM4,WDTP,WDTE)
19957 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
19959 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
19960 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
19961 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
19963 C...Loop over flavours; separate left- and right-handed couplings
19964 DO 490 I=MMINA,MMAXA
19965 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
19966 EI=KCHG(IABS(I),1)/3D0
19972 IF(IABS(I).LE.10) FCOI=FACA/3D0
19974 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
19975 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
19976 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
19977 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
19979 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
19980 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
19981 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
19982 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
19987 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
19990 ELSEIF(ISUB.EQ.23) THEN
19991 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
19992 FACZW=COMFAC*0.5D0*(AEM/XW)**2
19993 FACZW=FACZW*WIDS(23,2)
19994 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
19995 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
19996 DO 510 I=MMIN1,MMAX1
19998 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510
19999 DO 500 J=MMIN2,MMAX2
20001 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500
20002 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500
20003 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
20005 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
20007 AI=SIGN(1D0,EI+0.1D0)
20010 AJ=SIGN(1D0,EJ+0.1D0)
20012 IF(VI+AI.GT.0) THEN
20021 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20023 IF(IA.LE.10) FCOI=FACA/3D0
20028 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
20029 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
20030 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
20031 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
20032 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
20033 & WIDS(24,(5-KCHW)/2)
20034 C***Protect against slightly negative cross sections. (Reason yet to be
20035 C***sorted out. One possibility: addition of width to the W propagator.)
20036 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
20040 ELSEIF(ISUB.EQ.24) THEN
20041 C...f + fbar -> Z0 + h0 (or H0, or A0)
20042 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
20043 FACHZ=COMFAC*8D0*(AEM*XWC)**2*
20044 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
20045 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
20046 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
20047 & PARU(154+10*IHIGG)**2
20048 DO 520 I=MMINA,MMAXA
20049 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
20050 EI=KCHG(IABS(I),1)/3D0
20054 IF(IABS(I).LE.10) FCOI=FACA/3D0
20059 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
20062 ELSEIF(ISUB.EQ.25) THEN
20063 C...f + fbar -> W+ + W-
20064 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
20066 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
20067 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
20068 CALL PYWIDT(24,SQM3,WDTP,WDTE)
20069 GMMW3=SQRT(SQM3)*WDTP(0)
20070 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
20071 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
20072 CALL PYWIDT(24,SQM4,WDTP,WDTE)
20073 GMMW4=SQRT(SQM4)*WDTP(0)
20074 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
20075 C...Kinematical functions
20076 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
20077 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
20078 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
20079 GT=THUH34+4D0*THUH/TH2
20080 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
20081 GU=THUH34+4D0*THUH/UH2
20082 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
20083 C...Common factors and couplings
20084 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
20085 FACWW=FACWW*WIDS(24,1)
20087 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
20088 CZZ=AEM**2/(32D0*XW**2)*HBWZC
20089 CNG=AEM**2/(4D0*XW)
20090 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
20091 CNN=AEM**2/(16D0*XW**2)
20092 C...Coulomb factor for W+W- pair
20093 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
20094 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
20095 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
20096 IF(COULE.LT.100D0*PMAS(24,2)) THEN
20097 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
20098 & PMAS(24,2)**2)-COULE))
20100 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
20102 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
20103 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
20104 & PMAS(24,2)**2)+COULE))
20106 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
20109 IF(MSTP(40).EQ.1) THEN
20110 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
20111 & MAX(1D-10,2D0*COULP*COULP1))
20112 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
20113 ELSEIF(MSTP(40).EQ.2) THEN
20114 COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2))
20115 COULCP=CMPLX(0.,SNGL(COULP))
20116 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
20117 COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD)
20118 COULCS=CMPLX(0.,0.)
20121 COULXX=(ISTP-0.5)/NSTP
20122 COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/
20123 & (1.+COULXX/COULCD))
20125 COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)*
20127 FACCOU=ABS(COULCR)**2
20128 ELSEIF(MSTP(40).EQ.3) THEN
20129 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
20130 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
20131 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
20133 ELSEIF(MSTP(40).EQ.4) THEN
20134 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
20140 C...Loop over allowed flavours
20141 DO 540 I=MMINA,MMAXA
20142 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
20143 EI=KCHG(IABS(I),1)/3D0
20144 AI=SIGN(1D0,EI+0.1D0)
20147 IF(IABS(I).LE.10) FCOI=FACA/3D0
20149 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
20150 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
20152 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
20153 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
20159 SIGH(NCHN)=FACWW*FCOI*DSIGWW
20162 ELSEIF(ISUB.EQ.26) THEN
20163 C...f + fbar' -> W+/- + h0 (or H0, or A0)
20164 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
20165 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
20166 & ((SH-SQMW)**2+GMMW**2)
20167 FACHW=FACHW*WIDS(KFHIGG,2)
20168 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
20169 & PARU(155+10*IHIGG)**2
20170 DO 560 I=MMIN1,MMAX1
20172 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560
20173 DO 550 J=MMIN2,MMAX2
20175 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550
20176 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550
20177 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
20179 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
20181 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20183 IF(IA.LE.10) FCOI=FACA/3D0
20188 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
20192 ELSEIF(ISUB.EQ.27) THEN
20193 C...f + fbar -> h0 + h0
20195 ELSEIF(ISUB.EQ.28) THEN
20196 C...f + g -> f + g (q + g -> q + g only)
20197 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
20199 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
20201 DO 580 I=MMINA,MMAXA
20202 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580
20204 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570
20205 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570
20208 ISIG(NCHN,3-ISDE)=21
20213 ISIG(NCHN,3-ISDE)=21
20219 ELSEIF(ISUB.EQ.29) THEN
20220 C...f + g -> f + gamma (q + g -> q + gamma only)
20221 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
20222 DO 600 I=MMINA,MMAXA
20223 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600
20224 EI=KCHG(IABS(I),1)/3D0
20227 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590
20228 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590
20231 ISIG(NCHN,3-ISDE)=21
20237 ELSEIF(ISUB.EQ.30) THEN
20238 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
20239 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
20241 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
20245 RADC4=1D0+PYALPS(SQM4)/PARU(1)
20246 DO 610 I=1,MIN(16,MDCY(23,3))
20248 IF(MDME(IDC,1).LT.0) GOTO 610
20250 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
20254 AF=SIGN(1D0,EF+0.1D0)
20256 ELSEIF(I.LE.16) THEN
20258 AF=SIGN(1D0,EF+0.1D0)
20261 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
20262 IF(4D0*RM1.LT.1D0) THEN
20264 IF(I.LE.8) FCOF=3D0*RADC4
20265 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
20267 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
20268 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
20269 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
20270 & AF**2*(1D0-4D0*RM1))*BE34
20274 C...Propagators: as simulated in PYOFSH and as desired
20275 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
20279 CALL PYWIDT(23,SQM4,WDTP,WDTE)
20281 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
20282 HFGG=HFGG*HFAEM*VINT(111)/SQM4
20283 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
20284 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
20285 C...Loop over flavours; consider full gamma/Z structure
20286 DO 630 I=MMINA,MMAXA
20287 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630
20288 EI=KCHG(IABS(I),1)/3D0
20291 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
20292 & (VI**2+AI**2)*HFZZ)/HBW4
20294 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620
20295 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620
20298 ISIG(NCHN,3-ISDE)=21
20305 ELSEIF(ISUB.LE.40) THEN
20306 IF(ISUB.EQ.31) THEN
20307 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
20308 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
20309 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
20310 C...Propagators: as simulated in PYOFSH and as desired
20311 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
20312 CALL PYWIDT(24,SQM4,WDTP,WDTE)
20313 GMMWC=SQRT(SQM4)*WDTP(0)
20314 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
20315 FACWQ=FACWQ*HBW4C/HBW4
20316 DO 650 I=MMINA,MMAXA
20317 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650
20319 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
20320 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
20322 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640
20323 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640
20326 ISIG(NCHN,3-ISDE)=21
20328 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
20332 ELSEIF(ISUB.EQ.32) THEN
20333 C...f + g -> f + h0 (q + g -> q + h0 only)
20334 SQMHC=PMAS(25,1)**2
20335 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
20336 DO 651 I=MMINA,MMAXA
20338 IF(IA.NE.5) GOTO 651
20340 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
20341 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
20342 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
20345 FACHCQ=FHCQ*SQML/SQMW*
20346 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
20347 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
20348 & (SQMHC-SQMQ-SH)/SH)
20349 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
20351 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 641
20352 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 641
20355 ISIG(NCHN,3-ISDE)=21
20357 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
20361 ELSEIF(ISUB.EQ.33) THEN
20362 C...f + gamma -> f + g (q + gamma -> q + g only)
20363 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
20364 DO 670 I=MMINA,MMAXA
20365 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670
20366 EI=KCHG(IABS(I),1)/3D0
20369 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660
20370 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660
20373 ISIG(NCHN,3-ISDE)=22
20379 ELSEIF(ISUB.EQ.34) THEN
20380 C...f + gamma -> f + gamma
20381 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
20382 DO 690 I=MMINA,MMAXA
20383 IF(I.EQ.0) GOTO 690
20384 EI=KCHG(IABS(I),1)/3D0
20387 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680
20388 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680
20391 ISIG(NCHN,3-ISDE)=22
20397 ELSEIF(ISUB.EQ.35) THEN
20398 C...f + gamma -> f + (gamma*/Z0)
20399 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
20400 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
20401 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
20402 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
20403 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
20404 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
20406 FZQN=SH2+UH2+2D0*SQM4*TH
20409 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
20410 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
20414 RADC4=1D0+PYALPS(SQM4)/PARU(1)
20415 DO 700 I=1,MIN(16,MDCY(23,3))
20417 IF(MDME(IDC,1).LT.0) GOTO 700
20419 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
20423 AF=SIGN(1D0,EF+0.1D0)
20425 ELSEIF(I.LE.16) THEN
20427 AF=SIGN(1D0,EF+0.1D0)
20430 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
20431 IF(4D0*RM1.LT.1D0) THEN
20433 IF(I.LE.8) FCOF=3D0*RADC4
20434 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
20436 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
20437 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
20438 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
20439 & AF**2*(1D0-4D0*RM1))*BE34
20443 C...Propagators: as simulated in PYOFSH and as desired
20444 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
20448 CALL PYWIDT(23,SQM4,WDTP,WDTE)
20450 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
20451 HFGG=HFGG*HFAEM*VINT(111)/SQM4
20452 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
20453 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
20454 C...Loop over flavours; consider full gamma/Z structure
20455 DO 720 I=MMINA,MMAXA
20456 IF(I.EQ.0) GOTO 720
20457 EI=KCHG(IABS(I),1)/3D0
20460 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
20461 & (VI**2+AI**2)*HFZZ)/HBW4
20462 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
20464 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710
20465 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710
20468 ISIG(NCHN,3-ISDE)=22
20470 SIGH(NCHN)=FACZQ*FZQN/FZQD
20474 ELSEIF(ISUB.EQ.36) THEN
20475 C...f + gamma -> f' + W+/-
20476 FWQ=COMFAC*AEM**2/(2D0*XW)*
20477 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
20478 C...Propagators: as simulated in PYOFSH and as desired
20479 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
20480 CALL PYWIDT(24,SQM4,WDTP,WDTE)
20481 GMMWC=SQRT(SQM4)*WDTP(0)
20482 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
20484 DO 740 I=MMINA,MMAXA
20485 IF(I.EQ.0) GOTO 740
20487 EIA=ABS(KCHG(IABS(I),1)/3D0)
20488 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
20489 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
20490 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
20492 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730
20493 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730
20496 ISIG(NCHN,3-ISDE)=22
20498 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
20502 ELSEIF(ISUB.EQ.37) THEN
20503 C...f + gamma -> f + h0
20505 ELSEIF(ISUB.EQ.38) THEN
20506 C...f + Z0 -> f + g (q + Z0 -> q + g only)
20508 ELSEIF(ISUB.EQ.39) THEN
20509 C...f + Z0 -> f + gamma
20511 ELSEIF(ISUB.EQ.40) THEN
20512 C...f + Z0 -> f + Z0
20515 ELSEIF(ISUB.LE.50) THEN
20516 IF(ISUB.EQ.41) THEN
20517 C...f + Z0 -> f' + W+/-
20519 ELSEIF(ISUB.EQ.42) THEN
20520 C...f + Z0 -> f + h0
20522 ELSEIF(ISUB.EQ.43) THEN
20523 C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
20525 ELSEIF(ISUB.EQ.44) THEN
20526 C...f + W+/- -> f' + gamma
20528 ELSEIF(ISUB.EQ.45) THEN
20529 C...f + W+/- -> f' + Z0
20531 ELSEIF(ISUB.EQ.46) THEN
20532 C...f + W+/- -> f' + W+/-
20534 ELSEIF(ISUB.EQ.47) THEN
20535 C...f + W+/- -> f' + h0
20537 ELSEIF(ISUB.EQ.48) THEN
20538 C...f + h0 -> f + g (q + h0 -> q + g only)
20540 ELSEIF(ISUB.EQ.49) THEN
20541 C...f + h0 -> f + gamma
20543 ELSEIF(ISUB.EQ.50) THEN
20544 C...f + h0 -> f + Z0
20547 ELSEIF(ISUB.LE.60) THEN
20548 IF(ISUB.EQ.51) THEN
20549 C...f + h0 -> f' + W+/-
20551 ELSEIF(ISUB.EQ.52) THEN
20552 C...f + h0 -> f + h0
20554 ELSEIF(ISUB.EQ.53) THEN
20555 C...g + g -> f + fbar (g + g -> q + qbar only)
20556 CALL PYWIDT(21,SH,WDTP,WDTE)
20557 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
20558 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
20559 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
20560 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
20561 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750
20574 ELSEIF(ISUB.EQ.54) THEN
20575 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
20576 CALL PYWIDT(21,SH,WDTP,WDTE)
20578 DO 760 I=1,MIN(8,MDCY(21,3))
20580 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
20583 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
20584 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
20591 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
20599 ELSEIF(ISUB.EQ.55) THEN
20600 C...g + Z -> f + fbar (g + Z -> q + qbar only)
20602 ELSEIF(ISUB.EQ.56) THEN
20603 C...g + W -> f + f'bar (g + W -> q + q'bar only)
20605 ELSEIF(ISUB.EQ.57) THEN
20606 C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
20608 ELSEIF(ISUB.EQ.58) THEN
20609 C...gamma + gamma -> f + fbar
20610 CALL PYWIDT(22,SH,WDTP,WDTE)
20612 DO 770 I=1,MIN(12,MDCY(22,3))
20613 IF(I.LE.8) EF= KCHG(I,1)/3D0
20614 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
20615 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
20618 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
20619 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
20627 ELSEIF(ISUB.EQ.59) THEN
20628 C...gamma + Z0 -> f + fbar
20630 ELSEIF(ISUB.EQ.60) THEN
20631 C...gamma + W+/- -> f + fbar'
20634 ELSEIF(ISUB.LE.70) THEN
20635 IF(ISUB.EQ.61) THEN
20636 C...gamma + h0 -> f + fbar
20638 ELSEIF(ISUB.EQ.62) THEN
20639 C...Z0 + Z0 -> f + fbar
20641 ELSEIF(ISUB.EQ.63) THEN
20642 C...Z0 + W+/- -> f + fbar'
20644 ELSEIF(ISUB.EQ.64) THEN
20645 C...Z0 + h0 -> f + fbar
20647 ELSEIF(ISUB.EQ.65) THEN
20648 C...W+ + W- -> f + fbar
20650 ELSEIF(ISUB.EQ.66) THEN
20651 C...W+/- + h0 -> f + fbar'
20653 ELSEIF(ISUB.EQ.67) THEN
20654 C...h0 + h0 -> f + fbar
20656 ELSEIF(ISUB.EQ.68) THEN
20658 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
20660 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
20662 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
20664 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780
20669 SIGH(NCHN)=0.5D0*FACGG1
20674 SIGH(NCHN)=0.5D0*FACGG2
20679 SIGH(NCHN)=0.5D0*FACGG3
20682 ELSEIF(ISUB.EQ.69) THEN
20683 C...gamma + gamma -> W+ + W-
20684 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
20685 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
20686 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
20687 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
20688 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790
20696 ELSEIF(ISUB.EQ.70) THEN
20697 C...gamma + W+/- -> Z0 + W+/-
20698 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
20699 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
20700 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
20701 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
20702 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
20703 DO 810 KCHW=1,-1,-2
20705 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800
20708 ISIG(NCHN,3-ISDE)=24*KCHW
20710 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
20715 ELSEIF(ISUB.LE.80) THEN
20716 IF(ISUB.EQ.71) THEN
20717 C...Z0 + Z0 -> Z0 + Z0
20718 IF(SH.LE.4.01D0*SQMZ) GOTO 840
20720 IF(MSTP(46).LE.2) THEN
20721 C...Exact scattering ME:s for on-mass-shell gauge bosons
20722 BE2=1D0-4D0*SQMZ/SH
20723 TH=-0.5D0*SH*BE2*(1D0-CTH)
20724 UH=-0.5D0*SH*BE2*(1D0+CTH)
20725 IF(MAX(TH,UH).GT.-1D0) GOTO 840
20726 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
20727 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
20728 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
20729 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
20730 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
20731 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
20732 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
20733 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
20734 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
20735 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
20736 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
20737 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
20738 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
20739 & (ASHIM+ATHIM+AUHIM)**2)
20740 IF(MSTP(46).EQ.2) FACZZ=0D0
20743 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20744 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
20745 & ABS(A00U+2.*A20U)**2
20747 FACZZ=FACZZ*WIDS(23,1)
20749 DO 830 I=MMIN1,MMAX1
20750 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830
20751 EI=KCHG(IABS(I),1)/3D0
20755 DO 820 J=MMIN2,MMAX2
20756 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820
20757 EJ=KCHG(IABS(J),1)/3D0
20765 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
20770 ELSEIF(ISUB.EQ.72) THEN
20771 C...Z0 + Z0 -> W+ + W-
20772 IF(SH.LE.4.01D0*SQMZ) GOTO 870
20774 IF(MSTP(46).LE.2) THEN
20775 C...Exact scattering ME:s for on-mass-shell gauge bosons
20776 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
20778 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
20779 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
20780 IF(MAX(TH,UH).GT.-1D0) GOTO 870
20781 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
20782 & (1D0-2D0*SQMZ/SH)
20783 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
20784 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
20785 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
20786 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
20787 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
20788 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
20789 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
20791 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
20792 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
20793 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
20794 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
20795 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
20797 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
20799 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
20800 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
20801 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
20802 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
20803 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
20804 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
20805 & (ATWIM+AUWIM+A4IM)**2)
20808 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20809 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
20810 & ABS(A00U-A20U)**2
20812 FACWW=FACWW*WIDS(24,1)
20814 DO 860 I=MMIN1,MMAX1
20815 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
20816 EI=KCHG(IABS(I),1)/3D0
20820 DO 850 J=MMIN2,MMAX2
20821 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
20822 EJ=KCHG(IABS(J),1)/3D0
20830 SIGH(NCHN)=FACWW*AVI*AVJ
20835 ELSEIF(ISUB.EQ.73) THEN
20836 C...Z0 + W+/- -> Z0 + W+/-
20837 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900
20839 IF(MSTP(46).LE.2) THEN
20840 C...Exact scattering ME:s for on-mass-shell gauge bosons
20841 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
20842 EP1=1D0-(SQMZ-SQMW)/SH
20843 EP2=1D0+(SQMZ-SQMW)/SH
20844 TH=-0.5D0*SH*BE2*(1D0-CTH)
20845 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
20846 IF(MAX(TH,UH).GT.-1D0) GOTO 900
20847 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
20848 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
20849 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
20850 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
20851 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
20852 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
20853 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
20855 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
20856 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
20857 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
20858 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
20859 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
20860 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
20861 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
20862 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
20863 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
20864 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
20865 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
20866 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
20868 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
20869 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
20871 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
20872 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
20873 IF(MSTP(46).LE.0) FACZW=0D0
20874 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
20875 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
20876 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
20877 & (ASWIM+AUWIM+A4IM)**2)
20880 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20881 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
20882 & ABS(A20U+3.*A11U*SNGL(CTH))**2
20884 FACZW=FACZW*WIDS(23,2)
20886 DO 890 I=MMIN1,MMAX1
20887 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890
20888 EI=KCHG(IABS(I),1)/3D0
20892 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
20893 DO 880 J=MMIN2,MMAX2
20894 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880
20895 EJ=KCHG(IABS(J),1)/3D0
20899 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
20904 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
20909 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
20914 ELSEIF(ISUB.EQ.75) THEN
20915 C...W+ + W- -> gamma + gamma
20917 ELSEIF(ISUB.EQ.76) THEN
20918 C...W+ + W- -> Z0 + Z0
20919 IF(SH.LE.4.01D0*SQMZ) GOTO 930
20921 IF(MSTP(46).LE.2) THEN
20922 C...Exact scattering ME:s for on-mass-shell gauge bosons
20923 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
20925 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
20926 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
20927 IF(MAX(TH,UH).GT.-1D0) GOTO 930
20928 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
20929 & (1D0-2D0*SQMZ/SH)
20930 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
20931 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
20932 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
20933 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
20934 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
20935 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
20936 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
20938 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
20939 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
20940 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
20941 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
20942 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
20944 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
20946 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
20948 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
20949 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
20950 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
20951 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
20952 & (ATWIM+AUWIM+A4IM)**2)
20955 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20956 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
20957 & ABS(A00U-A20U)**2
20959 FACZZ=FACZZ*WIDS(23,1)
20961 DO 920 I=MMIN1,MMAX1
20962 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920
20963 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
20964 DO 910 J=MMIN2,MMAX2
20965 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910
20966 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
20967 IF(EI*EJ.GT.0D0) GOTO 910
20972 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
20977 ELSEIF(ISUB.EQ.77) THEN
20978 C...W+/- + W+/- -> W+/- + W+/-
20979 IF(SH.LE.4.01D0*SQMW) GOTO 960
20981 IF(MSTP(46).LE.2) THEN
20982 C...Exact scattering ME:s for on-mass-shell gauge bosons
20983 BE2=1D0-4D0*SQMW/SH
20987 TH=-0.5D0*SH*BE2*(1D0-CTH)
20988 UH=-0.5D0*SH*BE2*(1D0+CTH)
20989 IF(MAX(TH,UH).GT.-1D0) GOTO 960
20991 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
20992 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
20994 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
20995 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
20997 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
20998 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
20999 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
21002 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
21004 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
21005 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
21006 ATGRE=0.5D0*XW*SH/TH*TGZANG
21008 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
21010 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
21011 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
21012 AUGRE=0.5D0*XW*SH/UH*UGZANG
21014 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
21016 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
21018 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
21020 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
21022 IF(MSTP(46).LE.0) THEN
21027 ELSEIF(MSTP(46).EQ.1) THEN
21028 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
21029 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
21030 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
21031 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
21033 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
21034 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
21035 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
21036 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
21038 AWWA2=AWWARE**2+AWWAIM**2
21039 AWWS2=AWWSRE**2+AWWSIM**2
21042 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
21043 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
21044 & ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2
21045 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
21048 DO 950 I=MMIN1,MMAX1
21049 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950
21050 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
21051 DO 940 J=MMIN2,MMAX2
21052 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940
21053 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
21054 IF(EI*EJ.LT.0D0) THEN
21056 IF(MSTP(45).EQ.1) GOTO 940
21057 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
21058 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
21061 IF(MSTP(45).EQ.2) GOTO 940
21062 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
21063 IF(MSTP(46).GE.3) FACWW=FWWS
21064 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
21065 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
21071 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
21072 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
21077 ELSEIF(ISUB.EQ.78) THEN
21078 C...W+/- + h0 -> W+/- + h0
21080 ELSEIF(ISUB.EQ.79) THEN
21081 C...h0 + h0 -> h0 + h0
21083 ELSEIF(ISUB.EQ.80) THEN
21084 C...q + gamma -> q' + pi+/-
21085 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
21086 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
21087 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
21088 DELSH=UH*SQRT(ASSH*Q2FPSH)
21089 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
21090 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
21091 DELUH=SH*SQRT(ASUH*Q2FPUH)
21092 DO 980 I=MAX(-2,MMINA),MIN(2,MMAXA)
21093 IF(I.EQ.0) GOTO 980
21094 EI=KCHG(IABS(I),1)/3D0
21095 EJ=SIGN(1D0-ABS(EI),EI)
21097 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970
21098 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970
21101 ISIG(NCHN,3-ISDE)=22
21103 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
21109 C...C: 2 -> 2, tree diagrams with masses
21111 ELSEIF(ISUB.LE.90) THEN
21112 IF(ISUB.EQ.81) THEN
21113 C...q + qbar -> Q + Qbar
21114 SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21115 FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQMA)**2+
21116 & (UH-SQMA)**2)/SH2+2D0*SQMA/SH)
21117 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMA,0D0)
21119 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21120 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21122 DO 990 I=MMINA,MMAXA
21123 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21124 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990
21132 ELSEIF(ISUB.EQ.82) THEN
21133 C...g + g -> Q + Qbar
21134 SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21135 IF(MSTP(34).EQ.0) THEN
21136 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQMA)/(TH-SQMA)-
21137 & 2D0*(UH-SQMA)**2/SH2+4D0*(SQMA/SH)*(TH*UH-SQMA**2)/
21139 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQMA)/(UH-SQMA)-
21140 & 2D0*(TH-SQMA)**2/SH2+4D0*(SQMA/SH)*(TH*UH-SQMA**2)/
21143 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQMA)/(TH-SQMA)-
21144 & 2.25D0*(UH-SQMA)**2/SH2+4.5D0*(SQMA/SH)*(TH*UH-SQMA**2)/
21145 & (TH-SQMA)**2+0.5D0*SQMA*TH/(TH-SQMA)**2-SQMA**2/
21147 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQMA)/(UH-SQMA)-
21148 & 2.25D0*(TH-SQMA)**2/SH2+4.5D0*(SQMA/SH)*(TH*UH-SQMA**2)/
21149 & (UH-SQMA)**2+0.5D0*SQMA*UH/(UH-SQMA)**2-SQMA**2/
21152 IF(MSTP(35).GE.1) THEN
21153 FATRE=PYHFTH(SH,SQMA,2D0/7D0)
21154 FACQQ1=FACQQ1*FATRE
21155 FACQQ2=FACQQ2*FATRE
21158 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21159 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21162 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1000
21175 ELSEIF(ISUB.EQ.83) THEN
21176 C...f + q -> f' + Q
21177 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
21178 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
21179 DO 1020 I=MMIN1,MMAX1
21180 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
21181 DO 1010 J=MMIN2,MMAX2
21182 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
21183 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010
21184 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010
21185 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
21191 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
21192 & (IABS(I)+1)/2)*VINT(180+J)
21193 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
21194 & (MINT(55)+1)/2)*VINT(180+J)
21197 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
21198 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
21201 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
21202 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
21205 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
21206 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
21208 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
21214 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
21215 & (IABS(J)+1)/2)*VINT(180+I)
21216 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
21217 & (MINT(55)+1)/2)*VINT(180+I)
21219 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
21220 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
21223 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
21224 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
21227 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
21228 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
21233 ELSEIF(ISUB.EQ.84) THEN
21234 C...g + gamma -> Q + Qbar
21235 SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21236 FMTU=SQMA/(SQMA-TH)+SQMA/(SQMA-UH)
21237 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
21238 & ((SQMA-TH)/(SQMA-UH)+(SQMA-UH)/(SQMA-TH)+4D0*FMTU*(1D0-FMTU))
21239 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMA,0D0)
21241 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21242 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21244 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21251 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21259 ELSEIF(ISUB.EQ.85) THEN
21260 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
21261 SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21262 FMTU=SQMA/(SQMA-TH)+SQMA/(SQMA-UH)
21263 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
21264 & ((SQMA-TH)/(SQMA-UH)+(SQMA-UH)/(SQMA-TH)+4D0*FMTU*(1D0-FMTU))
21265 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
21266 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
21267 & FACFF=FACFF*PYHFTH(SH,SQMA,1D0)
21269 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
21270 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
21271 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
21273 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21281 ELSEIF(ISUB.EQ.86) THEN
21282 C...g + g -> J/Psi + g
21283 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
21284 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
21285 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
21286 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21294 ELSEIF(ISUB.EQ.87) THEN
21295 C...g + g -> chi_0c + g
21296 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
21297 QGTW=(SH*TH*UH)/SH**3
21299 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
21300 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
21301 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
21302 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
21303 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
21304 & (QGTW*(QGTW-RGTW*PGTW)**4)
21305 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21313 ELSEIF(ISUB.EQ.88) THEN
21314 C...g + g -> chi_1c + g
21315 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
21316 QGTW=(SH*TH*UH)/SH**3
21318 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
21319 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
21320 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
21321 & (QGTW-RGTW*PGTW)**4
21322 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21330 ELSEIF(ISUB.EQ.89) THEN
21331 C...g + g -> chi_2c + g
21332 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
21333 QGTW=(SH*TH*UH)/SH**3
21335 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
21336 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
21337 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
21338 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
21339 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
21340 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
21341 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21350 C...D: Mimimum bias processes
21352 ELSEIF(ISUB.LE.100) THEN
21353 IF(ISUB.EQ.91) THEN
21354 C...Elastic scattering
21355 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
21357 ELSEIF(ISUB.EQ.92) THEN
21358 C...Single diffractive scattering (first side, i.e. XB)
21359 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
21361 ELSEIF(ISUB.EQ.93) THEN
21362 C...Single diffractive scattering (second side, i.e. AX)
21363 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
21365 ELSEIF(ISUB.EQ.94) THEN
21366 C...Double diffractive scattering
21367 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
21369 ELSEIF(ISUB.EQ.95) THEN
21370 C...Low-pT scattering
21371 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
21373 ELSEIF(ISUB.EQ.96) THEN
21374 C...Multiple interactions: sum of QCD processes
21375 CALL PYWIDT(21,SH,WDTP,WDTE)
21377 C...q + q' -> q + q'
21378 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21379 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21380 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21381 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
21382 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21383 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21385 IF(I.EQ.0) GOTO 1040
21387 IF(J.EQ.0) GOTO 1030
21393 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21395 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
21400 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21405 C...q + qbar -> q' + qbar' or g + g
21406 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21407 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
21408 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21410 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21413 IF(I.EQ.0) GOTO 1050
21423 SIGH(NCHN)=0.5D0*FACGG1
21428 SIGH(NCHN)=0.5D0*FACGG2
21432 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21434 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21437 IF(I.EQ.0) GOTO 1070
21441 ISIG(NCHN,3-ISDE)=21
21446 ISIG(NCHN,3-ISDE)=21
21452 C...g + g -> q + qbar or g + g
21453 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21454 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
21455 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21456 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
21457 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
21458 & 2D0*TH/SH+TH2/SH2)*FACA
21459 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
21460 & 2D0*SH/UH+SH2/UH2)*FACA
21461 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
21462 & 2D0*UH/TH+UH2/TH2)
21477 SIGH(NCHN)=0.5D0*FACGG1
21482 SIGH(NCHN)=0.5D0*FACGG2
21487 SIGH(NCHN)=0.5D0*FACGG3
21489 ELSEIF(ISUB.EQ.99) THEN
21490 C...f + gamma* -> f.
21491 IF(MINT(107).EQ.4) THEN
21500 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)
21501 PM2RHO=PMAS(PYCOMP(113),1)**2
21502 IF(MSTP(19).EQ.0) THEN
21504 ELSEIF(MSTP(19).EQ.1) THEN
21505 COMFAC=COMFAC/(Q2GA+PM2RHO)
21506 ELSEIF(MSTP(19).EQ.2) THEN
21507 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21509 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21511 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
21512 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
21513 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
21514 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
21516 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
21518 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
21520 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
21521 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
21523 DO 1075 I=MMINA,MMAXA
21524 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 1075
21525 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 1075
21526 EI=KCHG(IABS(I),1)/3D0
21529 ISIG(NCHN,3-ISDE)=22
21531 SIGH(NCHN)=COMFAC*EI**2
21535 C...E: 2 -> 1, loop diagrams
21537 ELSEIF(ISUB.LE.110) THEN
21538 IF(ISUB.EQ.101) THEN
21539 C...g + g -> gamma*/Z0
21541 ELSEIF(ISUB.EQ.102) THEN
21542 C...g + g -> h0 (or H0, or A0)
21543 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
21545 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21546 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21547 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
21549 HI=SHR*WDTP(13)/32D0
21550 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080
21555 SIGH(NCHN)=HI*FACBW*HF
21558 ELSEIF(ISUB.EQ.103) THEN
21559 C...gamma + gamma -> h0 (or H0, or A0)
21560 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
21562 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21563 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21564 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
21566 HI=SHR*WDTP(14)*2D0
21567 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090
21572 SIGH(NCHN)=HI*FACBW*HF
21575 ELSEIF(ISUB.EQ.104) THEN
21576 C...g + g -> chi_c0.
21578 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
21579 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
21580 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
21581 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21589 ELSEIF(ISUB.EQ.105) THEN
21590 C...g + g -> chi_c2.
21592 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
21593 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
21594 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
21595 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21603 C...Continuation C: 2 -> 2, tree diagrams with masses.
21605 ELSEIF(ISUB.EQ.106) THEN
21606 C...g + g -> J/Psi + gamma.
21608 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
21609 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
21610 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
21611 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21619 ELSEIF(ISUB.EQ.107) THEN
21620 C...g + gamma -> J/Psi + g.
21622 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
21623 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
21624 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
21625 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21632 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21640 ELSEIF(ISUB.EQ.108) THEN
21641 C...gamma + gamma -> J/Psi + gamma.
21643 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
21644 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
21645 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
21646 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21654 C...F: 2 -> 2, box diagrams
21656 ELSEIF(ISUB.EQ.110) THEN
21657 C...f + fbar -> gamma + h0
21658 THUH=MAX(TH*UH,SH*CKIN(3)**2)
21659 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
21660 FACHG=FACHG*WIDS(KFHIGG,2)
21661 C...Calculate loop contributions for intermediate gamma* and Z0
21662 CIGTOT=CMPLX(0.,0.)
21663 CIZTOT=CMPLX(0.,0.)
21666 IF(J.LE.2*MSTP(1)) THEN
21669 AJ=SIGN(1D0,EJ+0.1D0)
21671 BALP=SQM4/(2D0*PMAS(J,1))**2
21672 BBET=SH/(2D0*PMAS(J,1))**2
21673 ELSEIF(J.LE.3*MSTP(1)) THEN
21675 JL=2*(J-2*MSTP(1))-1
21676 EJ=KCHG(10+JL,1)/3D0
21677 AJ=SIGN(1D0,EJ+0.1D0)
21679 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
21680 BBET=SH/(2D0*PMAS(10+JL,1))**2
21682 BALP=SQM4/(2D0*PMAS(24,1))**2
21683 BBET=SH/(2D0*PMAS(24,1))**2
21685 BABI=1D0/(BALP-BBET)
21686 IF(BALP.LT.1D0) THEN
21687 F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.)
21690 F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
21691 & -SNGL(0.5D0*PARU(1)))
21694 F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
21695 IF(BBET.LT.1D0) THEN
21696 F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.)
21699 F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
21700 & -SNGL(0.5D0*PARU(1)))
21703 F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET
21704 IF(J.LE.3*MSTP(1)) THEN
21705 FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+
21706 & BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP))
21707 CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF
21708 CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF
21711 CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)*
21712 & (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
21713 & SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
21714 CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP*
21715 & (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+
21716 & SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
21720 CIGTOT=CIGTOT/SNGL(SH)
21721 CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ))
21722 C...Loop over initial flavours
21723 DO 1110 I=MMINA,MMAXA
21724 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110
21725 EI=KCHG(IABS(I),1)/3D0
21729 IF(IABS(I).LE.10) FCOI=FACA/3D0
21734 SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)*
21735 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
21740 ELSEIF(ISUB.LE.120) THEN
21741 IF(ISUB.EQ.111) THEN
21742 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
21745 DO 1120 I=1,2*MSTP(1)
21749 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21750 CALL PYWAUX(1,EPSH,W1HR,W1HI)
21751 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21752 CALL PYWAUX(2,EPSH,W2HR,W2HI)
21753 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
21754 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
21755 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
21756 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
21758 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
21759 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
21760 FACGH=FACGH*WIDS(25,2)
21761 DO 1130 I=MMINA,MMAXA
21762 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21763 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130
21771 ELSEIF(ISUB.EQ.112) THEN
21772 C...f + g -> f + h0 (q + g -> q + h0 only)
21775 DO 1140 I=1,2*MSTP(1)
21779 CALL PYWAUX(1,EPST,W1TR,W1TI)
21780 CALL PYWAUX(1,EPSH,W1HR,W1HI)
21781 CALL PYWAUX(2,EPST,W2TR,W2TI)
21782 CALL PYWAUX(2,EPSH,W2HR,W2HI)
21783 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
21784 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
21785 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
21786 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
21788 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
21789 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
21790 FACQH=FACQH*WIDS(25,2)
21791 DO 1160 I=MMINA,MMAXA
21792 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160
21794 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150
21795 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150
21798 ISIG(NCHN,3-ISDE)=21
21804 ELSEIF(ISUB.EQ.113) THEN
21805 C...g + g -> g + h0
21814 DO 1170 I=1,2*MSTP(1)
21820 IF(EPSH.LT.1D-6) GOTO 1170
21821 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21822 CALL PYWAUX(1,EPST,W1TR,W1TI)
21823 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21824 CALL PYWAUX(1,EPSH,W1HR,W1HI)
21825 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21826 CALL PYWAUX(2,EPST,W2TR,W2TI)
21827 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21828 CALL PYWAUX(2,EPSH,W2HR,W2HI)
21829 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21830 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21831 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21832 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21833 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21834 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21835 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
21836 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
21837 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
21838 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
21839 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
21840 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
21841 W3STUR=YHSTUR-Y3STUR-Y3UTSR
21842 W3STUI=YHSTUI-Y3STUI-Y3UTSI
21843 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
21844 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
21845 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
21846 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
21847 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
21848 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
21849 W3USTR=YHUSTR-Y3USTR-Y3TSUR
21850 W3USTI=YHUSTI-Y3USTI-Y3TSUI
21851 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
21852 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
21853 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
21854 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
21855 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
21856 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
21857 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
21858 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
21859 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
21860 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
21861 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
21862 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
21863 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
21864 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
21865 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
21866 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
21867 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
21868 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
21869 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
21870 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
21871 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
21872 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
21873 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
21874 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
21875 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
21876 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
21877 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
21878 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
21879 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
21880 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
21881 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
21882 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
21883 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
21884 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
21885 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
21886 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
21887 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
21888 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
21889 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
21890 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
21891 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
21892 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
21893 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
21894 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
21895 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
21896 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
21897 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
21898 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
21899 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
21900 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
21901 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
21902 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
21903 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
21904 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
21905 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
21906 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
21907 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
21908 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
21909 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
21910 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
21911 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
21912 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
21913 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
21914 & (W2SR-W2HR+W3STUR))
21915 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
21916 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
21917 & (W2TR-W2HR+W3TUSR))
21918 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
21919 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
21920 & (W2UR-W2HR+W3USTR))
21921 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
21922 A2STUR=A2STUR+B2STUR+B2SUTR
21923 A2STUI=A2STUI+B2STUI+B2SUTI
21924 A2USTR=A2USTR+B2USTR+B2UTSR
21925 A2USTI=A2USTI+B2USTI+B2UTSI
21926 A2TUSR=A2TUSR+B2TUSR+B2TSUR
21927 A2TUSI=A2TUSI+B2TUSI+B2TSUI
21928 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
21929 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
21931 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
21932 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
21933 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
21934 FACGH=FACGH*WIDS(25,2)
21935 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180
21943 ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
21944 C...g + g -> gamma + gamma or g + g -> g + gamma
21959 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
21961 EI=KCHG(IABS(I),1)/3D0
21963 IF(ISUB.EQ.115) EIWT=EI
21968 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
21969 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
21972 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
21973 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
21974 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
21975 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
21981 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21982 CALL PYWAUX(1,EPST,W1TR,W1TI)
21983 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21984 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21985 CALL PYWAUX(2,EPST,W2TR,W2TI)
21986 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21987 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21988 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21989 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21990 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21991 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21992 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21993 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
21994 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
21995 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
21996 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
21997 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21998 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21999 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
22000 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
22001 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
22002 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
22003 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
22004 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
22005 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
22006 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
22007 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
22008 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
22009 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
22010 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
22011 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
22012 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
22013 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
22014 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
22015 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
22016 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
22017 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
22018 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
22019 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
22020 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
22021 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
22022 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
22023 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
22024 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
22025 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
22026 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
22027 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
22028 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
22029 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
22030 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
22031 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
22032 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
22033 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
22034 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
22035 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
22036 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
22037 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
22038 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
22039 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
22040 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
22041 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
22042 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
22044 A0STUR=A0STUR+EIWT*B0STUR
22045 A0STUI=A0STUI+EIWT*B0STUI
22046 A0TSUR=A0TSUR+EIWT*B0TSUR
22047 A0TSUI=A0TSUI+EIWT*B0TSUI
22048 A0UTSR=A0UTSR+EIWT*B0UTSR
22049 A0UTSI=A0UTSI+EIWT*B0UTSI
22050 A1STUR=A1STUR+EIWT*B1STUR
22051 A1STUI=A1STUI+EIWT*B1STUI
22052 A2STUR=A2STUR+EIWT*B2STUR
22053 A2STUI=A2STUI+EIWT*B2STUI
22055 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
22056 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
22057 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
22058 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
22059 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1200
22064 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
22065 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
22068 ELSEIF(ISUB.EQ.116) THEN
22069 C...g + g -> gamma + Z0
22071 ELSEIF(ISUB.EQ.117) THEN
22072 C...g + g -> Z0 + Z0
22074 ELSEIF(ISUB.EQ.118) THEN
22075 C...g + g -> W+ + W-
22079 C...G: 2 -> 3, tree diagrams
22081 ELSEIF(ISUB.LE.140) THEN
22082 IF(ISUB.EQ.121) THEN
22083 C...g + g -> Q + Qbar + h0
22084 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210
22087 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
22088 & (0.5D0*PMF/PMAS(24,1))**2
22090 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
22092 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
22094 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
22095 IF(IA.GT.10) IKFI=3
22096 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
22098 CALL PYQQBH(WTQQBH)
22099 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
22101 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22102 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
22103 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
22109 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
22112 ELSEIF(ISUB.EQ.122) THEN
22113 C...q + qbar -> Q + Qbar + h0
22116 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
22117 & (0.5D0*PMF/PMAS(24,1))**2
22119 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
22121 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
22123 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
22124 IF(IA.GT.10) IKFI=3
22125 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
22127 CALL PYQQBH(WTQQBH)
22128 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
22130 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22131 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
22132 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
22134 DO 1220 I=MMINA,MMAXA
22135 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22136 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220
22141 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
22144 ELSEIF(ISUB.EQ.123) THEN
22145 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
22147 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
22148 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
22149 & PARU(154+10*IHIGG)**2
22150 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
22151 & (VINT(216)-VINT(209)**2))**2
22152 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
22153 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
22154 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
22156 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22157 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
22158 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
22160 DO 1240 I=MMIN1,MMAX1
22161 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240
22163 DO 1230 J=MMIN2,MMAX2
22164 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230
22166 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
22167 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
22169 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
22170 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
22172 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
22173 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
22178 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
22182 ELSEIF(ISUB.EQ.124) THEN
22183 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
22185 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
22186 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
22187 & PARU(155+10*IHIGG)**2
22188 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
22189 & (VINT(216)-VINT(209)**2))**2
22190 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
22191 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
22193 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22194 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
22195 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
22197 DO 1260 I=MMIN1,MMAX1
22198 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260
22199 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
22200 DO 1250 J=MMIN2,MMAX2
22201 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250
22202 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
22203 IF(EI*EJ.GT.0D0) GOTO 1250
22204 FACLR=VINT(180+I)*VINT(180+J)
22209 SIGH(NCHN)=FACLR*FACWW*FACBW
22213 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
22214 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
22216 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
22218 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
22220 IF(ISUB.EQ.131) THEN
22221 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
22222 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
22224 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
22226 DO 1280 I=MMINA,MMAXA
22227 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1280
22228 EI=KCHG(IABS(I),1)/3D0
22231 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1270
22232 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1270
22235 ISIG(NCHN,3-ISDE)=22
22241 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
22242 C...f + gamma*_(T,L) -> f + gamma
22244 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
22246 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
22248 IF(ISUB.EQ.133) THEN
22249 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
22250 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
22252 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
22254 DO 1300 I=MMINA,MMAXA
22255 IF(I.EQ.0) GOTO 1300
22256 EI=KCHG(IABS(I),1)/3D0
22259 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1290
22260 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1290
22263 ISIG(NCHN,3-ISDE)=22
22269 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
22270 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
22272 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
22274 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
22276 CALL PYWIDT(21,SH,WDTP,WDTE)
22278 DO 1310 I=1,MIN(8,MDCY(21,3))
22280 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22283 IF(ISUB.EQ.135) THEN
22284 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
22285 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
22287 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
22289 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22296 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22304 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
22305 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
22307 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
22309 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
22310 CALL PYWIDT(22,SH,WDTP,WDTE)
22312 DO 1320 I=1,MIN(12,MDCY(22,3))
22313 IF(I.LE.8) EF= KCHG(I,1)/3D0
22314 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
22315 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22318 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
22319 IF(ISUB.EQ.137) THEN
22320 FPARAM=-SH*(TH+UH)/DLAMB2
22321 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
22322 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
22323 & 2D0*PH1*PH2*FPARAM**2)
22324 ELSEIF(ISUB.EQ.138) THEN
22325 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
22326 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
22327 & 2D0*PH1**2*(TH-UH)**2)
22328 ELSEIF(ISUB.EQ.139) THEN
22329 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
22330 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
22331 & 2D0*PH2**2*(TH-UH)**2)
22333 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
22334 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
22336 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22346 C...H: 2 -> 1, tree diagrams, non-standard model processes
22348 ELSEIF(ISUB.LE.160) THEN
22349 IF(ISUB.EQ.141) THEN
22350 C...f + fbar -> gamma*/Z0/Z'0
22351 SQMZP=PMAS(32,1)**2
22353 CALL PYWIDT(32,SH,WDTP,WDTE)
22359 FACZP=4D0*COMFAC*3D0
22360 DO 1330 I=MMINA,MMAXA
22361 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1330
22362 EI=KCHG(IABS(I),1)/3D0
22368 VPI=PARU(123-2*MOD(IABS(I),2))
22369 API=PARU(124-2*MOD(IABS(I),2))
22370 ELSEIF(IA.LE.4) THEN
22371 VPI=PARJ(182-2*MOD(IABS(I),2))
22372 API=PARJ(183-2*MOD(IABS(I),2))
22374 VPI=PARJ(190-2*MOD(IABS(I),2))
22375 API=PARJ(191-2*MOD(IABS(I),2))
22379 VPI=PARU(127-2*MOD(IABS(I),2))
22380 API=PARU(128-2*MOD(IABS(I),2))
22381 ELSEIF(IA.LE.14) THEN
22382 VPI=PARJ(186-2*MOD(IABS(I),2))
22383 API=PARJ(187-2*MOD(IABS(I),2))
22385 VPI=PARJ(194-2*MOD(IABS(I),2))
22386 API=PARJ(195-2*MOD(IABS(I),2))
22390 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
22392 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
22394 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
22399 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
22400 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
22401 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
22402 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
22403 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
22404 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
22405 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
22406 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
22409 ELSEIF(ISUB.EQ.142) THEN
22410 C...f + fbar' -> W'+/-
22411 SQMWP=PMAS(34,1)**2
22412 CALL PYWIDT(34,SH,WDTP,WDTE)
22414 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
22415 HP=AEM/(24D0*XW)*SH
22416 DO 1350 I=MMIN1,MMAX1
22417 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1350
22419 DO 1340 J=MMIN2,MMAX2
22420 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1340
22422 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1340
22423 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22425 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22426 HI=HP*(PARU(133)**2+PARU(134)**2)
22427 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
22428 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22433 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
22434 SIGH(NCHN)=HI*FACBW*HF
22438 ELSEIF(ISUB.EQ.143) THEN
22439 C...f + fbar' -> H+/-
22440 SQMHC=PMAS(37,1)**2
22441 CALL PYWIDT(37,SH,WDTP,WDTE)
22443 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
22444 HP=AEM/(8D0*XW)*SH/SQMW*SH
22445 DO 1370 I=MMIN1,MMAX1
22446 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1370
22448 IM=(MOD(IA,10)+1)/2
22449 DO 1360 J=MMIN2,MMAX2
22450 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1360
22452 JM=(MOD(JA,10)+1)/2
22453 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1360
22454 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22456 IF(MOD(IA,2).EQ.0) THEN
22463 RML=PYMRUN(IL,SH)**2/SH
22464 RMU=PYMRUN(IU,SH)**2/SH
22465 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
22466 IF(IA.LE.10) HI=HI*FACA/3D0
22467 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22468 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
22473 SIGH(NCHN)=HI*FACBW*HF
22477 ELSEIF(ISUB.EQ.144) THEN
22480 CALL PYWIDT(40,SH,WDTP,WDTE)
22482 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
22483 HP=AEM/(12D0*XW)*SH
22484 DO 1390 I=MMIN1,MMAX1
22485 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1390
22487 DO 1380 J=MMIN2,MMAX2
22488 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1380
22490 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1380
22492 IF(IA.LE.10) HI=HI*FACA/3D0
22493 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
22498 SIGH(NCHN)=HI*FACBW*HF
22502 ELSEIF(ISUB.EQ.145) THEN
22503 C...q + l -> LQ (leptoquark)
22504 SQMLQ=PMAS(39,1)**2
22505 CALL PYWIDT(39,SH,WDTP,WDTE)
22507 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
22508 IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0
22510 KFLQQ=KFDP(MDCY(39,2),1)
22511 KFLQL=KFDP(MDCY(39,2),2)
22512 DO 1410 I=MMIN1,MMAX1
22513 IF(KFAC(1,I).EQ.0) GOTO 1410
22515 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1410
22516 DO 1400 J=MMIN2,MMAX2
22517 IF(KFAC(2,J).EQ.0) GOTO 1400
22519 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1400
22520 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1400
22521 IF(JA.EQ.IA) GOTO 1400
22522 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
22523 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
22525 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
22530 SIGH(NCHN)=HI*FACBW*HF
22534 ELSEIF(ISUB.EQ.146) THEN
22535 C...e + gamma* -> e* (excited lepton)
22536 KFQSTR=KFPR(ISUB,1)
22537 KCQSTR=PYCOMP(KFQSTR)
22538 KFQEXC=MOD(KFQSTR,KEXCIT)
22539 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
22541 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
22542 QF=-PARU(157)/2D0-PARU(158)/2D0
22543 FACBW=FACBW*AEM*QF**2*SH/PARU(155)**2
22544 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
22547 DO 1416 I=-KFQEXC,KFQEXC,2*KFQEXC
22549 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1413
22550 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1413
22552 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22553 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
22556 ISIG(NCHN,3-ISDE)=22
22558 SIGH(NCHN)=HI*FACBW*HF
22562 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
22563 C...d + g -> d* and u + g -> u* (excited quarks)
22564 KFQSTR=KFPR(ISUB,1)
22565 KCQSTR=PYCOMP(KFQSTR)
22566 KFQEXC=MOD(KFQSTR,KEXCIT)
22567 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
22569 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
22570 FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
22571 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
22574 DO 1430 I=-KFQEXC,KFQEXC,2*KFQEXC
22576 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1420
22577 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1420
22579 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22580 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
22583 ISIG(NCHN,3-ISDE)=21
22585 SIGH(NCHN)=HI*FACBW*HF
22589 ELSEIF(ISUB.EQ.149) THEN
22590 C...g + g -> eta_techni
22591 CALL PYWIDT(38,SH,WDTP,WDTE)
22593 FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2)
22594 IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0
22596 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1440
22598 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22603 SIGH(NCHN)=HI*FACBW*HF
22608 C...I: 2 -> 2, tree diagrams, non-standard model processes
22610 ELSEIF(ISUB.LE.200) THEN
22611 IF(ISUB.EQ.161) THEN
22612 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
22613 C...(choice of only b and t to avoid kinematics problems)
22614 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
22615 C...H propagator: as simulated in PYOFSH and as desired
22616 SQMHC=PMAS(37,1)**2
22617 GMMHC=PMAS(37,1)*PMAS(37,2)
22618 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
22619 CALL PYWIDT(37,SQM4,WDTP,WDTE)
22620 GMMHCC=SQRT(SQM4)*WDTP(0)
22621 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
22622 FHCQ=FHCQ*HBW4C/HBW4
22623 DO 1460 I=MMINA,MMAXA
22625 IF(IA.NE.5) GOTO 1460
22626 SQML=PYMRUN(IA,SH)**2
22628 SQMQ=PYMRUN(IUA,SH)**2
22629 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
22630 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
22631 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
22632 & (SQMHC-SQMQ-SH)/SH)
22633 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22635 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1450
22636 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1450
22639 ISIG(NCHN,3-ISDE)=21
22641 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
22645 ELSEIF(ISUB.EQ.162) THEN
22646 C...q + g -> LQ + lbar; LQ=leptoquark
22647 SQMLQ=PMAS(39,1)**2
22648 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
22649 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
22650 KFLQQ=KFDP(MDCY(39,2),1)
22651 DO 1480 I=MMINA,MMAXA
22652 IF(IABS(I).NE.KFLQQ) GOTO 1480
22655 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1470
22656 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1470
22659 ISIG(NCHN,3-ISDE)=21
22661 SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
22665 ELSEIF(ISUB.EQ.163) THEN
22666 C...g + g -> LQ + LQbar; LQ=leptoquark
22667 SQMLQ=PMAS(39,1)**2
22668 FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)*
22669 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
22670 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
22671 & ((TH-SQMLQ)*(UH-SQMLQ)))
22672 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1490
22676 C...Since don't know proper colour flow, randomize between alternatives
22677 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
22681 ELSEIF(ISUB.EQ.164) THEN
22682 C...q + qbar -> LQ + LQbar; LQ=leptoquark
22683 SQMLQ=PMAS(39,1)**2
22684 FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)*
22685 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
22686 FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)*
22687 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
22688 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
22689 KFLQQ=KFDP(MDCY(39,2),1)
22690 DO 1500 I=MMINA,MMAXA
22691 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22692 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
22698 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
22701 ELSEIF(ISUB.EQ.165) THEN
22702 C...q + qbar -> l+ + l- (including contact term for compositeness)
22703 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
22704 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
22705 KFF=IABS(KFPR(ISUB,1))
22707 AF=SIGN(1D0,EF+0.1D0)
22712 IF(KFF.LE.10) FCOF=3D0
22714 IF(KFF.EQ.6) WID2=WIDS(6,1)
22715 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
22716 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
22717 DO 1510 I=MMINA,MMAXA
22718 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1510
22719 EI=KCHG(IABS(I),1)/3D0
22720 AI=SIGN(1D0,EI+0.1D0)
22725 IF(IABS(I).LE.10) FCOI=FACA/3D0
22726 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
22727 FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
22728 & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
22729 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
22731 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
22732 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
22734 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
22735 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
22736 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
22737 IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
22738 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
22743 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
22746 ELSEIF(ISUB.EQ.166) THEN
22747 C...q + q'bar -> l + nu_l (including contact term for compositeness)
22748 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
22749 WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
22750 KFF=IABS(KFPR(ISUB,1))
22752 IF(KFF.LE.10) FCOF=3D0
22753 DO 1530 I=MMIN1,MMAX1
22754 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1530
22756 DO 1520 J=MMIN2,MMAX2
22757 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1520
22759 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1520
22760 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22763 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22765 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
22766 & MOD(J,2).EQ.0)) THEN
22767 IF(KFF.EQ.5) WID2=WIDS(6,2)
22768 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
22769 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
22771 IF(KFF.EQ.5) WID2=WIDS(6,3)
22772 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
22773 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
22779 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
22780 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
22781 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
22785 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
22786 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
22787 KFQSTR=KFPR(ISUB,2)
22788 KCQSTR=PYCOMP(KFQSTR)
22789 KFQEXC=MOD(KFQSTR,KEXCIT)
22790 FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
22791 FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
22792 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
22793 C...Propagators: as simulated in PYOFSH and as desired
22794 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
22795 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
22796 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
22797 GMMQC=SQRT(SQM4)*WDTP(0)
22798 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
22799 FACQSA=FACQSA*HBW4C/HBW4
22800 FACQSB=FACQSB*HBW4C/HBW4
22801 DO 1550 I=MMIN1,MMAX1
22803 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1550
22804 DO 1540 J=MMIN2,MMAX2
22806 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1540
22807 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
22812 SIGH(NCHN)=(4D0/3D0)*FACQSA
22817 SIGH(NCHN)=(4D0/3D0)*FACQSA
22818 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
22823 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
22825 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
22830 SIGH(NCHN)=(8D0/3D0)*FACQSB
22835 SIGH(NCHN)=(8D0/3D0)*FACQSB
22836 ELSEIF(I.EQ.-J) THEN
22847 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
22852 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
22858 ELSEIF(ISUB.EQ.169) THEN
22859 C...q + qbar -> e + e* (excited lepton)
22860 KFQSTR=KFPR(ISUB,2)
22861 KCQSTR=PYCOMP(KFQSTR)
22862 KFQEXC=MOD(KFQSTR,KEXCIT)
22863 FACQSB=(COMFAC/6D0)*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
22864 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
22865 C...Propagators: as simulated in PYOFSH and as desired
22866 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
22867 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
22868 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
22869 GMMQC=SQRT(SQM4)*WDTP(0)
22870 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
22871 FACQSB=FACQSB*HBW4C/HBW4
22872 DO 1555 I=MMIN1,MMAX1
22874 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1555
22877 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1555
22890 ELSEIF(ISUB.EQ.191) THEN
22891 C...q + qbar -> rho_tech0.
22892 SQMRHT=PMAS(54,1)**2
22893 CALL PYWIDT(54,SH,WDTP,WDTE)
22895 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
22896 IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0
22897 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22898 ALPRHT=2.91D0*(3D0/PARP(144))
22899 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
22900 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
22901 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
22902 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
22903 DO 1560 I=MMINA,MMAXA
22904 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1560
22906 EI=KCHG(IABS(I),1)/3D0
22907 AI=SIGN(1D0,EI+0.1D0)
22911 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
22912 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
22913 IF(IA.LE.10) HI=HI*FACA/3D0
22918 SIGH(NCHN)=HI*FACBW*HF
22921 ELSEIF(ISUB.EQ.192) THEN
22922 C...q + qbar' -> rho_tech+/-.
22923 SQMRHT=PMAS(55,1)**2
22924 CALL PYWIDT(55,SH,WDTP,WDTE)
22926 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
22927 IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0
22928 ALPRHT=2.91D0*(3D0/PARP(144))
22929 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
22930 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
22931 DO 1580 I=MMIN1,MMAX1
22932 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1580
22934 DO 1570 J=MMIN2,MMAX2
22935 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1570
22937 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1570
22938 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22940 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22941 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
22943 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22948 SIGH(NCHN)=HI*FACBW*HF
22952 ELSEIF(ISUB.EQ.193) THEN
22953 C...q + qbar -> omega_tech0.
22954 SQMOMT=PMAS(56,1)**2
22955 CALL PYWIDT(56,SH,WDTP,WDTE)
22957 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
22958 IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0
22959 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22960 ALPRHT=2.91D0*(3D0/PARP(144))
22961 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
22962 & (2D0*PARP(143)-1D0)**2
22963 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
22964 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
22965 DO 1590 I=MMINA,MMAXA
22966 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1590
22968 EI=KCHG(IABS(I),1)/3D0
22969 AI=SIGN(1D0,EI+0.1D0)
22973 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
22974 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
22975 IF(IA.LE.10) HI=HI*FACA/3D0
22980 SIGH(NCHN)=HI*FACBW*HF
22983 ELSEIF(ISUB.EQ.194) THEN
22984 C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
22986 ALPRHT=2.91D0*(3D0/PARP(144))
22988 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
22989 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
22991 QUPD=2D0*PARP(143)-1D0
22992 FAR=SQRT(AEM/ALPRHT)
23000 CALL PYWIDT(23,SH,WDTP,WDTE)
23001 SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
23002 CALL PYWIDT(54,SH,WDTP,WDTE)
23003 SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
23004 CALL PYWIDT(56,SH,WDTP,WDTE)
23005 SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
23006 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
23007 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
23008 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
23009 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
23010 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
23012 XWRHT=1D0/(4D0*XW*(1D0-XW))
23013 KFF=IABS(KFPR(ISUB,1))
23015 AF=SIGN(1D0,EF+0.1D0)
23020 IF(KFF.LE.10) FCOF=3D0
23023 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
23024 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
23025 DZZ=DZZ*CMPLX(XWRHT,0D0)
23026 DAZ=DAZ*CMPLX(SQRT(XWRHT),0D0)
23028 DO 1600 I=MMINA,MMAXA
23029 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
23030 EI=KCHG(IABS(I),1)/3D0
23031 AI=SIGN(1D0,EI+0.1D0)
23036 IF(IABS(I).LE.10) FCOI=FCOI/3D0
23037 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
23038 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
23039 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
23040 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
23041 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
23042 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
23047 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
23050 ELSEIF(ISUB.EQ.195) THEN
23051 C...f + fbar' -> f'' + fbar''' via s-channel rho_tech+
23054 ALPRHT=2.91D0*(3D0/PARP(144))
23055 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
23057 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
23058 CALL PYWIDT(24,SH,WDTP,WDTE)
23059 SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
23060 CALL PYWIDT(55,SH,WDTP,WDTE)
23061 SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
23064 IF(KFA.LE.8) FCOF=3D0
23065 DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
23066 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
23068 DO 1605 I=MMIN1,MMAX1
23069 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1605
23071 DO 1604 J=MMIN2,MMAX2
23072 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1604
23074 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1604
23075 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
23077 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
23079 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
23084 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
23091 C...J: 2 -> 2, tree diagrams, SUSY processes
23093 ELSEIF(ISUB.LE.210) THEN
23094 IF(ISUB.EQ.201) THEN
23095 C...f + fbar -> e_L + e_Lbar
23096 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23097 DO 1630 I=MMIN1,MMAX1
23099 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
23101 TT3I=SIGN(1D0,EI+1D-6)/2D0
23105 C...Color factor for e+ e-
23106 IF(IA.GE.11) FCOL=3D0
23107 IF(ISUBSV.EQ.301) THEN
23110 ELSEIF(ILR.EQ.1) THEN
23111 A1=SFMIX(KFID,3)**2
23112 A2=SFMIX(KFID,4)**2
23113 ELSEIF(ILR.EQ.0) THEN
23114 A1=SFMIX(KFID,1)**2
23115 A2=SFMIX(KFID,2)**2
23117 XLQ=(TT3J-EJ*XW)*A1
23122 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
23123 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
23124 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
23125 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
23129 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
23135 DK=1D0/(TH-SMZ(II)**2)
23136 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
23138 FREK=FAC2*TANW*EI*ZMIX(II,1)
23139 TNN1=TNN1+FLEK**2*DK
23140 TNN2=TNN2+FREK**2*DK
23142 DL=1D0/(TH-SMZ(JJ)**2)
23143 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
23145 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
23146 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
23149 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
23150 TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
23151 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
23152 & (TNN1*XLF*A1+TNN2*XRF*A2)
23153 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
23156 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
23158 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
23159 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
23160 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
23165 SIGH(NCHN)=FACQQ1+FACQQ2
23168 ELSEIF(ISUB.EQ.203) THEN
23169 C...f + fbar -> e_L + e_Rbar
23170 DO 1660 I=MMIN1,MMAX1
23172 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1660
23173 EI=KCHG(IABS(I),1)/3D0
23174 TT3I=SIGN(1D0,EI)/2D0
23178 C...Color factor for e+ e-
23179 IF(IA.GE.11) FCOL=3D0
23180 A1=SFMIX(KFID,1)**2
23181 A2=SFMIX(KFID,2)**2
23186 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
23187 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
23190 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
23196 DK=1D0/(TH-SMZ(II)**2)
23197 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
23199 FREK=FAC2*TANW*EI*ZMIX(II,1)
23200 TNN1=TNN1+FLEK**2*DK
23201 TNN2=TNN2+FREK**2*DK
23203 DL=1D0/(TH-SMZ(JJ)**2)
23204 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
23206 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
23207 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
23210 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
23211 TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
23212 TZN=(UH*TH-SQM3*SQM4)*A1*A2
23213 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
23214 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
23217 FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
23218 FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
23219 FACQQ=(FACQQ1+FACQQ2)
23224 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23225 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
23230 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
23231 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23234 ELSEIF(ISUB.EQ.210) THEN
23235 C...q + qbar' -> W*- > ~l_L + ~nu_L
23236 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
23237 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
23238 DO 1680 I=MMIN1,MMAX1
23240 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1680
23241 DO 1670 J=MMIN2,MMAX2
23243 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1670
23244 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1670
23246 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23247 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
23249 IF(KCHSUM.LT.0) KCHW=3
23254 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
23255 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
23256 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23258 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
23259 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
23261 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
23266 ELSEIF(ISUB.LE.220) THEN
23267 IF(ISUB.EQ.213) THEN
23268 C...f + fbar -> ~nu_L + ~nu_Lbar
23269 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
23270 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23271 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23273 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23276 PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
23279 DO 1690 I=MMIN1,MMAX1
23281 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1690
23284 C...Color factor for e+ e-
23285 IF(IA.GE.11) FCOL=3D0
23286 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
23290 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
23291 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
23294 TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
23296 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
23302 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
23303 & *AEM**2*FCOL/3D0/XW**2
23306 ELSEIF(ISUB.EQ.216) THEN
23307 C...q + qbar -> ~chi0_1 + ~chi0_1
23308 IF(IZID1.EQ.IZID2) THEN
23309 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23311 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23312 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23314 FACGG1=COMFAC*AEM**2/3D0/XW**2
23315 IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0
23318 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
23319 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
23320 XS2 = SMZ(IZID1)*SMZ(IZID2)/SH
23321 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
23322 REPRPZ = (SH-SQMZ)/PROPZ2
23323 OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+
23324 & ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0
23325 DO 1700 I=MMINA,MMAXA
23326 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1700
23327 EI=KCHG(IABS(I),1)/3D0
23329 IF(ABS(I).GE.11) FCOL=3D0
23330 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
23334 C...Factored out sqrt(2)
23335 FR1=TANW*EI*ZMIX(IZID1,1)
23336 FR2=TANW*EI*ZMIX(IZID2,1)
23337 FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW*
23338 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0
23339 FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW*
23340 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0
23345 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
23346 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
23347 FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2)
23348 FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2-
23349 & 2D0*XS2*SH2/(TH-XML2)/(UH-XML2))
23350 FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2-
23351 & 2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2))
23352 FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/
23353 & (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) )
23354 FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/
23355 & (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) )
23360 SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU)
23364 ELSEIF(ISUB.LE.230) THEN
23365 IF(ISUB.EQ.226) THEN
23366 C...f + fbar -> ~chi+_1 + ~chi-_1
23367 FACGG1=COMFAC*AEM**2/3D0/XW**2
23370 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
23371 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
23372 WS2 = SMW(IZID1)*SMW(IZID2)/SH
23373 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
23374 REPRPZ = (SH-SQMZ)/PROPZ2
23376 IF(IZID1.EQ.IZID2) DIFF=1D0
23377 DO 1710 I=MMINA,MMAXA
23378 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
23379 EI=KCHG(IABS(I),1)/3D0
23381 IF(IABS(I).GE.11) FCOL=3D0
23382 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
23388 OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)-
23389 & VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF
23390 ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)-
23391 & UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF
23394 C...u-type quark - d-type squark
23395 IF(MOD(I,2).EQ.0) THEN
23396 FACT0 = -UMIX(IZID1,1)*UMIX(IZID2,1)
23397 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
23398 C...d-type quark - u-type squark
23400 FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1)
23401 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
23403 FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2
23404 FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+
23405 & 4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)*
23406 & (WU2-WT2))*SH2/PROPZ2
23407 FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2
23408 FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+
23409 & WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI)
23410 FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI)
23411 FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2
23412 FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL
23417 IF(IZID1.EQ.IZID2) THEN
23418 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23420 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
23421 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23426 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23427 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
23431 ELSEIF(ISUB.EQ.229) THEN
23432 C...q + qbar' -> ~chi0_1 + ~chi+-_1
23433 FACGG1=COMFAC*AEM**2/6D0/XW**2
23436 ZMU2 = PMAS(PYCOMP(KSUSY1+2),1)**2
23437 ZMD2 = PMAS(PYCOMP(KSUSY1+1),1)**2
23438 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
23439 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
23440 WS2 = SMW(IZID1)*SMZ(IZID2)/SH
23441 RT2I = 1D0/SQRT(2D0)
23442 PROPW = ((SH-SQMW)**2+WWID**2*SQMW)
23443 OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+
23444 & ZMIX(IZID2,2)*VMIX(IZID1,1)
23445 OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+
23446 & ZMIX(IZID2,2)*UMIX(IZID1,1)
23450 FACST0=UMIX(IZID1,1)
23451 FACSU0=VMIX(IZID1,1)
23452 FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
23453 FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
23456 FACTU0=FACSU0*FACST0
23457 FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR
23458 & + SH2*WS2*OL)*FACST0
23459 FACSU = 2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL
23460 & + SH2*WS2*OR)*FACSU0
23461 FACT = WT2*SH2/(TH-ZMD2)**2*FACT0
23462 FACU = WU2*SH2/(UH-ZMU2)**2*FACU0
23463 FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0
23464 FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2
23465 FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST)
23466 DO 1730 I=MMIN1,MMAX1
23468 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1730
23469 DO 1720 J=MMIN2,MMAX2
23471 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1720
23472 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1720
23474 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23475 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
23477 IF(KCHSUM.LT.0) KCHW=3
23482 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23483 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
23488 ELSEIF(ISUB.LE.240) THEN
23489 IF(ISUB.EQ.237) THEN
23490 C...q + qbar -> gluino + ~chi0_1
23491 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23492 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23493 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
23496 DO 1740 I=MMINA,MMAXA
23497 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
23498 EI=KCHG(IABS(I),1)/3D0
23500 XLQC = -TANW*EI*ZMIX(IZID,1)
23501 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
23502 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
23505 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
23506 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
23507 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
23508 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
23509 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
23510 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
23511 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
23512 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
23513 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
23514 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
23519 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
23523 ELSEIF(ISUB.LE.250) THEN
23524 IF(ISUB.EQ.241) THEN
23525 C...q + qbar' -> ~chi+-_1 + gluino
23526 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
23529 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
23530 FAC0=UMIX(IZID,1)**2
23531 FAC1=VMIX(IZID,1)**2
23532 DO 1760 I=MMIN1,MMAX1
23534 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1760
23535 DO 1750 J=MMIN2,MMAX2
23537 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1750
23538 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1750
23540 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23541 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
23543 IF(KCHSUM.LT.0) KCHW=3
23544 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
23545 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
23546 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
23547 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
23548 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
23549 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
23550 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
23551 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
23552 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
23553 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
23554 & SH/(TH-XMU2)/(UH-XMD2))/2D0
23559 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
23560 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23561 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
23565 ELSEIF(ISUB.EQ.243) THEN
23566 C...q + qbar -> gluino + gluino
23567 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23570 DO 1770 I=MMINA,MMAXA
23571 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23572 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1770
23574 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
23575 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
23576 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
23577 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
23578 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
23579 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
23580 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
23581 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
23582 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
23583 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
23584 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
23585 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
23589 C...1/2 for identical particles
23590 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
23593 ELSEIF(ISUB.EQ.244) THEN
23594 C...g + g -> gluino + gluino
23595 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23598 FACQQ1=COMFAC*AS**2*9D0/4D0*(
23599 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
23600 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
23601 FACQQ2=COMFAC*AS**2*9D0/4D0*(
23602 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
23603 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
23604 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
23605 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
23606 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1780
23611 SIGH(NCHN)=FACQQ1/2D0
23616 SIGH(NCHN)=FACQQ2/2D0
23621 SIGH(NCHN)=FACQQ3/2D0
23624 ELSEIF(ISUB.EQ.246) THEN
23625 C...g + q_j -> ~chi0_1 + ~q_j
23626 FAC0=COMFAC*AS*AEM/6D0/XW
23629 FACZQ0=FAC0*( (ZM2-TH)/SH +
23630 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
23631 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
23632 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
23633 DO 1800 I=-KFNSQ,KFNSQ,2*KFNSQ
23634 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1800
23635 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1800
23636 EI=KCHG(IABS(I),1)/3D0
23638 XRQZ = -TANW*EI*ZMIX(IZID,1)
23639 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
23640 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
23642 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
23644 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
23650 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1790
23651 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1790
23654 ISIG(NCHN,3-ISDE)=21
23656 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23657 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23662 ELSEIF(ISUB.LE.260) THEN
23663 IF(ISUB.EQ.254) THEN
23664 C...g + q_j -> ~chi1_1 + ~q_i
23665 FAC0=COMFAC*AS*AEM/12D0/XW
23670 FACZQ0=FAC0*( (ZM2-TH)/SH +
23671 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
23672 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
23673 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
23674 IF(MOD(KFNSQ1,2).EQ.0) THEN
23681 DO 1820 I=-KFNSQ,KFNSQ,2*KFNSQ
23682 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1820
23683 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1820
23685 IF(MOD(IA,2).EQ.0) THEN
23690 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
23694 IF(I.LT.0) KCHWQ=5-KCHW
23696 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1810
23697 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1810
23700 ISIG(NCHN,3-ISDE)=21
23702 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23703 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
23707 ELSEIF(ISUB.EQ.258) THEN
23708 C...g + q_j -> gluino + ~q_i
23715 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
23716 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
23717 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
23718 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
23719 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
23721 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
23722 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
23723 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
23724 FACQG1=COMFAC*AS**2*FACQG1/2D0
23725 FACQG2=COMFAC*AS**2*FACQG2/2D0
23726 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
23727 DO 1840 I=-KFNSQ,KFNSQ,2*KFNSQ
23728 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1840
23729 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1840
23732 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23733 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23735 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1830
23736 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1830
23739 ISIG(NCHN,3-ISDE)=21
23741 SIGH(NCHN)=FACQG1*FACSEL
23744 ISIG(NCHN,3-ISDE)=21
23746 SIGH(NCHN)=FACQG2*FACSEL
23751 ELSEIF(ISUB.LE.270) THEN
23752 IF(ISUB.EQ.261) THEN
23753 C...q_i + q_ibar -> ~t_1 + ~t_1bar
23754 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
23755 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23756 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
23758 DO 1850 I=MMIN1,MMAX1
23760 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1850
23761 IF(IA.GE.11.AND.IA.LE.18) THEN
23763 EJ=KCHG(KFNSQ,1)/3D0
23764 T3I=SIGN(1D0,EI)/2D0
23765 T3J=SIGN(1D0,EJ)/2D0
23766 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
23767 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
23768 XLF=2D0*(T3I-EI*XW)
23770 TAA=0.5D0*(EI*EJ)**2
23771 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
23772 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
23773 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
23774 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
23775 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
23781 SIGH(NCHN)=FACQQ1*FAC0
23784 ELSEIF(ISUB.EQ.263) THEN
23785 C...f + fbar -> ~t1 + ~t2bar
23786 DO 1860 I=MMIN1,MMAX1
23788 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
23789 EI=KCHG(IABS(I),1)/3D0
23790 TT3I=SIGN(1D0,EI)/2D0
23794 C...Color factor for e+ e-
23795 IF(IA.GE.11) FCOL=3D0
23796 XLQ=2D0*(TT3J-EJ*XW)
23798 XLF=2D0*(TT3I-EI*XW)
23800 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
23801 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
23802 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
23803 C...Factor of 2 for t1 t2bar + t2 t1bar
23804 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
23805 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
23810 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23811 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
23816 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
23817 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23820 ELSEIF(ISUB.EQ.264) THEN
23821 C...g + g -> ~t_1 + ~t_1bar
23824 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
23825 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23826 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
23827 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
23828 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870
23842 ELSEIF(ISUB.LE.280) THEN
23843 IF(ISUB.EQ.271) THEN
23844 C...q + q' -> ~q + ~q' (~g exchange)
23845 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
23853 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
23854 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
23857 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
23858 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
23859 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
23862 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
23863 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
23864 DO 1890 I=-KFNSQI,KFNSQI,2*KFNSQI
23865 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1890
23867 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1890
23870 DO 1880 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
23871 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1880
23873 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1880
23874 IF(I*J.LT.0) GOTO 1880
23879 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23880 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
23883 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
23884 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
23886 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
23887 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23888 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
23895 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
23896 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
23898 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
23899 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23900 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
23906 ELSEIF(ISUB.EQ.274) THEN
23907 C...q + qbar' -> ~q + ~qbar'
23908 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
23912 C...Mrenna...Normalization.and.1/XMT
23913 FACQQ1=COMFAC*AS**2*2D0/9D0*(
23914 & (UH*TH-SQM3*SQM4)/XMT**2 )
23915 FACQQB=COMFAC*AS**2*2D0/9D0*(
23916 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
23917 FACQQB=FACQQB+FACQQ1
23919 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
23922 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
23923 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
23924 DO 1910 I=-KFNSQI,KFNSQI,2*KFNSQI
23925 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1910
23927 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1910
23930 DO 1900 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
23931 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1900
23933 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1900
23934 IF(I*J.GT.0) GOTO 1900
23939 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23940 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
23941 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
23942 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23946 ELSEIF(ISUB.EQ.277) THEN
23947 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
23948 C...if i .eq. j covered in 274
23949 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
23950 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
23952 DO 1920 I=MMIN1,MMAX1
23954 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
23955 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1920
23956 IF(IA.EQ.KFNSQ) GOTO 1920
23957 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
23959 EJ=KCHG(KFNSQ,1)/3D0
23961 T3I=SIGN(1D0,EI)/2D0
23963 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
23964 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
23966 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
23967 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
23969 XLF=2D0*(T3I-EI*XW)
23976 TAA=0.5D0*(EI*EJ)**2
23977 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
23978 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
23979 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
23980 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
23981 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
23982 ELSEIF(IA.LE.6) THEN
23983 FAC0=AS**2*8D0/9D0/2D0
23989 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23992 ELSEIF(ISUB.EQ.279) THEN
23993 C...g + g -> ~q_j + ~q_jbar
23996 C...5=RKF because ~t ~tbar treated separately
23997 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
23998 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
23999 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
24000 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1930
24005 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24010 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24016 ELSEIF(ISUB.LE.340) THEN
24018 ELSEIF(ISUB.LE.360) THEN
24020 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
24021 C...l + l -> H_L++/-- or H_R++/--.
24023 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
24025 FACBW=8D0*COMFAC/((SH-PMAS(KFRES,1)**2)**2+HS**2)
24026 DO 1950 I=MMIN1,MMAX1
24028 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
24030 DO 1940 J=MMIN2,MMAX2
24032 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
24034 IF(I*J.LT.0) GOTO 1940
24035 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24040 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
24041 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
24042 SIGH(NCHN)=HI*FACBW*HF
24046 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
24047 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
24049 C...Propagators: as simulated in PYOFSH and as desired
24050 HBW3=PMAS(KFRES,1)*PMAS(KFRES,2)/((SQM3-PMAS(KFRES,1)**2)**2+
24051 & (PMAS(KFRES,1)*PMAS(KFRES,2))**2)
24052 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
24053 GMMC=SQRT(SQM3)*WDTP(0)
24054 HBW3C=GMMC/((SQM3-PMAS(KFRES,1)**2)**2+GMMC**2)
24055 FHCC=COMFAC*AEM*HBW3C/HBW3
24056 DO 1980 I=MMINA,MMAXA
24058 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 1980
24060 J=ISIGN(KFPR(ISUB,2),-I)
24061 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
24062 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
24063 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
24065 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
24066 & (TH-SQM4)*SH)/(TH-SQM4)**2
24067 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
24069 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
24070 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
24071 & ((UH-SQM3)*(TH-SQM4))
24072 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
24073 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
24074 & ((UH-SQM3)*(SH-SQML))
24075 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
24076 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
24077 & ((SH-SQML)*(TH-SQM4))
24078 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
24079 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
24081 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1960
24082 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1960
24085 ISIG(NCHN,3-ISDE)=22
24087 SIGH(NCHN)=FHCC*SMM*WIDSC
24091 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
24092 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
24094 SQMH=PMAS(KFRES,1)**2
24095 GMMH=PMAS(KFRES,1)*PMAS(KFRES,2)
24096 C...Propagators: H++/-- as simulated in PYOFSH and as desired
24097 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
24098 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
24099 GMMH3=SQRT(SQM3)*WDTP(0)
24100 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
24101 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
24102 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
24103 GMMH4=SQRT(SQM4)*WDTP(0)
24104 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
24105 C...Kinematical and coupling functions
24106 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
24107 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
24108 C...Loop over allowed flavours
24109 DO 2000 I=MMINA,MMAXA
24110 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2000
24111 EI=KCHG(IABS(I),1)/3D0
24112 AI=SIGN(1D0,EI+0.1D0)
24115 IF(IABS(I).LE.10) FCOI=FACA/3D0
24116 IF(ISUB.EQ.349) THEN
24117 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
24118 IF(IABS(I).LT.10) THEN
24119 DSIGHH=8D0*AEM**2*(EI**2/SH2+
24120 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
24121 & (VI**2+AI**2)*XWHH**2*HBWZ)
24123 IAOFF=181+3*((IABS(I)-11)/2)
24124 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
24126 DSIGHH=8D0*AEM**2*(EI**2/SH2+
24127 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
24128 & (VI**2+AI**2)*XWHH**2*HBWZ)+
24129 & 8D0*AEM*(EI*HSUM/(SH*TH)+
24130 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
24134 IF(IABS(I).LT.10) THEN
24135 DSIGHH=8D0*AEM**2*EI**2/SH2
24137 IAOFF=181+3*((IABS(I)-11)/2)
24138 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
24140 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
24148 SIGH(NCHN)=FACHH*FCOI*DSIGHH
24151 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
24152 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
24154 SQMH=PMAS(KFRES,1)**2
24155 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
24156 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*PMAS(63,1)**2
24157 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
24158 FACPRT=1D0/((VINT(204)**2-VINT(215))*
24159 & (VINT(209)**2-VINT(216)))
24160 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
24161 & (VINT(209)**2+2D0*VINT(218)))
24162 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
24164 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
24165 IF(ABS(SHR-PMAS(KFRES,1)).GT.PARP(48)*PMAS(KFRES,2))
24167 DO 2020 I=MMIN1,MMAX1
24168 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2020
24169 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 2020
24170 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
24171 DO 2010 J=MMIN2,MMAX2
24172 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2010
24173 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 2010
24174 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
24176 IF(IABS(KCHH).NE.2) GOTO 2010
24177 FACLR=VINT(180+I)*VINT(180+J)
24178 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
24179 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
24180 FACPRP=0.5D0*(FACPRT+FACPRU)**2
24188 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
24193 ELSEIF(ISUB.LE.380) THEN
24195 IF(ISUB.EQ.361) THEN
24196 C...f + fbar -> W_L W_L, W_L pi_tech, pi_tech pi_tech
24197 FACA=(SH**2*BE34**2-(TH-UH)**2)
24198 ALPRHT=2.91D0*(3D0/PARP(144))
24199 HP=(1D0/12D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0
24200 FAR=SQRT(AEM/ALPRHT)
24208 CALL PYWIDT(23,SH,WDTP,WDTE)
24209 SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
24210 CALL PYWIDT(54,SH,WDTP,WDTE)
24211 SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
24212 CALL PYWIDT(56,SH,WDTP,WDTE)
24213 SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
24214 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
24215 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
24216 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
24217 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
24219 DO 2040 I=MMINA,MMAXA
24220 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2040
24222 EI=KCHG(IABS(I),1)/3D0
24223 AI=SIGN(1D0,EI+0.1D0)
24225 VALI=0.25D0*(VI+AI)
24226 VARI=0.25D0*(VI-AI)
24227 F2L=EI*DARHO+VALI*DZRHO/SQRT(XW*XW1)
24228 F2R=EI*DARHO+VARI*DZRHO/SQRT(XW*XW1)
24229 HI=ABS(F2L)**2+ABS(F2R)**2
24230 IF(IA.LE.10) HI=HI/3D0
24235 IF(KFA.EQ.KFB) THEN
24236 SIGH(NCHN)=HI*HP*WIDS(KFA,1)
24238 SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,3)
24243 SIGH(NCHN)=HI*HP*WIDS(KFA,3)*WIDS(KFB,2)
24247 ELSEIF(ISUB.EQ.364) THEN
24248 C...f + fbar -> gamma pi_tech, gamma pi_tech', Z pi_tech, Z pi_tech',
24250 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*SH
24251 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*SH
24253 ALPRHT=2.91D0*(3D0/PARP(144))
24254 HP=(1D0/24D0)*AEM**2*COMFAC*3D0
24255 FAR=SQRT(AEM/ALPRHT)
24263 CALL PYWIDT(23,SH,WDTP,WDTE)
24264 SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
24265 CALL PYWIDT(54,SH,WDTP,WDTE)
24266 SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
24267 CALL PYWIDT(56,SH,WDTP,WDTE)
24268 SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
24269 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
24270 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
24271 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
24272 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
24273 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
24274 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
24276 DO 2060 I=MMINA,MMAXA
24277 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2060
24279 EI=KCHG(IABS(I),1)/3D0
24280 AI=SIGN(1D0,EI+0.1D0)
24282 VALI=0.25D0*(VI+AI)
24283 VARI=0.25D0*(VI-AI)
24284 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
24285 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
24286 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
24287 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
24288 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
24289 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
24290 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
24291 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
24292 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
24293 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
24295 IF(IA.LE.10) HI=HI/3D0
24300 IF(ISUBSV.NE.368) THEN
24301 SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,2)
24303 SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,3)
24308 SIGH(NCHN)=HI*HP*WIDS(KFA,3)*WIDS(KFB,2)
24312 ELSEIF(ISUB.EQ.370) THEN
24313 C...f + fbar' -> W_L Z_L, W_L pi_tech, Z_L pi_tech, pi_tech pi_tech
24315 FACA=(SH**2*BE34**2-(TH-UH)**2)
24316 ALPRHT=2.91D0*(3D0/PARP(144))
24317 HP=(1D0/24D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0/XW
24319 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
24320 CALL PYWIDT(24,SH,WDTP,WDTE)
24321 SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
24322 CALL PYWIDT(55,SH,WDTP,WDTE)
24323 SSMR=CMPLX(1D0-PMAS(55,1)**2/SH,WDTP(0)/SHR)
24325 DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
24326 HP=HP*FWR**2/ABS(DETD)**2/SH**2
24328 DO 2080 I=MMIN1,MMAX1
24329 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2080
24331 DO 2070 J=MMIN2,MMAX2
24332 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2070
24334 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2070
24335 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24337 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24339 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
24344 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,2)
24348 ELSEIF(ISUB.EQ.374) THEN
24349 C...f + fbar' -> G pi_tech
24350 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*VRGP**2
24351 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
24353 ALPRHT=2.91D0*(3D0/PARP(144))
24354 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*(VFAC+AFAC)*SH
24356 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
24357 CALL PYWIDT(24,SH,WDTP,WDTE)
24358 SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
24359 CALL PYWIDT(55,SH,WDTP,WDTE)
24360 SSMR=CMPLX(1D0-PMAS(55,1)**2/SH,WDTP(0)/SHR)
24362 DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
24363 HP=HP*FWR**2/ABS(DETD)**2/SH**2
24365 DO 2100 I=MMIN1,MMAX1
24366 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2100
24368 DO 2090 J=MMIN2,MMAX2
24369 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2090
24371 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2090
24372 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24374 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24376 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
24381 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,2)
24388 C...Multiply with parton distributions
24389 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
24390 DO 2200 ICHN=1,NCHN
24391 IF(MINT(45).GE.2) THEN
24393 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
24395 IF(MINT(46).GE.2) THEN
24397 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
24399 SIGS=SIGS+SIGH(ICHN)
24406 C*********************************************************************
24409 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
24410 C...parton distributions according to a few different parametrizations.
24411 C...Note that what is coded is x times the probability distribution,
24412 C...i.e. xq(x,Q2) etc.
24414 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
24416 C...Double precision and integer declarations.
24417 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24418 IMPLICIT INTEGER(I-N)
24419 INTEGER PYK,PYCHGE,PYCOMP
24421 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24422 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24423 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24424 COMMON/PYINT1/MINT(400),VINT(400)
24425 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
24427 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
24429 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
24430 &XPPI(-6:6),XPPR(-6:6)
24432 C...Interface to PDFLIB.
24433 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
24435 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
24436 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
24437 CHARACTER*20 PARM(20)
24438 DATA VALUE/20*0D0/,PARM/20*' '/
24440 C...Data related to Schuler-Sjostrand photon distributions.
24441 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
24443 C...Reset parton distributions.
24449 C...Check x and particle species.
24450 IF(X.LE.0D0.OR.X.GE.1D0) THEN
24451 WRITE(MSTU(11),5000) X
24455 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
24456 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
24457 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
24458 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111) THEN
24459 WRITE(MSTU(11),5100) KF
24463 C...Electron (or muon or tau) parton distribution call.
24464 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
24465 CALL PYPDEL(KFA,X,Q2,XPEL)
24470 C...Photon parton distribution call (VDM+anomalous).
24471 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
24472 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
24473 CALL PYPDGA(X,Q2,XPGA)
24477 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
24480 IF(MSTP(55).GE.7) P2MX=4.0D0
24481 IF(MSTP(57).EQ.0) Q2MX=P2MX
24483 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24484 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
24489 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
24492 IF(MSTP(55).GE.11) P2MX=4.0D0
24493 IF(MSTP(57).EQ.0) Q2MX=P2MX
24495 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24496 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
24498 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
24501 ELSEIF(MSTP(56).EQ.2) THEN
24502 C...Call PDFLIB parton distributions.
24506 VALUE(2)=MSTP(55)/1000
24508 VALUE(3)=MOD(MSTP(55),1000)
24509 IF(MINT(93).NE.3000000+MSTP(55)) THEN
24510 CALL PDFSET(PARM,VALUE)
24511 MINT(93)=3000000+MSTP(55)
24514 QQ2=MAX(0D0,Q2MIN,Q2)
24515 IF(MSTP(57).EQ.0) QQ2=Q2MIN
24517 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24519 IF(MSTP(55).EQ.5004) THEN
24520 IF(5D0*P2.LT.QQ2.AND.
24521 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
24522 & P2.GE.0D0.AND.P2.LT.10D0.AND.
24523 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
24524 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
24539 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
24568 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
24571 C...Pion/gammaVDM parton distribution call.
24572 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND.
24573 & MINT(109).EQ.2)) THEN
24574 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
24575 & MSTP(55).LE.12) THEN
24576 ISET=1+MOD(MSTP(55)-1,4)
24579 IF(ISET.GE.3) P2MX=4.0D0
24580 IF(MSTP(57).EQ.0) Q2MX=P2MX
24582 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24583 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
24585 XPQ(KFL)=XPVMD(KFL)
24588 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
24589 CALL PYPDPI(X,Q2,XPPI)
24593 ELSEIF(MSTP(54).EQ.2) THEN
24594 C...Call PDFLIB parton distributions.
24598 VALUE(2)=MSTP(53)/1000
24600 VALUE(3)=MOD(MSTP(53),1000)
24601 IF(MINT(93).NE.2000000+MSTP(53)) THEN
24602 CALL PDFSET(PARM,VALUE)
24603 MINT(93)=2000000+MSTP(53)
24606 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
24607 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
24608 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
24624 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
24627 C...Anomalous photon parton distribution call.
24628 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
24631 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
24632 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
24633 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
24634 IF(MSTP(57).EQ.0) Q2MX=P2MX
24636 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24637 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
24639 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
24642 ELSEIF(MSTP(56).EQ.1) THEN
24643 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
24644 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
24645 IF(MSTP(57).EQ.0) Q2MX=P2MX
24647 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24648 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
24650 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
24653 ELSEIF(MSTP(56).EQ.2) THEN
24654 IF(MSTP(57).EQ.0) Q2MX=P2MX
24655 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
24660 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
24661 IF(MSTP(57).EQ.0) Q2MX=P2MX
24662 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
24668 210 RKF=11D0*PYR(0)
24670 IF(RKF.GT.1D0) KFR=2
24671 IF(RKF.GT.5D0) KFR=3
24672 IF(RKF.GT.6D0) KFR=4
24673 IF(RKF.GT.10D0) KFR=5
24674 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
24675 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
24676 IF(MSTP(57).EQ.0) Q2MX=P2MX
24677 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
24684 C...Proton parton distribution call.
24686 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
24687 CALL PYPDPR(X,Q2,XPPR)
24691 ELSEIF(MSTP(52).EQ.2) THEN
24692 C...Call PDFLIB parton distributions.
24696 VALUE(2)=MSTP(51)/1000
24698 VALUE(3)=MOD(MSTP(51),1000)
24699 IF(MINT(93).NE.1000000+MSTP(51)) THEN
24701 CALL PDFSET_ALICE(PARM,VALUE)
24702 MINT(93)=1000000+MSTP(51)
24705 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
24706 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
24708 CALL STRUCTM_ALICE(
24709 + XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
24725 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
24729 C...Isospin average for pi0/gammaVDM.
24730 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
24731 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
24736 XPS=0.5D0*(XPQ(1)+XPQ(-2))
24737 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
24741 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
24742 XPQ(1)=XPQ(1)+0.2D0*XPV
24743 XPQ(-1)=XPQ(-1)+0.2D0*XPV
24744 XPQ(2)=XPQ(2)+0.8D0*XPV
24745 XPQ(-2)=XPQ(-2)+0.8D0*XPV
24746 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
24748 XPQ(-3)=XPQ(-3)+XPV
24749 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
24751 XPQ(-4)=XPQ(-4)+XPV
24752 IF(MSTP(55).GE.9) THEN
24758 XPQ(1)=XPQ(1)+0.5D0*XPV
24759 XPQ(-1)=XPQ(-1)+0.5D0*XPV
24760 XPQ(2)=XPQ(2)+0.5D0*XPV
24761 XPQ(-2)=XPQ(-2)+0.5D0*XPV
24764 C...Rescale for gammaVDM by effective gamma -> rho coupling.
24765 C+++Do not rescale?
24766 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
24767 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
24769 XPQ(KFL)=VINT(281)*XPQ(KFL)
24771 VINT(232)=VINT(281)*XPV
24774 C...Isospin conjugation for neutron.
24775 ELSEIF(KFA.EQ.2112) THEN
24783 C...Simple recipes for hyperon (average valence parton distribution).
24784 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
24785 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
24786 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
24787 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
24792 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
24793 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
24794 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
24797 C...Charge conjugation for antiparticle.
24800 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
24807 C...Allow gluon also in position 21.
24810 C...Check positivity and reset above maximum allowed flavour.
24812 XPQ(KFL)=MAX(0D0,XPQ(KFL))
24813 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
24816 C...Formats for error printouts.
24817 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
24818 5100 FORMAT(' Error: illegal particle code for parton distribution;',
24820 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
24826 C*********************************************************************
24829 C...Gives proton parton distribution at small x and/or Q^2 according to
24830 C...correct limiting behaviour.
24832 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
24834 C...Double precision and integer declarations.
24835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24836 IMPLICIT INTEGER(I-N)
24837 INTEGER PYK,PYCHGE,PYCOMP
24839 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24840 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24841 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24842 COMMON/PYINT1/MINT(400),VINT(400)
24843 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
24845 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
24846 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
24848 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
24852 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
24853 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
24854 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
24856 CALL PYPDFU(KF,X,Q2,XPQ)
24860 C...Reset. Check x.
24864 IF(X.LE.0D0.OR.X.GE.1D0) THEN
24865 WRITE(MSTU(11),5000) X
24869 C...Define valence content.
24873 IF(KF.EQ.2212) THEN
24876 ELSEIF(KF.EQ.-2212) THEN
24879 ELSEIF(KF.EQ.2112) THEN
24882 ELSEIF(KF.EQ.-2112) THEN
24885 ELSEIF(KF.EQ.211) THEN
24889 ELSEIF(KF.EQ.-211) THEN
24893 ELSEIF(MINT(105).LE.223) THEN
24898 ELSEIF(MINT(105).EQ.333) THEN
24903 ELSEIF(MINT(105).EQ.443) THEN
24910 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
24911 CALL PYPDFU(KFC,X,Q2,XPA)
24912 Q2MN=MAX(3D0,VINT(231))
24913 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
24914 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
24916 C...Large Q2 and large x: naive call is enough.
24917 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
24923 C...Small Q2 and large x: dampen boundary value.
24924 ELSEIF(X.GT.XMN) THEN
24926 C...Evaluate at boundary and define dampening factors.
24927 CALL PYPDFU(KFC,X,Q2MN,XPA)
24928 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
24929 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
24931 C...Separate valence and sea parts of parton distribution.
24933 XFV1=XPA(KFV1)-XPA(-KFV1)
24934 XPA(KFV1)=XPA(-KFV1)
24935 XFV2=XPA(KFV2)-XPA(-KFV2)
24936 XPA(KFV2)=XPA(-KFV2)
24938 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
24939 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
24940 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
24941 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
24944 C...Dampen valence and sea separately. Put back together.
24946 XPQ(KFL)=FS*XPA(KFL)
24949 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
24950 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
24952 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
24953 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
24954 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
24955 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
24959 C...Large Q2 and small x: interpolate behaviour.
24960 ELSEIF(Q2.GT.Q2MN) THEN
24962 C...Evaluate at extremes and define coefficients for interpolation.
24963 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
24965 CALL PYPDFU(KFC,X,Q2B,XPB)
24967 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
24968 FVA=(X/XMN)**0.45D0*FLA
24969 FSA=(X/XMN)**(-0.08D0)*FLA
24972 C...Separate valence and sea parts of parton distribution.
24974 XFVA1=XPA(KFV1)-XPA(-KFV1)
24975 XPA(KFV1)=XPA(-KFV1)
24976 XFVA2=XPA(KFV2)-XPA(-KFV2)
24977 XPA(KFV2)=XPA(-KFV2)
24978 XFVB1=XPB(KFV1)-XPB(-KFV1)
24979 XPB(KFV1)=XPB(-KFV1)
24980 XFVB2=XPB(KFV2)-XPB(-KFV2)
24981 XPB(KFV2)=XPB(-KFV2)
24983 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
24984 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
24985 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
24986 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
24987 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
24988 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
24989 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
24990 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
24993 C...Interpolate for valence and sea. Put back together.
24995 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
24998 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
24999 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
25001 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
25002 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
25003 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
25004 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
25008 C...Small Q2 and small x: dampen boundary value and add term.
25011 C...Evaluate at boundary and define dampening factors.
25012 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
25013 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
25015 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
25016 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
25017 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
25018 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
25019 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
25020 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
25022 C...Separate valence and sea parts of parton distribution.
25024 XFV1=XPA(KFV1)-XPA(-KFV1)
25025 XPA(KFV1)=XPA(-KFV1)
25026 XFV2=XPA(KFV2)-XPA(-KFV2)
25027 XPA(KFV2)=XPA(-KFV2)
25029 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
25030 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
25031 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
25032 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
25035 C...Dampen valence and sea separately. Add constant terms.
25036 C...Put back together.
25038 XPQ(KFL)=FSA*XPA(KFL)
25042 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
25044 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
25045 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
25048 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
25050 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
25051 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
25052 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
25053 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
25059 C...Format for error printout.
25060 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
25065 C*********************************************************************
25068 C...Gives electron (or muon, or tau) parton distribution.
25070 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
25072 C...Double precision and integer declarations.
25073 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25074 IMPLICIT INTEGER(I-N)
25075 INTEGER PYK,PYCHGE,PYCOMP
25077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25079 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25080 COMMON/PYINT1/MINT(400),VINT(400)
25081 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
25083 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
25085 C...Interface to PDFLIB.
25086 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
25088 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
25089 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
25090 CHARACTER*20 PARM(20)
25091 DATA VALUE/20*0D0/,PARM/20*' '/
25093 C...Some common constants.
25099 IF(KFA.EQ.13) PME=PMAS(13,1)
25100 IF(KFA.EQ.15) PME=PMAS(15,1)
25101 XL=LOG(MAX(1D-10,X))
25102 X1L=LOG(MAX(1D-10,1D0-X))
25103 HLE=LOG(MAX(3D0,Q2/PME**2))
25104 HBE2=(AEM/PARU(1))*(HLE-1D0)
25106 C...Electron inside electron, see R. Kleiss et al., in Z physics at
25107 C...LEP 1, CERN 89-08, p. 34
25108 IF(MSTP(59).LE.1) THEN
25109 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
25110 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
25111 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
25112 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
25113 & 4D0*XL/(1D0-X)-5D0-X)
25115 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
25116 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
25117 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
25119 C...Zero distribution for very large x and rescale it for intermediate.
25120 IF(X.GT.1D0-1D-10) THEN
25122 ELSEIF(X.GT.1D0-1D-7) THEN
25123 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
25127 C...Photon and (transverse) W- inside electron.
25128 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
25129 IF(MSTP(13).LE.1) THEN
25132 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
25134 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
25135 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
25136 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
25138 C...Electron or positron inside photon inside electron.
25139 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
25140 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
25141 & 2D0*X*(1D0+X)*XL)
25142 XPEL(11)=XPEL(11)+XFSEA
25145 C...Initialize PDFLIB photon parton distributions.
25146 IF(MSTP(56).EQ.2) THEN
25150 VALUE(2)=MSTP(55)/1000
25152 VALUE(3)=MOD(MSTP(55),1000)
25153 IF(MINT(93).NE.3000000+MSTP(55)) THEN
25154 CALL PDFSET(PARM,VALUE)
25155 MINT(93)=3000000+MSTP(55)
25159 C...Quarks and gluons inside photon inside electron:
25160 C...numerical convolution required.
25169 IF(ITER.EQ.0) NSTP=2
25171 SXP(KFL)=0.5D0*SXP(KFL)
25174 IF(ITER.EQ.0) WTSTP=0.5D0
25175 C...Pick grid of x_{gamma} values logarithmically even.
25180 XLE=XL*(ISTP-0.5D0)/NSTP
25182 XE=MIN(1D0-1D-10,EXP(XLE))
25183 XG=MIN(1D0-1D-10,X/XE)
25184 C...Evaluate photon inside electron parton distribution for convolution.
25185 XPGP=1D0+(1D0-XE)**2
25186 IF(MSTP(13).LE.1) THEN
25189 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
25191 C...Evaluate photon parton distributions for convolution.
25192 IF(MSTP(56).EQ.1) THEN
25193 CALL PYPDGA(XG,Q2,XPGA)
25195 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
25197 ELSEIF(MSTP(56).EQ.2) THEN
25198 C...Call PDFLIB parton distributions.
25200 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
25201 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
25202 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
25203 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
25204 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
25205 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
25206 SXP(3)=SXP(3)+WTSTP*XPGP*STR
25207 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
25208 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
25209 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
25212 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
25213 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
25214 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
25216 C...Put convolution into output arrays.
25218 XPEL(0)=FCONV*SXP(0)
25220 XPEL(KFL)=FCONV*SXP(KFL)
25221 XPEL(-KFL)=XPEL(KFL)
25228 C*********************************************************************
25231 C...Gives photon parton distribution.
25233 SUBROUTINE PYPDGA(X,Q2,XPGA)
25235 C...Double precision and integer declarations.
25236 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25237 IMPLICIT INTEGER(I-N)
25238 INTEGER PYK,PYCHGE,PYCOMP
25240 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25241 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25242 COMMON/PYINT1/MINT(400),VINT(400)
25243 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
25245 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
25246 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
25247 &DGCS(4,3),DGDS(4,3),DGES(4,3)
25249 C...The following data lines are coefficients needed in the
25250 C...Drees and Grassie photon parton distribution parametrization.
25251 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
25252 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
25253 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
25254 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
25255 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
25256 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
25257 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
25258 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
25259 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
25260 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
25261 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
25262 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
25263 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
25264 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
25265 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
25266 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
25267 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
25268 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
25269 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
25270 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
25271 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
25272 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
25273 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
25274 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
25275 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
25276 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
25278 C...Photon parton distribution from Drees and Grassie.
25279 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
25284 IF(MSTP(57).LE.0) THEN
25287 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
25291 IF(Q2.GT.25D0) NF=4
25292 IF(Q2.GT.300D0) NF=5
25296 C...Evaluate gluon content.
25297 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
25298 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
25299 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
25300 XPGL=DGA*X**DGB*X1**DGC
25302 C...Evaluate up- and down-type quark content.
25303 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
25304 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
25305 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
25306 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
25307 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
25308 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
25309 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
25310 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
25311 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
25312 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
25313 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
25315 IF(NF.EQ.4) DGF=10D0
25316 IF(NF.EQ.5) DGF=55D0/6D0
25317 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
25319 XPQU=(XPQS+9D0*XPQN)/6D0
25320 XPQD=(XPQS-4.5D0*XPQN)/6D0
25321 ELSEIF(NF.EQ.4) THEN
25322 XPQU=(XPQS+6D0*XPQN)/8D0
25323 XPQD=(XPQS-6D0*XPQN)/8D0
25325 XPQU=(XPQS+7.5D0*XPQN)/10D0
25326 XPQD=(XPQS-5D0*XPQN)/10D0
25329 C...Put into output arrays.
25334 IF(NF.GE.4) XPGA(4)=AEM*XPQU
25335 IF(NF.GE.5) XPGA(5)=AEM*XPQD
25337 XPGA(-KFL)=XPGA(KFL)
25343 C*********************************************************************
25346 C...Constructs the F2 and parton distributions of the photon
25347 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
25348 C...For F2, c and b are included by the Bethe-Heitler formula;
25349 C...in the 'MSbar' scheme additionally a Cgamma term is added.
25350 C...Contains the SaS sets 1D, 1M, 2D and 2M.
25351 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25353 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
25355 C...Double precision and integer declarations.
25356 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25357 IMPLICIT INTEGER(I-N)
25358 INTEGER PYK,PYCHGE,PYCOMP
25360 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
25362 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
25363 SAVE /PYINT8/,/PYINT9/
25365 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
25366 C...Charm and bottom masses (low to compensate for J/psi etc.).
25367 DATA PMC/1.3D0/, PMB/4.6D0/
25368 C...alpha_em and alpha_em/(2*pi).
25369 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
25370 C...Lambda value for 4 flavours.
25372 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
25374 C...VMD couplings f_V**2/(4*pi).
25375 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
25376 C...Masses for rho (=omega) and phi.
25377 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
25378 C...Number of points in integration for IP2=1.
25396 C...Set Q0 cut-off parameter as function of set used.
25404 C...Scale choice for off-shell photon; common factors.
25409 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
25410 FACNOR=LOG(Q2/Q02)/NSTEP
25411 ELSEIF(IP2.EQ.2) THEN
25413 ELSEIF(IP2.EQ.3) THEN
25415 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
25416 ELSEIF(IP2.EQ.4) THEN
25417 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
25418 & ((Q2+P2)*(Q02+P2)))
25419 ELSEIF(IP2.EQ.5) THEN
25420 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
25421 & ((Q2+P2)*(Q02+P2)))
25422 P2MX=Q0*SQRT(P2MXA)
25423 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
25424 ELSEIF(IP2.EQ.6) THEN
25425 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
25426 & ((Q2+P2)*(Q02+P2)))
25427 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
25429 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
25430 & ((Q2+P2)*(Q02+P2)))
25431 P2MX=Q0*SQRT(P2MXA)
25433 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
25434 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
25435 IF(ABS(Q2-Q02).GT.1D-6) THEN
25436 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
25437 ELSEIF(P2.LT.Q02) THEN
25438 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
25444 C...Call VMD parametrization for d quark and use to give rho, omega,
25445 C...phi. Note dipole dampening for off-shell photon.
25446 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
25450 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
25451 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
25453 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
25455 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
25456 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
25457 XPVMD(3)=XPVMD(3)+FACS*XFVAL
25458 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
25459 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
25460 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
25461 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
25462 VXPVMD(2)=FRACU*FACUD*XFVAL
25463 VXPVMD(3)=FACS*XFVAL
25464 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
25465 VXPVMD(-2)=FRACU*FACUD*XFVAL
25466 VXPVMD(-3)=FACS*XFVAL
25469 C...Anomalous parametrizations for different strategies
25470 C...for off-shell photons; except full integration.
25472 C...Call anomalous parametrization for d + u + s.
25473 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
25475 XPANL(KFL)=FACNOR*XPGA(KFL)
25476 VXPANL(KFL)=FACNOR*VXPGA(KFL)
25479 C...Call anomalous parametrization for c and b.
25480 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
25482 XPANH(KFL)=FACNOR*XPGA(KFL)
25483 VXPANH(KFL)=FACNOR*VXPGA(KFL)
25485 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
25487 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
25488 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
25492 C...Special option: loop over flavours and integrate over k2.
25494 DO 160 ISTEP=1,NSTEP
25495 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
25496 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
25497 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
25498 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
25499 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
25500 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
25501 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
25503 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
25504 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
25505 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
25506 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
25512 C...Call Bethe-Heitler term expression for charm and bottom.
25513 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
25516 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
25520 C...For MSbar subtraction call C^gamma term expression for d, u, s.
25521 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
25522 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
25524 XPDIR(KFL)=XPGA(KFL)
25528 C...Store result in output array.
25531 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
25532 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
25533 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
25534 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
25535 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
25541 C*********************************************************************
25544 C...Evaluates the VMD parton distributions of a photon,
25545 C...evolved homogeneously from an initial scale P2 to Q2.
25546 C...Does not include dipole suppression factor.
25547 C...ISET is parton distribution set, see above;
25548 C...additionally ISET=0 is used for the evolution of an anomalous photon
25549 C...which branched at a scale P2 and then evolved homogeneously to Q2.
25550 C...ALAM is the 4-flavour Lambda, which is automatically converted
25551 C...to 3- and 5-flavour equivalents as needed.
25552 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25554 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
25556 C...Double precision and integer declarations.
25557 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25558 IMPLICIT INTEGER(I-N)
25559 INTEGER PYK,PYCHGE,PYCOMP
25560 C...Local arrays and data.
25561 DIMENSION XPGA(-6:6), VXPGA(-6:6)
25562 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
25571 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
25572 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
25573 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
25574 P2EFF=MAX(P2,1.2D0*ALAM3**2)
25575 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
25576 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
25577 Q2EFF=MAX(Q2,P2EFF)
25579 C...Find number of flavours at lower and upper scale.
25581 IF(P2EFF.LT.PMC**2) NFP=3
25582 IF(P2EFF.GT.PMB**2) NFP=5
25584 IF(Q2EFF.LT.PMC**2) NFQ=3
25585 IF(Q2EFF.GT.PMB**2) NFQ=5
25587 C...Find s as sum of 3-, 4- and 5-flavour parts.
25591 IF(NFQ.EQ.3) Q2DIV=Q2EFF
25592 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
25594 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
25596 IF(NFP.EQ.3) P2DIV=PMC**2
25598 IF(NFQ.EQ.5) Q2DIV=PMB**2
25599 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
25603 IF(NFP.EQ.5) P2DIV=P2EFF
25604 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
25607 C...Calculate frequent combinations of x and s.
25614 C...Evaluate homogeneous anomalous parton distributions below or
25615 C...above threshold.
25617 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25618 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25619 XVAL = X * 1.5D0 * (X**2+X1**2)
25623 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
25624 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
25625 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
25626 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
25627 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
25628 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
25629 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
25630 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
25631 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
25632 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
25633 & (2D0*X-1D0)*X*XL**2)
25636 C...Evaluate set 1D parton distributions below or above threshold.
25637 ELSEIF(ISET.EQ.1) THEN
25638 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25639 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25640 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
25641 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
25642 XSEA = 0.100D0 * X1**3.76D0
25644 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
25645 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
25646 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
25647 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
25648 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
25649 & X**0.40D0 * X1**(1.76D0+3D0*S)
25650 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
25651 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
25652 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
25653 XSEA0 = 0.100D0 * X1**3.76D0
25656 C...Evaluate set 1M parton distributions below or above threshold.
25657 ELSEIF(ISET.EQ.2) THEN
25658 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25659 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25660 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
25661 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
25664 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
25665 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
25666 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
25667 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
25668 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
25669 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
25670 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
25671 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
25676 C...Evaluate set 2D parton distributions below or above threshold.
25677 ELSEIF(ISET.EQ.3) THEN
25678 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25679 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25680 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
25681 XGLU = 1.925D0 * X1**2
25682 XSEA = 0.242D0 * X1**4
25684 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
25685 & X**(0.46D0+0.25D0*S) *
25686 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
25687 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
25688 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
25689 & EXP(-18.67D0*S) *
25690 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
25691 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
25692 & XL**(9.3D0*S/(1D0+1.7D0*S))
25693 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
25694 & (1D0-0.607D0*S+21.95D0*S2) *
25695 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
25696 XSEA0 = 0.242D0 * X1**4
25699 C...Evaluate set 2M parton distributions below or above threshold.
25700 ELSEIF(ISET.EQ.4) THEN
25701 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25702 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25703 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
25704 XGLU = 1.808D0 * X1**2
25705 XSEA = 0.209D0 * X1**4
25707 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
25708 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
25709 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
25710 & XL**(5.15D0*S/(1D0+2D0*S)) +
25711 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
25712 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
25713 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
25714 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
25715 & XL**(10.9D0*S/(1D0+2.5D0*S))
25716 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
25717 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
25718 & X1**(4D0+S) * XL**(0.45D0*S)
25719 XSEA0 = 0.209D0 * X1**4
25723 C...Threshold factors for c and b sea.
25724 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
25726 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
25727 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
25729 XCHM=XSEA*(1D0-(SCH/SLL)**2)
25731 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
25735 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
25736 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
25738 XBOT=XSEA*(1D0-(SBT/SLL)**2)
25740 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
25744 C...Fill parton distributions.
25751 XPGA(KFA)=XPGA(KFA)+XVAL
25753 XPGA(-KFL)=XPGA(KFL)
25761 C*********************************************************************
25764 C...Evaluates the parton distributions of the anomalous photon,
25765 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
25766 C...KF=0 gives the sum over (up to) 5 flavours,
25767 C...KF<0 limits to flavours up to abs(KF),
25768 C...KF>0 is for flavour KF only.
25769 C...ALAM is the 4-flavour Lambda, which is automatically converted
25770 C...to 3- and 5-flavour equivalents as needed.
25771 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25773 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
25775 C...Double precision and integer declarations.
25776 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25777 IMPLICIT INTEGER(I-N)
25778 INTEGER PYK,PYCHGE,PYCOMP
25779 C...Local arrays and data.
25780 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
25781 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
25788 IF(Q2.LE.P2) RETURN
25791 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
25792 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
25794 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
25795 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
25796 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
25797 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
25798 Q2EFF=MAX(Q2,P2EFF)
25801 C...Find number of flavours at lower and upper scale.
25803 IF(P2EFF.LT.PMC**2) NFP=3
25804 IF(P2EFF.GT.PMB**2) NFP=5
25806 IF(Q2EFF.LT.PMC**2) NFQ=3
25807 IF(Q2EFF.GT.PMB**2) NFQ=5
25809 C...Define range of flavour loop.
25813 ELSEIF(KF.LT.0) THEN
25821 C...Loop over flavours the photon can branch into.
25822 DO 110 KFL=KFLMN,KFLMX
25824 C...Light flavours: calculate t range and (approximate) s range.
25825 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
25826 TDIFF=LOG(Q2EFF/P2EFF)
25827 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
25828 & LOG(P2EFF/ALAMSQ(NFQ)))
25829 IF(NFQ.GT.NFP) THEN
25831 IF(NFQ.EQ.4) Q2DIV=PMC**2
25832 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
25833 & LOG(P2EFF/ALAMSQ(NFQ)))
25834 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
25835 & LOG(P2EFF/ALAMSQ(NFQ-1)))
25836 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
25838 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
25840 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
25841 & LOG(P2EFF/ALAMSQ(4)))
25842 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
25843 & LOG(P2EFF/ALAMSQ(3)))
25844 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
25847 C...u and s quark do not need a separate treatment when d has been done.
25848 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
25850 C...Charm: as above, but only include range above c threshold.
25851 ELSEIF(KFL.EQ.4) THEN
25852 IF(Q2.LE.PMC**2) GOTO 110
25853 P2EFF=MAX(P2EFF,PMC**2)
25854 Q2EFF=MAX(Q2EFF,P2EFF)
25855 TDIFF=LOG(Q2EFF/P2EFF)
25856 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
25857 & LOG(P2EFF/ALAMSQ(NFQ)))
25858 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
25860 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
25861 & LOG(P2EFF/ALAMSQ(NFQ)))
25862 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
25863 & LOG(P2EFF/ALAMSQ(NFQ-1)))
25864 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
25867 C...Bottom: as above, but only include range above b threshold.
25868 ELSEIF(KFL.EQ.5) THEN
25869 IF(Q2.LE.PMB**2) GOTO 110
25870 P2EFF=MAX(P2EFF,PMB**2)
25871 Q2EFF=MAX(Q2,P2EFF)
25872 TDIFF=LOG(Q2EFF/P2EFF)
25873 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
25874 & LOG(P2EFF/ALAMSQ(NFQ)))
25877 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
25879 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
25880 FAC=AEM2PI*2D0*CHSQ*TDIFF
25882 C...Evaluate parton distributions (normalized to unit momentum sum).
25883 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
25884 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
25885 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
25886 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
25887 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
25888 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
25889 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
25890 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
25891 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
25892 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
25893 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
25894 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
25896 C...Threshold factors for c and b sea.
25897 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
25899 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
25900 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
25901 XCHM=XSEA*(1D0-(SCH/SLL)**3)
25904 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
25905 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
25906 XBOT=XSEA*(1D0-(SBT/SLL)**3)
25910 C...Add contribution of each valence flavour.
25911 XPGA(0)=XPGA(0)+FAC*XGLU
25912 XPGA(1)=XPGA(1)+FAC*XSEA
25913 XPGA(2)=XPGA(2)+FAC*XSEA
25914 XPGA(3)=XPGA(3)+FAC*XSEA
25915 XPGA(4)=XPGA(4)+FAC*XCHM
25916 XPGA(5)=XPGA(5)+FAC*XBOT
25917 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
25918 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
25921 XPGA(-KFL)=XPGA(KFL)
25922 VXPGA(-KFL)=VXPGA(KFL)
25928 C*********************************************************************
25931 C...Evaluates the Bethe-Heitler cross section for heavy flavour
25933 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25935 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
25937 C...Double precision and integer declarations.
25938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25939 IMPLICIT INTEGER(I-N)
25940 INTEGER PYK,PYCHGE,PYCOMP
25943 DATA AEM2PI/0.0011614D0/
25949 C...Check kinematics limits.
25950 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
25952 BETA2=1D0-4D0*PM2/W2
25953 IF(BETA2.LT.1D-10) RETURN
25957 C...Simple case: P2 = 0.
25958 IF(P2.LT.1D-4) THEN
25959 IF(BETA.LT.0.99D0) THEN
25960 XBL=LOG((1D0+BETA)/(1D0-BETA))
25962 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
25964 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
25965 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
25967 C...Complicated case: P2 > 0, based on approximation of
25968 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
25970 RPQ=1D0-4D0*X**2*P2/Q2
25971 IF(RPQ.GT.1D-10) THEN
25972 RPBE=SQRT(RPQ*BETA2)
25973 IF(RPBE.LT.0.99D0) THEN
25974 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
25975 XBI=2D0*RPBE/(1D0-RPBE**2)
25977 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
25978 XBL=LOG((1D0+RPBE)**2/RPBESN)
25979 XBI=2D0*RPBE/RPBESN
25981 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
25982 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
25983 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
25987 C...Multiply by charge-squared etc. to get parton distribution.
25989 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
25990 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
25995 C*********************************************************************
25998 C...Evaluates the direct contribution, i.e. the C^gamma term,
25999 C...as needed in MSbar parametrizations.
26000 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
26002 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
26004 C...Double precision and integer declarations.
26005 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26006 IMPLICIT INTEGER(I-N)
26007 INTEGER PYK,PYCHGE,PYCOMP
26008 C...Local array and data.
26009 DIMENSION XPGA(-6:6)
26010 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
26017 C...Evaluate common x-dependent expression.
26018 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
26019 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
26021 C...d, u, s part by simple charge factor.
26022 XPGA(1)=(1D0/9D0)*CGAM
26023 XPGA(2)=(4D0/9D0)*CGAM
26024 XPGA(3)=(1D0/9D0)*CGAM
26026 C...Also fill for antiquarks.
26034 C*********************************************************************
26037 C...Gives pi+ parton distribution according to two different
26038 C...parametrizations.
26040 SUBROUTINE PYPDPI(X,Q2,XPPI)
26042 C...Double precision and integer declarations.
26043 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26044 IMPLICIT INTEGER(I-N)
26045 INTEGER PYK,PYCHGE,PYCOMP
26047 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26048 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26049 COMMON/PYINT1/MINT(400),VINT(400)
26050 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
26052 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
26054 C...The following data lines are coefficients needed in the
26055 C...Owens pion parton distribution parametrizations, see below.
26056 C...Expansion coefficients for up and down valence quark distributions.
26057 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
26058 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
26059 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
26060 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
26061 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
26062 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
26063 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
26064 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
26065 C...Expansion coefficients for gluon distribution.
26066 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
26067 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
26068 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
26069 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
26070 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
26071 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
26072 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
26073 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
26074 C...Expansion coefficients for (up+down+strange) quark sea distribution.
26075 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
26076 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
26077 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
26078 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
26079 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
26080 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
26081 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
26082 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
26083 C...Expansion coefficients for charm quark sea distribution.
26084 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
26085 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
26086 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
26087 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
26088 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
26089 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
26090 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
26091 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
26093 C...Euler's beta function, requires ordinary Gamma function
26094 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
26096 C...Reset output array.
26101 IF(MSTP(53).LE.2) THEN
26102 C...Pion parton distributions from Owens.
26103 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
26105 C...Determine set, Lambda and s expansion variable.
26107 IF(NSET.EQ.1) ALAM=0.2D0
26108 IF(NSET.EQ.2) ALAM=0.4D0
26110 IF(MSTP(57).LE.0) THEN
26113 Q2IN=MIN(2D3,MAX(4D0,Q2))
26114 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
26117 C...Calculate parton distributions.
26120 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
26121 & COW(3,IS,KFL,NSET)*SD**2
26124 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
26126 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
26131 C...Put into output array.
26134 XPPI(2)=XQ(1)+XQ(3)/6D0
26137 XPPI(-1)=XQ(1)+XQ(3)/6D0
26142 C...Leading order pion parton distributions from Gluck, Reya and Vogt.
26143 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
26147 C...Determine s expansion variable and some x expressions.
26149 IF(MSTP(57).LE.0) THEN
26152 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
26153 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
26159 C...Evaluate valence, gluon and sea distributions.
26160 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
26161 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
26162 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
26164 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
26165 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
26167 & (1D0-X)**(0.390D0+1.053D0*SD)
26168 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
26170 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
26172 & XL**(2.538D0-0.763D0*SD)
26173 IF(SD.LE.0.888D0) THEN
26176 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
26178 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
26181 IF(SD.LE.1.351D0) THEN
26184 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
26185 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
26189 C...Put into output array.
26197 XPPI(-KFL)=XPPI(KFL)
26199 XPPI(2)=XPPI(2)+XFVAL
26200 XPPI(-1)=XPPI(-1)+XFVAL
26206 C*********************************************************************
26209 C...Gives proton parton distributions according to a few different
26210 C...parametrizations.
26212 SUBROUTINE PYPDPR(X,Q2,XPPR)
26214 C...Double precision and integer declarations.
26215 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26216 IMPLICIT INTEGER(I-N)
26217 INTEGER PYK,PYCHGE,PYCOMP
26219 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26220 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26221 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26222 COMMON/PYINT1/MINT(400),VINT(400)
26223 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
26224 C...Arrays and data.
26225 DIMENSION XPPR(-6:6),Q2MIN(16)
26226 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
26227 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
26229 C...Reset output array.
26234 C...Common preliminaries.
26235 NSET=MAX(1,MIN(16,MSTP(51)))
26236 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
26237 VINT(231)=Q2MIN(NSET)
26238 IF(MSTP(57).EQ.0) THEN
26241 Q2L=MAX(Q2MIN(NSET),Q2)
26244 IF(NSET.GE.1.AND.NSET.LE.3) THEN
26245 C...Interface to the CTEQ 3 parton distributions.
26246 QRT=SQRT(MAX(1D0,Q2L))
26248 C...Loop over flavours.
26251 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
26252 ELSEIF(I.LE.2) THEN
26253 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
26259 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
26260 C...Interface to the GRV 94 distributions.
26262 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26263 ELSEIF(NSET.EQ.5) THEN
26264 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26266 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26269 C...Put into output array.
26271 XPPR(-1)=0.5D0*(UDB+DEL)
26272 XPPR(-2)=0.5D0*(UDB-DEL)
26276 XPPR(1)=DV+XPPR(-1)
26277 XPPR(2)=UV+XPPR(-2)
26282 ELSEIF(NSET.EQ.7) THEN
26283 C...Interface to the CTEQ 5L parton distributions.
26284 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
26285 C...freezing x*f(x,Q2) at borders.
26286 QRT=SQRT(MAX(1D0,MIN(1D4,Q2L)))
26287 XIN=MAX(1D-6,MIN(1D0,X))
26289 C...Loop over flavours (with u <-> d notation mismatch).
26290 SUMUDB=PYCT5L(-1,XIN,QRT)
26291 RATUDB=PYCT5L(-2,XIN,QRT)
26294 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
26295 ELSEIF(I.EQ.2) THEN
26296 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
26297 ELSEIF(I.EQ.-1) THEN
26298 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
26299 ELSEIF(I.EQ.-2) THEN
26300 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
26302 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
26303 IF(I.LT.0) XPPR(-I)=XPPR(I)
26307 ELSEIF(NSET.EQ.8) THEN
26308 C...Interface to the CTEQ 5M1 parton distributions.
26309 QRT=SQRT(MAX(1D0,MIN(1D4,Q2L)))
26310 XIN=MAX(1D-6,MIN(1D0,X))
26312 C...Loop over flavours (with u <-> d notation mismatch).
26313 SUMUDB=PYCT5M(-1,XIN,QRT)
26314 RATUDB=PYCT5M(-2,XIN,QRT)
26317 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
26318 ELSEIF(I.EQ.2) THEN
26319 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
26320 ELSEIF(I.EQ.-1) THEN
26321 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
26322 ELSEIF(I.EQ.-2) THEN
26323 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
26325 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
26326 IF(I.LT.0) XPPR(-I)=XPPR(I)
26330 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
26331 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
26332 C...obsolete but offers backwards compatibility.
26333 CALL PYPDPO(X,Q2L,XPPR)
26335 C...Symmetric choice for debugging only
26336 ELSEIF(NSET.EQ.16) THEN
26354 C*********************************************************************
26357 C...Gives the CTEQ 3 parton distribution function sets in
26358 C...parametrized form, of October 24, 1994.
26359 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
26360 C...J. Qiu, W.K. Tung and H. Weerts.
26362 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
26364 C...Double precision declaration.
26365 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26366 IMPLICIT INTEGER(I-N)
26368 C...Data on Lambda values of fits, minimum Q and quark masses.
26369 DIMENSION ALM(3), QMS(4:6)
26370 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
26371 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
26373 C....Check flavour thresholds. Set up QI for SB.
26376 IF(Q .LE. QMS(IP)) THEN
26385 C...Use "standard lambda" of parametrization program for expansion.
26387 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
26392 C...Expansion for CTEQ3L.
26393 IF(ISET .EQ. 1) THEN
26394 IF(IPRT .EQ. 2) THEN
26395 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
26397 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
26398 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
26399 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
26400 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
26401 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
26402 ELSEIF(IPRT .EQ. 1) THEN
26403 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
26405 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
26406 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
26407 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
26408 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
26409 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
26410 ELSEIF(IPRT .EQ. 0) THEN
26411 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
26413 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
26414 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
26415 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
26416 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
26417 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
26418 ELSEIF(IPRT .EQ. -1) THEN
26419 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
26421 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
26422 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
26423 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
26424 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
26425 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
26426 ELSEIF(IPRT .EQ. -2) THEN
26427 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
26429 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
26430 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
26431 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
26432 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
26433 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
26434 ELSEIF(IPRT .EQ. -3) THEN
26435 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
26437 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
26438 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
26439 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
26440 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
26441 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
26442 ELSEIF(IPRT .EQ. -4) THEN
26443 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
26445 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
26446 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
26447 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
26448 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
26449 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
26450 ELSEIF(IPRT .EQ. -5) THEN
26451 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
26453 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
26454 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
26455 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
26456 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
26457 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
26458 ELSEIF(IPRT .EQ. -6) THEN
26459 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
26461 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
26462 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
26463 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
26464 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
26465 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
26468 C...Expansion for CTEQ3M.
26469 ELSEIF(ISET .EQ. 2) THEN
26470 IF(IPRT .EQ. 2) THEN
26471 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
26473 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
26474 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
26475 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
26476 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
26477 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
26478 ELSEIF(IPRT .EQ. 1) THEN
26479 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
26481 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
26482 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
26483 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
26484 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
26485 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
26486 ELSEIF(IPRT .EQ. 0) THEN
26487 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
26489 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
26490 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
26491 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
26492 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
26493 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
26494 ELSEIF(IPRT .EQ. -1) THEN
26495 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
26497 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
26498 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
26499 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
26500 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
26501 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
26502 ELSEIF(IPRT .EQ. -2) THEN
26503 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
26505 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
26506 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
26507 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
26508 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
26509 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
26510 ELSEIF(IPRT .EQ. -3) THEN
26511 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
26513 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
26514 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
26515 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
26516 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
26517 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
26518 ELSEIF(IPRT .EQ. -4) THEN
26519 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
26521 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
26522 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
26523 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
26524 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
26525 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
26526 ELSEIF(IPRT .EQ. -5) THEN
26527 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
26529 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
26530 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
26531 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
26532 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
26533 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
26534 ELSEIF(IPRT .EQ. -6) THEN
26535 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
26537 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
26538 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
26539 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
26540 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
26541 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
26544 C...Expansion for CTEQ3D.
26545 ELSEIF(ISET .EQ. 3) THEN
26546 IF(IPRT .EQ. 2) THEN
26547 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
26549 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
26550 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
26551 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
26552 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
26553 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
26554 ELSEIF(IPRT .EQ. 1) THEN
26555 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
26557 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
26558 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
26559 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
26560 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
26561 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
26562 ELSEIF(IPRT .EQ. 0) THEN
26563 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
26565 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
26566 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
26567 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
26568 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
26569 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
26570 ELSEIF(IPRT .EQ. -1) THEN
26571 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
26573 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
26574 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
26575 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
26576 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
26577 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
26578 ELSEIF(IPRT .EQ. -2) THEN
26579 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
26581 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
26582 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
26583 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
26584 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
26585 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
26586 ELSEIF(IPRT .EQ. -3) THEN
26587 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
26589 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
26590 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
26591 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
26592 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
26593 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
26594 ELSEIF(IPRT .EQ. -4) THEN
26595 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
26597 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
26598 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
26599 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
26600 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
26601 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
26602 ELSEIF(IPRT .EQ. -5) THEN
26603 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
26605 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
26606 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
26607 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
26608 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
26609 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
26610 ELSEIF(IPRT .EQ. -6) THEN
26611 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
26613 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
26614 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
26615 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
26616 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
26617 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
26621 C...Calculation of x * f(x, Q).
26622 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
26623 & *(LOG(1D0+1D0/X))**A5 )
26628 C*********************************************************************
26631 C...Gives the GRV 94 L (leading order) parton distribution function set
26632 C...in parametrized form.
26633 C...Authors: M. Glueck, E. Reya and A. Vogt.
26635 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26637 C...Double precision declaration.
26638 IMPLICIT DOUBLE PRECISION (A - Z)
26640 C...Common expressions.
26642 LAM2 = 0.2322D0 * 0.2322D0
26643 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
26649 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
26650 AKU = 0.590D0 - 0.024D0 * S
26651 BKU = 0.131D0 + 0.063D0 * S
26652 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
26653 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
26654 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
26655 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
26656 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
26659 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
26661 BKD = 0.486D0 + 0.062D0 * S
26662 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
26663 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
26664 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
26665 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
26666 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
26669 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
26670 AKE = 0.409D0 - 0.005D0 * S
26671 BKE = 0.799D0 + 0.071D0 * S
26672 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
26673 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
26675 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
26676 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
26681 AKX = 0.410D0 - 0.232D0 * S
26682 BKX = 0.534D0 - 0.457D0 * S
26683 AGX = 0.890D0 - 0.140D0 * S
26685 CX = 0.320D0 + 0.683D0 * S
26686 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
26687 EX = 4.119D0 + 1.713D0 * S
26688 ESX = 0.682D0 + 2.978D0 * S
26689 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
26696 AKS = 1.798D0 - 0.596D0 * S
26697 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
26698 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
26699 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
26700 EST = 3.981D0 + 1.638D0 * S
26702 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
26710 BC = 4.24D0 - 0.804D0 * S
26711 DCT = 3.46D0 - 1.076D0 * S
26712 ECT = 4.61D0 + 1.49D0 * S
26713 ESC = 2.555D0 + 1.961D0 * S
26714 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
26723 DBT = 2.929D0 + 1.396D0 * S
26724 EBT = 4.71D0 + 1.514D0 * S
26725 ESB = 4.02D0 + 1.239D0 * S
26726 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
26731 AKG = 1.742D0 - 0.930D0 * S
26732 BKG = - 0.399D0 * S2
26733 AG = 7.486D0 - 2.185D0 * S
26734 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
26735 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
26736 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
26737 EG = 0.807D0 + 2.005D0 * S
26738 ESG = 3.841D0 + 0.316D0 * S
26739 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
26745 C*********************************************************************
26748 C...Gives the GRV 94 M (MSbar) parton distribution function set
26749 C...in parametrized form.
26750 C...Authors: M. Glueck, E. Reya and A. Vogt.
26752 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26754 C...Double precision declaration.
26755 IMPLICIT DOUBLE PRECISION (A - Z)
26757 C...Common expressions.
26759 LAM2 = 0.248D0 * 0.248D0
26760 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
26766 NU = 1.304D0 + 0.863D0 * S
26767 AKU = 0.558D0 - 0.020D0 * S
26769 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
26770 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
26771 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
26772 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
26773 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
26776 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
26777 AKD = 0.270D0 - 0.019D0 * S
26779 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
26780 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
26781 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
26782 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
26783 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
26786 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
26787 AKE = 0.409D0 - 0.007D0 * S
26788 BKE = 0.782D0 + 0.082D0 * S
26789 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
26790 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
26792 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
26793 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
26801 BGX = 3.210D0 - 1.866D0 * S
26803 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
26804 EX = 3.077D0 + 1.446D0 * S
26805 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
26806 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
26813 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
26814 AS = -4.329D0 + 1.131D0 * S
26815 BS = 9.568D0 - 1.744D0 * S
26816 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
26817 EST = 3.031D0 + 1.639D0 * S
26818 ESS = 5.837D0 + 0.815D0 * S
26819 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
26825 AKC = -0.625D0 - 0.523D0 * S
26827 BC = 1.896D0 + 1.616D0 * S
26828 DCT = 4.12D0 + 0.683D0 * S
26829 ECT = 4.36D0 + 1.328D0 * S
26830 ESC = 0.677D0 + 0.679D0 * S
26831 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
26837 AKB = - 0.193D0 * S
26840 DBT = 3.447D0 + 0.927D0 * S
26841 EBT = 4.68D0 + 1.259D0 * S
26842 ESB = 1.892D0 + 2.199D0 * S
26843 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
26848 AKG = 1.724D0 + 0.157D0 * S
26849 BKG = 0.800D0 + 1.016D0 * S
26850 AG = 7.517D0 - 2.547D0 * S
26851 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
26852 CG = 4.039D0 + 1.491D0 * S
26853 DG = 3.404D0 + 0.830D0 * S
26854 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
26855 ESG = 3.256D0 - 0.436D0 * S
26856 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
26861 C*********************************************************************
26864 C...Gives the GRV 94 D (DIS) parton distribution function set
26865 C...in parametrized form.
26866 C...Authors: M. Glueck, E. Reya and A. Vogt.
26868 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26870 C...Double precision declaration.
26871 IMPLICIT DOUBLE PRECISION (A - Z)
26873 C...Common expressions.
26875 LAM2 = 0.248D0 * 0.248D0
26876 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
26882 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
26883 AKU = 0.563D0 - 0.025D0 * S
26884 BKU = 0.054D0 + 0.154D0 * S
26885 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
26886 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
26887 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
26888 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
26889 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
26892 ND = 0.156D0 - 0.017D0 * S
26893 AKD = 0.299D0 - 0.022D0 * S
26894 BKD = 0.259D0 - 0.015D0 * S
26895 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
26896 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
26897 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
26898 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
26899 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
26902 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
26903 AKE = 0.419D0 - 0.013D0 * S
26904 BKE = 1.064D0 - 0.038D0 * S
26905 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
26906 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
26907 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
26908 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
26909 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
26914 AKX = 0.326D0 + 0.150D0 * S
26915 BKX = 0.956D0 + 0.405D0 * S
26917 BGX = 3.794D0 - 2.359D0 * DS
26919 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
26920 EX = 3.049D0 + 1.597D0 * S
26921 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
26922 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
26929 AKS = 1.415D0 - 0.641D0 * DS
26930 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
26931 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
26932 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
26933 EST = 4.546D0 + 0.372D0 * S2
26934 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
26935 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
26941 AKC = -0.625D0 - 0.523D0 * S
26943 BC = 1.896D0 + 1.616D0 * S
26944 DCT = 4.12D0 + 0.683D0 * S
26945 ECT = 4.36D0 + 1.328D0 * S
26946 ESC = 0.677D0 + 0.679D0 * S
26947 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
26953 AKB = - 0.193D0 * S
26956 DBT = 3.447D0 + 0.927D0 * S
26957 EBT = 4.68D0 + 1.259D0 * S
26958 ESB = 1.892D0 + 2.199D0 * S
26959 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
26965 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
26966 AG = 25.09D0 - 7.935D0 * S
26967 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
26968 CG = 590.3D0 - 173.8D0 * S
26969 DG = 5.196D0 + 1.857D0 * S
26970 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
26971 ESG = 3.232D0 - 0.542D0 * S
26972 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
26977 C*********************************************************************
26980 C...Auxiliary for the GRV 94 parton distribution functions
26981 C...for u and d valence and d-u sea.
26982 C...Authors: M. Glueck, E. Reya and A. Vogt.
26984 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
26986 C...Double precision declaration.
26987 IMPLICIT DOUBLE PRECISION (A - Z)
26991 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
26997 C*********************************************************************
27000 C...Auxiliary for the GRV 94 parton distribution functions
27001 C...for d+u sea and gluon.
27002 C...Authors: M. Glueck, E. Reya and A. Vogt.
27004 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
27006 C...Double precision declaration.
27007 IMPLICIT DOUBLE PRECISION (A - Z)
27011 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
27012 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
27017 C*********************************************************************
27020 C...Auxiliary for the GRV 94 parton distribution functions
27021 C...for s, c and b sea.
27022 C...Authors: M. Glueck, E. Reya and A. Vogt.
27024 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
27026 C...Double precision declaration.
27027 IMPLICIT DOUBLE PRECISION (A - Z)
27035 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
27036 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
27042 C*********************************************************************
27044 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
27045 C...in Parametrized Form
27046 C... September 15, 1999
27048 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
27049 C... CTEQ5 PPARTON DISTRIBUTIONS"
27052 C...The CTEQ5M1 set given here is an updated version of the original
27053 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
27054 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
27055 C...almost all applications.
27056 C...The improvement is in the QCD evolution which is now more
27057 C...accurate, and which agrees completely with the benchmark work
27058 C...of the HERA 96/97 Workshop.
27059 C...The differences between the parametrized and the corresponding
27060 C...table versions (on which it is based) are of similar order as
27061 C...between the two version.
27063 C...!! Because accurate parametrizations over a wide range of (x,Q)
27064 C...is hard to obtain, only the most widely used sets CTEQ5M and
27065 C...CTEQ5L are available in parametrized form for now.
27067 C...These parametrizations were obtained by Jon Pumplin.
27069 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
27070 C -------------------------------------------------------------------
27071 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
27072 C 3 CTEQ5L Leading Order 0.127 192 146
27073 C -------------------------------------------------------------------
27074 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
27075 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
27078 C...The two Iset value are adopted to agree with the standard table
27081 C...Range of validity:
27082 C...The range of (x, Q) covered by this parametrization of the QCD
27083 C...evolved parton distributions is 1E-6 < x < 1 ;
27084 C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
27085 C...data only in a subset of that region; and the assumed DGLAP
27086 C...evolution is unlikely to be valid for all of it either.
27088 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
27089 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
27090 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
27091 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
27093 C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
27096 C...Auxiliary function for parametrization of CTEQ5L.
27097 C...Author: J. Pumplin 9/99.
27099 FUNCTION PYCT5L(IFL,X,Q)
27101 C...Double precision declaration.
27102 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27103 IMPLICIT INTEGER(I-N)
27105 PARAMETER (NEX=8, NLF=2)
27106 DIMENSION AM(0:NEX,0:NLF,-5:2)
27107 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
27108 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
27109 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
27110 DIMENSION AF(0:NEX)
27112 DATA MEXVEC( 2) / 8 /
27113 DATA MLFVEC( 2) / 2 /
27114 DATA UT1VEC( 2) / 0.4971265E+01 /
27115 DATA UT2VEC( 2) / -0.1105128E+01 /
27116 DATA ALFVEC( 2) / 0.2987216E+00 /
27117 DATA QMAVEC( 2) / 0.0000000E+00 /
27118 DATA (AM( 0,K, 2),K=0, 2)
27119 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
27120 DATA (AM( 1,K, 2),K=0, 2)
27121 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
27122 DATA (AM( 2,K, 2),K=0, 2)
27123 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
27124 DATA (AM( 3,K, 2),K=0, 2)
27125 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
27126 DATA (AM( 4,K, 2),K=0, 2)
27127 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
27128 DATA (AM( 5,K, 2),K=0, 2)
27129 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
27130 DATA (AM( 6,K, 2),K=0, 2)
27131 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
27132 DATA (AM( 7,K, 2),K=0, 2)
27133 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
27134 DATA (AM( 8,K, 2),K=0, 2)
27135 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
27137 DATA MEXVEC( 1) / 8 /
27138 DATA MLFVEC( 1) / 2 /
27139 DATA UT1VEC( 1) / 0.2612618E+01 /
27140 DATA UT2VEC( 1) / -0.1258304E+06 /
27141 DATA ALFVEC( 1) / 0.3407552E+00 /
27142 DATA QMAVEC( 1) / 0.0000000E+00 /
27143 DATA (AM( 0,K, 1),K=0, 2)
27144 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
27145 DATA (AM( 1,K, 1),K=0, 2)
27146 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
27147 DATA (AM( 2,K, 1),K=0, 2)
27148 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
27149 DATA (AM( 3,K, 1),K=0, 2)
27150 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
27151 DATA (AM( 4,K, 1),K=0, 2)
27152 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
27153 DATA (AM( 5,K, 1),K=0, 2)
27154 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
27155 DATA (AM( 6,K, 1),K=0, 2)
27156 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
27157 DATA (AM( 7,K, 1),K=0, 2)
27158 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
27159 DATA (AM( 8,K, 1),K=0, 2)
27160 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
27162 DATA MEXVEC( 0) / 8 /
27163 DATA MLFVEC( 0) / 2 /
27164 DATA UT1VEC( 0) / -0.4656819E+00 /
27165 DATA UT2VEC( 0) / -0.2742390E+03 /
27166 DATA ALFVEC( 0) / 0.4491863E+00 /
27167 DATA QMAVEC( 0) / 0.0000000E+00 /
27168 DATA (AM( 0,K, 0),K=0, 2)
27169 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
27170 DATA (AM( 1,K, 0),K=0, 2)
27171 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
27172 DATA (AM( 2,K, 0),K=0, 2)
27173 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
27174 DATA (AM( 3,K, 0),K=0, 2)
27175 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
27176 DATA (AM( 4,K, 0),K=0, 2)
27177 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
27178 DATA (AM( 5,K, 0),K=0, 2)
27179 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
27180 DATA (AM( 6,K, 0),K=0, 2)
27181 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
27182 DATA (AM( 7,K, 0),K=0, 2)
27183 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
27184 DATA (AM( 8,K, 0),K=0, 2)
27185 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
27187 DATA MEXVEC(-1) / 8 /
27188 DATA MLFVEC(-1) / 2 /
27189 DATA UT1VEC(-1) / 0.3862583E+01 /
27190 DATA UT2VEC(-1) / -0.1265969E+01 /
27191 DATA ALFVEC(-1) / 0.2457668E+00 /
27192 DATA QMAVEC(-1) / 0.0000000E+00 /
27193 DATA (AM( 0,K,-1),K=0, 2)
27194 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
27195 DATA (AM( 1,K,-1),K=0, 2)
27196 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
27197 DATA (AM( 2,K,-1),K=0, 2)
27198 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
27199 DATA (AM( 3,K,-1),K=0, 2)
27200 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
27201 DATA (AM( 4,K,-1),K=0, 2)
27202 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
27203 DATA (AM( 5,K,-1),K=0, 2)
27204 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
27205 DATA (AM( 6,K,-1),K=0, 2)
27206 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
27207 DATA (AM( 7,K,-1),K=0, 2)
27208 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
27209 DATA (AM( 8,K,-1),K=0, 2)
27210 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
27212 DATA MEXVEC(-2) / 7 /
27213 DATA MLFVEC(-2) / 2 /
27214 DATA UT1VEC(-2) / 0.1895615E+00 /
27215 DATA UT2VEC(-2) / -0.3069097E+01 /
27216 DATA ALFVEC(-2) / 0.5293999E+00 /
27217 DATA QMAVEC(-2) / 0.0000000E+00 /
27218 DATA (AM( 0,K,-2),K=0, 2)
27219 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
27220 DATA (AM( 1,K,-2),K=0, 2)
27221 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
27222 DATA (AM( 2,K,-2),K=0, 2)
27223 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
27224 DATA (AM( 3,K,-2),K=0, 2)
27225 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
27226 DATA (AM( 4,K,-2),K=0, 2)
27227 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
27228 DATA (AM( 5,K,-2),K=0, 2)
27229 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
27230 DATA (AM( 6,K,-2),K=0, 2)
27231 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
27232 DATA (AM( 7,K,-2),K=0, 2)
27233 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
27235 DATA MEXVEC(-3) / 7 /
27236 DATA MLFVEC(-3) / 2 /
27237 DATA UT1VEC(-3) / 0.3753257E+01 /
27238 DATA UT2VEC(-3) / -0.1113085E+01 /
27239 DATA ALFVEC(-3) / 0.3713141E+00 /
27240 DATA QMAVEC(-3) / 0.0000000E+00 /
27241 DATA (AM( 0,K,-3),K=0, 2)
27242 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
27243 DATA (AM( 1,K,-3),K=0, 2)
27244 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
27245 DATA (AM( 2,K,-3),K=0, 2)
27246 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
27247 DATA (AM( 3,K,-3),K=0, 2)
27248 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
27249 DATA (AM( 4,K,-3),K=0, 2)
27250 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
27251 DATA (AM( 5,K,-3),K=0, 2)
27252 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
27253 DATA (AM( 6,K,-3),K=0, 2)
27254 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
27255 DATA (AM( 7,K,-3),K=0, 2)
27256 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
27258 DATA MEXVEC(-4) / 7 /
27259 DATA MLFVEC(-4) / 2 /
27260 DATA UT1VEC(-4) / 0.4400772E+01 /
27261 DATA UT2VEC(-4) / -0.1356116E+01 /
27262 DATA ALFVEC(-4) / 0.3712017E-01 /
27263 DATA QMAVEC(-4) / 0.1300000E+01 /
27264 DATA (AM( 0,K,-4),K=0, 2)
27265 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
27266 DATA (AM( 1,K,-4),K=0, 2)
27267 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
27268 DATA (AM( 2,K,-4),K=0, 2)
27269 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
27270 DATA (AM( 3,K,-4),K=0, 2)
27271 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
27272 DATA (AM( 4,K,-4),K=0, 2)
27273 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
27274 DATA (AM( 5,K,-4),K=0, 2)
27275 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
27276 DATA (AM( 6,K,-4),K=0, 2)
27277 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
27278 DATA (AM( 7,K,-4),K=0, 2)
27279 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
27281 DATA MEXVEC(-5) / 6 /
27282 DATA MLFVEC(-5) / 2 /
27283 DATA UT1VEC(-5) / 0.5562568E+01 /
27284 DATA UT2VEC(-5) / -0.1801317E+01 /
27285 DATA ALFVEC(-5) / 0.4952010E-02 /
27286 DATA QMAVEC(-5) / 0.4500000E+01 /
27287 DATA (AM( 0,K,-5),K=0, 2)
27288 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
27289 DATA (AM( 1,K,-5),K=0, 2)
27290 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
27291 DATA (AM( 2,K,-5),K=0, 2)
27292 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
27293 DATA (AM( 3,K,-5),K=0, 2)
27294 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
27295 DATA (AM( 4,K,-5),K=0, 2)
27296 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
27297 DATA (AM( 5,K,-5),K=0, 2)
27298 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
27299 DATA (AM( 6,K,-5),K=0, 2)
27300 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
27302 IF(Q .LE. QMAVEC(IFL)) THEN
27307 IF(X .GE. 1.D0) THEN
27312 TMP = LOG(Q/ALFVEC(IFL))
27313 IF(TMP .LE. 0.D0) THEN
27325 DO 100 K = 0, MLFVEC(IFL)
27326 AF(I) = AF(I) + SBX*AM(I,K,IFL)
27332 U = LOG(X/0.00001D0)
27334 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
27335 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
27336 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
27337 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
27338 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
27340 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
27342 C...Include threshold factor.
27343 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
27348 C*********************************************************************
27351 C...Auxiliary function for parametrization of CTEQ5M1.
27352 C...Author: J. Pumplin 9/99.
27354 FUNCTION PYCT5M(IFL,X,Q)
27356 C...Double precision declaration.
27357 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27358 IMPLICIT INTEGER(I-N)
27360 PARAMETER (NEX=8, NLF=2)
27361 DIMENSION AM(0:NEX,0:NLF,-5:2)
27362 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
27363 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
27364 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
27365 DIMENSION AF(0:NEX)
27367 DATA MEXVEC( 2) / 8 /
27368 DATA MLFVEC( 2) / 2 /
27369 DATA UT1VEC( 2) / 0.5141718E+01 /
27370 DATA UT2VEC( 2) / -0.1346944E+01 /
27371 DATA ALFVEC( 2) / 0.5260555E+00 /
27372 DATA QMAVEC( 2) / 0.0000000E+00 /
27373 DATA (AM( 0,K, 2),K=0, 2)
27374 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
27375 DATA (AM( 1,K, 2),K=0, 2)
27376 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
27377 DATA (AM( 2,K, 2),K=0, 2)
27378 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
27379 DATA (AM( 3,K, 2),K=0, 2)
27380 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
27381 DATA (AM( 4,K, 2),K=0, 2)
27382 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
27383 DATA (AM( 5,K, 2),K=0, 2)
27384 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
27385 DATA (AM( 6,K, 2),K=0, 2)
27386 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
27387 DATA (AM( 7,K, 2),K=0, 2)
27388 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
27389 DATA (AM( 8,K, 2),K=0, 2)
27390 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
27392 DATA MEXVEC( 1) / 8 /
27393 DATA MLFVEC( 1) / 2 /
27394 DATA UT1VEC( 1) / 0.4138426E+01 /
27395 DATA UT2VEC( 1) / -0.3221374E+01 /
27396 DATA ALFVEC( 1) / 0.4960962E+00 /
27397 DATA QMAVEC( 1) / 0.0000000E+00 /
27398 DATA (AM( 0,K, 1),K=0, 2)
27399 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
27400 DATA (AM( 1,K, 1),K=0, 2)
27401 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
27402 DATA (AM( 2,K, 1),K=0, 2)
27403 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
27404 DATA (AM( 3,K, 1),K=0, 2)
27405 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
27406 DATA (AM( 4,K, 1),K=0, 2)
27407 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
27408 DATA (AM( 5,K, 1),K=0, 2)
27409 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
27410 DATA (AM( 6,K, 1),K=0, 2)
27411 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
27412 DATA (AM( 7,K, 1),K=0, 2)
27413 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
27414 DATA (AM( 8,K, 1),K=0, 2)
27415 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
27417 DATA MEXVEC( 0) / 8 /
27418 DATA MLFVEC( 0) / 2 /
27419 DATA UT1VEC( 0) / -0.1026789E+01 /
27420 DATA UT2VEC( 0) / -0.9051707E+01 /
27421 DATA ALFVEC( 0) / 0.9462977E+00 /
27422 DATA QMAVEC( 0) / 0.0000000E+00 /
27423 DATA (AM( 0,K, 0),K=0, 2)
27424 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
27425 DATA (AM( 1,K, 0),K=0, 2)
27426 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
27427 DATA (AM( 2,K, 0),K=0, 2)
27428 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
27429 DATA (AM( 3,K, 0),K=0, 2)
27430 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
27431 DATA (AM( 4,K, 0),K=0, 2)
27432 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
27433 DATA (AM( 5,K, 0),K=0, 2)
27434 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
27435 DATA (AM( 6,K, 0),K=0, 2)
27436 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
27437 DATA (AM( 7,K, 0),K=0, 2)
27438 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
27439 DATA (AM( 8,K, 0),K=0, 2)
27440 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
27442 DATA MEXVEC(-1) / 8 /
27443 DATA MLFVEC(-1) / 2 /
27444 DATA UT1VEC(-1) / 0.5243571E+01 /
27445 DATA UT2VEC(-1) / -0.2870513E+01 /
27446 DATA ALFVEC(-1) / 0.6701448E+00 /
27447 DATA QMAVEC(-1) / 0.0000000E+00 /
27448 DATA (AM( 0,K,-1),K=0, 2)
27449 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
27450 DATA (AM( 1,K,-1),K=0, 2)
27451 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
27452 DATA (AM( 2,K,-1),K=0, 2)
27453 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
27454 DATA (AM( 3,K,-1),K=0, 2)
27455 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
27456 DATA (AM( 4,K,-1),K=0, 2)
27457 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
27458 DATA (AM( 5,K,-1),K=0, 2)
27459 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
27460 DATA (AM( 6,K,-1),K=0, 2)
27461 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
27462 DATA (AM( 7,K,-1),K=0, 2)
27463 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
27464 DATA (AM( 8,K,-1),K=0, 2)
27465 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
27467 DATA MEXVEC(-2) / 7 /
27468 DATA MLFVEC(-2) / 2 /
27469 DATA UT1VEC(-2) / 0.4782210E+01 /
27470 DATA UT2VEC(-2) / -0.1976856E+02 /
27471 DATA ALFVEC(-2) / 0.7558374E+00 /
27472 DATA QMAVEC(-2) / 0.0000000E+00 /
27473 DATA (AM( 0,K,-2),K=0, 2)
27474 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
27475 DATA (AM( 1,K,-2),K=0, 2)
27476 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
27477 DATA (AM( 2,K,-2),K=0, 2)
27478 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
27479 DATA (AM( 3,K,-2),K=0, 2)
27480 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
27481 DATA (AM( 4,K,-2),K=0, 2)
27482 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
27483 DATA (AM( 5,K,-2),K=0, 2)
27484 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
27485 DATA (AM( 6,K,-2),K=0, 2)
27486 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
27487 DATA (AM( 7,K,-2),K=0, 2)
27488 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
27490 DATA MEXVEC(-3) / 7 /
27491 DATA MLFVEC(-3) / 2 /
27492 DATA UT1VEC(-3) / 0.4518239E+01 /
27493 DATA UT2VEC(-3) / -0.2690590E+01 /
27494 DATA ALFVEC(-3) / 0.6124079E+00 /
27495 DATA QMAVEC(-3) / 0.0000000E+00 /
27496 DATA (AM( 0,K,-3),K=0, 2)
27497 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
27498 DATA (AM( 1,K,-3),K=0, 2)
27499 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
27500 DATA (AM( 2,K,-3),K=0, 2)
27501 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
27502 DATA (AM( 3,K,-3),K=0, 2)
27503 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
27504 DATA (AM( 4,K,-3),K=0, 2)
27505 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
27506 DATA (AM( 5,K,-3),K=0, 2)
27507 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
27508 DATA (AM( 6,K,-3),K=0, 2)
27509 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
27510 DATA (AM( 7,K,-3),K=0, 2)
27511 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
27513 DATA MEXVEC(-4) / 7 /
27514 DATA MLFVEC(-4) / 2 /
27515 DATA UT1VEC(-4) / 0.2783230E+01 /
27516 DATA UT2VEC(-4) / -0.1746328E+01 /
27517 DATA ALFVEC(-4) / 0.1115653E+01 /
27518 DATA QMAVEC(-4) / 0.1300000E+01 /
27519 DATA (AM( 0,K,-4),K=0, 2)
27520 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
27521 DATA (AM( 1,K,-4),K=0, 2)
27522 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
27523 DATA (AM( 2,K,-4),K=0, 2)
27524 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
27525 DATA (AM( 3,K,-4),K=0, 2)
27526 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
27527 DATA (AM( 4,K,-4),K=0, 2)
27528 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
27529 DATA (AM( 5,K,-4),K=0, 2)
27530 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
27531 DATA (AM( 6,K,-4),K=0, 2)
27532 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
27533 DATA (AM( 7,K,-4),K=0, 2)
27534 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
27536 DATA MEXVEC(-5) / 6 /
27537 DATA MLFVEC(-5) / 2 /
27538 DATA UT1VEC(-5) / 0.1619654E+02 /
27539 DATA UT2VEC(-5) / -0.3367346E+01 /
27540 DATA ALFVEC(-5) / 0.5109891E-02 /
27541 DATA QMAVEC(-5) / 0.4500000E+01 /
27542 DATA (AM( 0,K,-5),K=0, 2)
27543 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
27544 DATA (AM( 1,K,-5),K=0, 2)
27545 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
27546 DATA (AM( 2,K,-5),K=0, 2)
27547 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
27548 DATA (AM( 3,K,-5),K=0, 2)
27549 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
27550 DATA (AM( 4,K,-5),K=0, 2)
27551 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
27552 DATA (AM( 5,K,-5),K=0, 2)
27553 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
27554 DATA (AM( 6,K,-5),K=0, 2)
27555 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
27557 IF(Q .LE. QMAVEC(IFL)) THEN
27562 IF(X .GE. 1.D0) THEN
27567 TMP = LOG(Q/ALFVEC(IFL))
27568 IF(TMP .LE. 0.D0) THEN
27580 DO 100 K = 0, MLFVEC(IFL)
27581 AF(I) = AF(I) + SBX*AM(I,K,IFL)
27587 U = LOG(X/0.00001D0)
27589 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
27590 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
27591 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
27592 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
27593 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
27595 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
27597 C...Include threshold factor.
27598 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
27603 C*********************************************************************
27606 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
27607 C...a few older parametrizations, now obsolete but convenient for
27608 C...backwards checks.
27610 SUBROUTINE PYPDPO(X,Q2,XPPR)
27612 C...Double precision and integer declarations.
27613 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27614 IMPLICIT INTEGER(I-N)
27615 INTEGER PYK,PYCHGE,PYCOMP
27617 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27618 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27619 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27620 COMMON/PYINT1/MINT(400),VINT(400)
27621 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27622 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
27623 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
27626 C...The following data lines are coefficients needed in the
27627 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
27628 C...parametrizations, see below.
27629 C...Powers of 1-x in different cases.
27630 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
27631 C...Expansion coefficients for up valence quark distribution.
27632 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
27633 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
27634 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
27635 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
27636 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
27637 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
27638 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
27639 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
27640 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
27641 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
27642 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
27643 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
27644 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
27645 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
27646 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
27647 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
27648 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
27649 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
27650 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
27651 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
27652 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
27653 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
27654 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
27655 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
27656 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
27657 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
27658 C...Expansion coefficients for down valence quark distribution.
27659 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
27660 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
27661 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
27662 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
27663 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
27664 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
27665 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
27666 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
27667 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
27668 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
27669 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
27670 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
27671 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
27672 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
27673 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
27674 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
27675 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
27676 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
27677 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
27678 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
27679 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
27680 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
27681 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
27682 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
27683 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
27684 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
27685 C...Expansion coefficients for up and down sea quark distributions.
27686 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
27687 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
27688 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
27689 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
27690 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
27691 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
27692 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
27693 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
27694 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
27695 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
27696 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
27697 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
27698 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
27699 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
27700 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
27701 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
27702 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
27703 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
27704 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
27705 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
27706 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
27707 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
27708 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
27709 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
27710 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
27711 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
27712 C...Expansion coefficients for gluon distribution.
27713 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
27714 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
27715 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
27716 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
27717 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
27718 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
27719 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
27720 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
27721 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
27722 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
27723 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
27724 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
27725 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
27726 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
27727 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
27728 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
27729 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
27730 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
27731 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
27732 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
27733 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
27734 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
27735 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
27736 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
27737 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
27738 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
27739 C...Expansion coefficients for strange sea quark distribution.
27740 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
27741 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
27742 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
27743 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
27744 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
27745 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
27746 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
27747 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
27748 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
27749 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
27750 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
27751 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
27752 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
27753 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
27754 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
27755 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
27756 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
27757 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
27758 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
27759 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
27760 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
27761 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
27762 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
27763 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
27764 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
27765 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
27766 C...Expansion coefficients for charm sea quark distribution.
27767 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
27768 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
27769 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
27770 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
27771 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
27772 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
27773 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
27774 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
27775 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
27776 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
27777 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
27778 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
27779 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
27780 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
27781 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
27782 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
27783 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
27784 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
27785 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
27786 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
27787 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
27788 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
27789 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
27790 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
27791 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
27792 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
27793 C...Expansion coefficients for bottom sea quark distribution.
27794 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
27795 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
27796 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
27797 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
27798 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
27799 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
27800 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
27801 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
27802 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
27803 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
27804 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
27805 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
27806 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
27807 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
27808 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
27809 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
27810 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
27811 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
27812 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
27813 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
27814 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
27815 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
27816 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
27817 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
27818 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
27819 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
27820 C...Expansion coefficients for top sea quark distribution.
27821 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
27822 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
27823 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
27824 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
27825 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
27826 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
27827 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
27828 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
27829 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
27830 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
27831 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
27832 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
27833 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
27834 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
27835 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
27836 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
27837 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
27838 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
27839 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
27840 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
27841 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
27842 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
27843 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
27844 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
27845 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
27846 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
27848 C...The following data lines are coefficients needed in the
27849 C...Duke, Owens proton structure function parametrizations, see below.
27850 C...Expansion coefficients for (up+down) valence quark distribution.
27851 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
27852 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27853 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27854 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
27855 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
27856 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27857 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27858 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
27859 C...Expansion coefficients for down valence quark distribution.
27860 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
27861 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27862 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
27863 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
27864 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
27865 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27866 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
27867 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
27868 C...Expansion coefficients for (up+down+strange) sea quark distribution.
27869 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
27870 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27871 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
27872 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
27873 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
27874 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27875 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
27876 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
27877 C...Expansion coefficients for charm sea quark distribution.
27878 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
27879 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27880 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
27881 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
27882 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
27883 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27884 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
27885 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
27886 C...Expansion coefficients for gluon distribution.
27887 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
27888 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
27889 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
27890 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
27891 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
27892 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
27893 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
27894 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
27896 C...Euler's beta function, requires ordinary Gamma function
27897 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
27899 C...Leading order proton parton distributions from Gluck, Reya and Vogt.
27900 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
27902 IF(MSTP(51).EQ.11) THEN
27904 C...Determine s expansion variable and some x expressions.
27905 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
27906 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
27911 C...Evaluate valence, gluon and sea distributions.
27912 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
27913 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
27914 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
27915 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
27916 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
27917 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
27918 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
27919 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
27920 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
27921 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
27922 & SQRT(4.066D0*SD**1.218D0*XL)))*
27923 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
27924 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
27925 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
27926 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
27927 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
27928 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
27929 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
27930 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
27931 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
27932 IF(SD.LE.0.888D0) THEN
27935 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
27936 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
27937 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
27939 IF(SD.LE.1.351D0) THEN
27942 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
27943 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
27944 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
27947 C...Put into output array.
27949 XPPR(1)=XFVDD+XFSEA
27950 XPPR(2)=XFVUD-XFVDD+XFSEA
27960 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
27961 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
27962 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
27964 C...Determine set, Lambda and x and t expansion variables.
27966 IF(NSET.EQ.1) ALAM=0.2D0
27967 IF(NSET.EQ.2) ALAM=0.29D0
27968 TMIN=LOG(5D0/ALAM**2)
27969 TMAX=LOG(1D8/ALAM**2)
27970 T=LOG(MAX(1D0,Q2/ALAM**2))
27971 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
27973 IF(X.LE.0.1D0) NX=2
27974 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
27975 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
27977 C...Chebyshev polynomials for x and t expansion.
27980 TX(3)=2D0*VX**2-1D0
27981 TX(4)=4D0*VX**3-3D0*VX
27982 TX(5)=8D0*VX**4-8D0*VX**2+1D0
27983 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
27986 TT(3)=2D0*VT**2-1D0
27987 TT(4)=4D0*VT**3-3D0*VT
27988 TT(5)=8D0*VT**4-8D0*VT**2+1D0
27989 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
27991 C...Calculate structure functions.
27996 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
27999 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
28002 C...Put into output array.
28004 XPPR(1)=XQ(2)+XQ(3)
28005 XPPR(2)=XQ(1)+XQ(3)
28013 C...Special expansion for bottom (threshold effects).
28014 IF(MSTP(58).GE.5) THEN
28015 IF(NSET.EQ.1) TMIN=8.1905D0
28016 IF(NSET.EQ.2) TMIN=7.4474D0
28018 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
28021 TT(3)=2D0*VT**2-1D0
28022 TT(4)=4D0*VT**3-3D0*VT
28023 TT(5)=8D0*VT**4-8D0*VT**2+1D0
28024 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
28028 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
28031 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
28036 C...Special expansion for top (threshold effects).
28037 IF(MSTP(58).GE.6) THEN
28038 IF(NSET.EQ.1) TMIN=11.5528D0
28039 IF(NSET.EQ.2) TMIN=10.8097D0
28040 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
28041 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
28043 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
28046 TT(3)=2D0*VT**2-1D0
28047 TT(4)=4D0*VT**3-3D0*VT
28048 TT(5)=8D0*VT**4-8D0*VT**2+1D0
28049 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
28053 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
28056 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
28061 C...Proton parton distributions from Duke, Owens.
28062 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
28063 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
28065 C...Determine set, Lambda and s expansion parameter.
28067 IF(NSET.EQ.1) ALAM=0.2D0
28068 IF(NSET.EQ.2) ALAM=0.4D0
28069 Q2IN=MIN(1D6,MAX(4D0,Q2))
28070 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
28072 C...Calculate structure functions.
28075 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
28076 & CDO(3,IS,KFL,NSET)*SD**2
28079 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
28080 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
28082 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
28083 & TS(5)*X**2+TS(6)*X**3)
28087 C...Put into output arrays.
28089 XPPR(1)=XQ(2)+XQ(3)/6D0
28090 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
28103 C*********************************************************************
28106 C...Gives threshold attractive/repulsive factor for heavy flavour
28109 FUNCTION PYHFTH(SH,SQM,FRATT)
28111 C...Double precision and integer declarations.
28112 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28113 IMPLICIT INTEGER(I-N)
28114 INTEGER PYK,PYCHGE,PYCOMP
28116 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28117 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28118 COMMON/PYINT1/MINT(400),VINT(400)
28119 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28121 C...Value for alpha_strong.
28122 IF(MSTP(35).LE.1) THEN
28127 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
28133 C...Evaluate attractive and repulsive factors.
28134 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
28135 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
28136 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
28137 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
28138 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
28144 C*********************************************************************
28147 C...Splits a hadron remnant into two (partons or hadron + parton)
28148 C...in case it is more complicated than just a quark or a diquark.
28150 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
28152 C...Double precision and integer declarations.
28153 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28154 IMPLICIT INTEGER(I-N)
28155 INTEGER PYK,PYCHGE,PYCOMP
28156 C...Commonblocks. PYDAT1 temporary
28157 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28158 COMMON/PYINT1/MINT(400),VINT(400)
28159 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28160 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
28164 C...Preliminaries. Parton composition.
28167 KFL(1)=MOD(KFA/1000,10)
28168 KFL(2)=MOD(KFA/100,10)
28169 KFL(3)=MOD(KFA/10,10)
28170 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
28171 KFL(2)=INT(1.5D0+PYR(0))
28172 IF(MINT(105).EQ.333) KFL(2)=3
28173 IF(MINT(105).EQ.443) KFL(2)=4
28175 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
28178 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
28182 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
28189 C...Subdivide lepton.
28190 IF(KFA.GE.11.AND.KFA.LE.18) THEN
28191 IF(KFLR.EQ.KFA) THEN
28193 ELSEIF(KFLR.EQ.22) THEN
28195 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
28197 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
28199 ELSEIF(KFLR.EQ.21) THEN
28207 C...Subdivide photon.
28208 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
28209 IF(KFLR.NE.21) THEN
28214 IF(RAGR.GT.0.125D0) KFLSP=2
28215 IF(RAGR.GT.0.625D0) KFLSP=3
28216 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
28220 C...Subdivide Reggeon or Pomeron.
28221 ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
28222 IF(KFLIN.EQ.21) THEN
28228 C...Subdivide meson.
28229 ELSEIF(KFL(1).EQ.0) THEN
28230 KFL(2)=KFL(2)*(-1)**KFL(2)
28231 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
28232 IF(KFLR.EQ.KFL(2)) THEN
28234 ELSEIF(KFLR.EQ.KFL(3)) THEN
28236 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
28239 ELSEIF(KFLR.EQ.21) THEN
28242 ELSEIF(KFLR*KFL(2).GT.0) THEN
28245 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
28246 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
28248 ELSEIF(KFLCH.EQ.0) THEN
28249 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
28257 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
28258 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
28260 ELSEIF(KFLCH.EQ.0) THEN
28261 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
28268 C...Subdivide baryon.
28272 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
28275 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
28278 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
28279 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
28282 IAGR=1.00001D0+2.99998D0*PYR(0)
28285 IF(IAGR.EQ.1) ID1=2
28286 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
28289 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
28290 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
28291 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
28292 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
28293 ELSEIF(MOD(KFA,10).EQ.2) THEN
28294 IF(IAGR.EQ.1) KSP=1
28295 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
28297 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
28298 IF(KFLR.EQ.21) THEN
28300 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
28303 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
28304 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
28306 ELSEIF(KFLCH.EQ.0) THEN
28307 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
28311 ELSEIF(NAGR.EQ.0) THEN
28314 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
28315 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
28317 ELSEIF(KFLCH.EQ.0) THEN
28318 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
28326 C...Add on correct sign for result.
28333 C*********************************************************************
28336 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
28337 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
28338 C...(Dover, 1965) 6.1.36.
28342 C...Double precision and integer declarations.
28343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28344 IMPLICIT INTEGER(I-N)
28345 INTEGER PYK,PYCHGE,PYCOMP
28346 C...Local array and data.
28348 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
28349 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
28358 PYGAMM=PYGAMM+B(I)*DXP
28364 PYGAMM=(X-IX)*PYGAMM
28371 C***********************************************************************
28374 C...Calculates real and imaginary parts of the auxiliary functions W1
28375 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
28376 C...der Bij, Nucl. Phys. B297 (1988) 221.
28378 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
28380 C...Double precision and integer declarations.
28381 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28382 IMPLICIT INTEGER(I-N)
28383 INTEGER PYK,PYCHGE,PYCOMP
28385 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28388 ASINH(X)=LOG(X+SQRT(X**2+1D0))
28389 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
28391 IF(EPS.LT.0D0) THEN
28392 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
28393 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
28395 ELSEIF(EPS.LT.1D0) THEN
28396 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
28397 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
28398 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
28399 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
28401 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
28402 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
28409 C***********************************************************************
28412 C...Calculates real and imaginary parts of the auxiliary function I3;
28413 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
28414 C...Nucl. Phys. B297 (1988) 221.
28416 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
28418 C...Double precision and integer declarations.
28419 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28420 IMPLICIT INTEGER(I-N)
28421 INTEGER PYK,PYCHGE,PYCOMP
28423 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28426 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
28427 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
28429 IF(EPS.LT.0D0) THEN
28430 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
28431 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
28432 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
28433 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
28434 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
28435 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
28436 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
28437 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
28439 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
28440 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
28441 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
28442 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
28443 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
28444 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
28445 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
28446 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
28447 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
28448 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
28449 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
28450 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
28451 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
28452 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
28453 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
28454 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
28456 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
28457 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
28458 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
28459 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
28460 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
28463 ELSEIF(EPS.LT.1D0) THEN
28464 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
28465 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
28466 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
28467 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
28468 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
28469 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
28470 & (0.25D0*(RAT+1D0)*EPS))
28471 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
28472 & (0.25D0*(RAT+1D0)*EPS))
28473 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
28474 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
28475 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
28476 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
28477 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
28478 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
28479 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
28480 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
28481 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
28482 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
28483 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
28484 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
28485 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
28486 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
28487 & (1D0+0.25D0*RAT*EPS-GA))
28488 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
28489 & (1D0+0.25D0*RAT*EPS-GA))
28491 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
28492 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
28493 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
28494 & LOG((GA+BE-1D0)/(BE-GA))
28495 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
28498 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
28499 RCTHE=RSQ*(1D0-2D0*BE/EPS)
28500 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
28501 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
28502 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
28504 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
28505 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
28506 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
28507 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
28508 & (PHI-THE)*(PHI+THE-PARU(1))
28509 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
28510 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
28513 Y3RE=2D0/(2D0*BE-1D0)*F3RE
28514 Y3IM=2D0/(2D0*BE-1D0)*F3IM
28519 C***********************************************************************
28522 C...Calculates real and imaginary part of Spence function; see
28523 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
28525 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
28527 C...Double precision and integer declarations.
28528 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28529 IMPLICIT INTEGER(I-N)
28530 INTEGER PYK,PYCHGE,PYCOMP
28532 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28534 C...Local array and data.
28537 &1.000000D+00, -5.000000D-01, 1.666667D-01,
28538 &0.000000D+00, -3.333333D-02, 0.000000D+00,
28539 &2.380952D-02, 0.000000D+00, -3.333333D-02,
28540 &0.000000D+00, 7.575757D-02, 0.000000D+00,
28541 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
28545 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
28546 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
28547 IF(IREIM.EQ.2) PYSPEN=0D0
28551 XMOD=SQRT(XRE**2+XIM**2)
28552 IF(XMOD.LT.1D-6) THEN
28553 IF(IREIM.EQ.1) PYSPEN=0D0
28554 IF(IREIM.EQ.2) PYSPEN=0D0
28558 XARG=SIGN(ACOS(XRE/XMOD),XIM)
28562 IF(XMOD.GT.1D0) THEN
28564 ALGXIM=XARG-SIGN(PARU(1),XARG)
28565 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
28566 SP0IM=-ALGXRE*ALGXIM
28573 IF(XRE.GT.0.5D0) THEN
28578 XMOD=SQRT(XRE**2+XIM**2)
28579 XARG=SIGN(ACOS(XRE/XMOD),XIM)
28582 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
28583 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
28589 XMOD=SQRT(XRE**2+XIM**2)
28590 XARG=SIGN(ACOS(XRE/XMOD),XIM)
28599 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
28600 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
28601 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
28604 SPRE=SPRE+B(I)*TERMRE
28605 SPIM=SPIM+B(I)*TERMIM
28608 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
28609 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
28614 C***********************************************************************
28617 C...Calculates the matrix element for the processes
28618 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
28619 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
28620 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
28622 SUBROUTINE PYQQBH(WTQQBH)
28624 C...Double precision and integer declarations.
28625 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28626 IMPLICIT INTEGER(I-N)
28627 INTEGER PYK,PYCHGE,PYCOMP
28629 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28630 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28631 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28632 COMMON/PYINT1/MINT(400),VINT(400)
28633 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28634 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
28635 C...Local arrays and function.
28636 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
28637 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
28640 C...Mass parameters.
28643 SHPR=SQRT(VINT(26))*VINT(1)
28644 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
28645 PH=SQRT(VINT(21))*VINT(1)
28649 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
28651 PT=SQRT(MAX(0D0,VINT(197+5*I)))
28652 PP(I,1)=PT*COS(VINT(198+5*I))
28653 PP(I,2)=PT*SIN(VINT(198+5*I))
28655 PP(3,1)=-PP(1,1)-PP(2,1)
28656 PP(3,2)=-PP(1,2)-PP(2,2)
28657 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
28658 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
28659 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
28661 PP(3,3)=PMT3*SINH(VINT(211))
28662 PP(3,4)=PMT3*COSH(VINT(211))
28663 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
28664 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
28665 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
28666 PP(2,3)=-PP(1,3)-PP(3,3)
28667 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
28668 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
28670 C...Set up incoming kinematics and derived momentum combinations.
28674 PP(I,3)=-0.5D0*SHPR*(-1)**I
28675 PP(I,4)=-0.5D0*SHPR
28678 PP(6,J)=PP(1,J)+PP(2,J)
28679 PP(7,J)=PP(1,J)+PP(3,J)
28680 PP(8,J)=PP(1,J)+PP(4,J)
28681 PP(9,J)=PP(1,J)+PP(5,J)
28682 PP(10,J)=-PP(2,J)-PP(3,J)
28683 PP(11,J)=-PP(2,J)-PP(4,J)
28684 PP(12,J)=-PP(2,J)-PP(5,J)
28685 PP(13,J)=-PP(4,J)-PP(5,J)
28688 C...Derived kinematics invariants.
28717 C...Define colour coefficients for g + g -> Q + Qbar + H.
28718 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
28722 CLR(I+3,J+3)=16D0/3D0
28723 CLR(I,J+3)=-2D0/3D0
28724 CLR(I+3,J)=-2D0/3D0
28737 CLR(6+K1,6+K2)=12D0
28741 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
28742 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
28743 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
28744 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
28745 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
28746 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
28747 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
28749 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
28750 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
28751 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
28752 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
28753 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
28754 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
28755 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
28756 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
28757 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
28758 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
28759 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
28760 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
28761 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
28762 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
28763 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
28764 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
28765 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
28766 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
28768 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
28769 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
28770 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
28771 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
28772 & +X4*X9*X5+X4*X5**2)
28773 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
28774 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
28775 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
28776 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
28777 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
28778 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
28779 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
28780 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
28781 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
28782 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
28783 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
28784 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
28785 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
28786 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
28787 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
28788 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
28789 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
28790 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
28791 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
28792 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
28794 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
28795 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
28796 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
28797 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
28798 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
28799 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
28800 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
28802 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
28803 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
28804 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
28805 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
28806 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
28807 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
28809 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
28810 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
28811 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
28812 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
28813 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
28814 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
28815 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
28817 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
28818 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
28819 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
28820 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
28821 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
28822 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
28823 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
28824 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
28825 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
28826 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
28827 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
28828 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
28829 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
28830 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
28831 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
28832 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
28833 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
28834 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
28835 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
28836 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
28837 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
28838 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
28839 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
28840 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
28841 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
28842 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
28843 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
28844 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
28845 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
28846 & +X3*X8*X5+X3*X5**2)
28847 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
28848 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
28849 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
28850 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
28851 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
28852 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
28853 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
28855 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
28856 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
28857 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
28858 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
28859 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
28860 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
28861 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
28862 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
28863 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
28864 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
28865 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
28866 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
28867 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
28868 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
28869 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
28870 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
28871 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
28872 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
28873 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
28874 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
28875 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
28876 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
28877 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
28878 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
28879 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
28880 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
28882 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
28883 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
28884 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
28885 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
28886 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
28887 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
28888 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
28889 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
28890 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
28891 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
28892 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
28893 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
28894 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
28895 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
28896 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
28897 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
28898 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
28899 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
28900 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
28901 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
28902 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
28903 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
28904 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
28905 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
28906 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
28907 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
28909 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
28910 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
28911 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
28912 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
28913 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
28914 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
28915 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
28916 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
28917 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
28918 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
28919 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
28920 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
28921 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
28922 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
28923 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
28924 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
28925 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
28926 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
28927 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
28928 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
28929 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
28930 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
28931 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
28932 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
28933 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
28934 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
28935 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
28936 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
28937 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
28938 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
28939 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
28940 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
28941 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
28942 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
28943 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
28944 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
28945 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
28946 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
28947 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
28948 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
28949 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
28950 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
28951 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
28952 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
28954 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
28955 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
28956 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
28957 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
28958 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
28959 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
28960 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
28961 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
28962 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
28963 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
28964 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
28966 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
28967 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
28968 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
28969 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
28970 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
28971 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
28973 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
28974 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
28975 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
28977 FM(9,10)=0.5D0*(FMXX+FM(9,10))
28978 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
28979 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
28980 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
28982 C...Repackage matrix elements.
28988 RM(7,7)=FM(7,7)-2D0*FM(9,9)
28989 RM(7,8)=FM(7,8)-2D0*FM(9,10)
28990 RM(8,8)=FM(8,8)-2D0*FM(10,10)
28992 C...Produce final result: matrix elements * colours * propagators.
28997 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
29000 WTQQBH=-WTQQBH/256D0
29003 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
29004 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
29005 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
29007 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
29008 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
29009 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
29011 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
29012 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
29015 C...Produce final result: matrix elements * propagators.
29017 A12=A12/(DX(7)*DX(8))
29019 WTQQBH=-(A11+A22+2D0*A12)/8D0
29025 C*********************************************************************
29028 C...Initializes supersymmetry: finds sparticle masses and
29029 C...branching ratios and stores this information.
29030 C...AUTHOR: STEPHEN MRENNA
29034 C...Double precision and integer declarations.
29035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29036 IMPLICIT INTEGER(I-N)
29037 INTEGER PYK,PYCHGE,PYCOMP
29038 C...Parameter statement to help give large particle numbers.
29039 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29041 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29042 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29043 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
29044 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29045 COMMON/PYINT4/MWID(500),WIDS(500,5)
29046 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29047 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29049 COMMON/PYHTRI/HHH(7)
29050 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
29053 C...Local variables.
29055 DOUBLE PRECISION ALFA,BETA
29056 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
29057 DOUBLE PRECISION PYALEM
29058 INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
29059 INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
29060 DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
29061 DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
29062 1 DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
29063 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
29064 DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
29065 DOUBLE PRECISION DELM,XMDIF,BRLIM
29066 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
29067 DOUBLE PRECISION ARG,SGNMU,R,GAM
29068 INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
29069 INTEGER IMSSM,KFHIGG
29071 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
29072 SAVE INIT,MWIDSU,MDCYSU
29074 &1000001,2000001,1000002,2000002,1000003,2000003,
29075 &1000004,2000004,1000005,2000005,1000006,2000006,
29076 &1000011,2000011,1000012,2000012,1000013,2000013,
29077 &1000014,2000014,1000015,2000015,1000016,2000016,
29078 &1000021,1000022,1000023,1000025,1000035,1000024,
29079 &1000037,1000039, 25, 35, 36, 37/
29082 C...Do nothing if SUSY not requested.
29084 IF(IMSSM.EQ.0) RETURN
29086 C...Save copy of MWID(KC) and MDCY(KC,1) values before
29087 C...they are set to zero for the LSP.
29094 MDCYSU(I)=MDCY(KC,1)
29098 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
29102 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
29104 MDCY(KC,1)=MDCYSU(I)
29108 C...First part of routine: set masses and couplings.
29110 C...Reset mixing values in sfermion sector to pure left/right.
29118 C...Common couplings.
29123 COS2B=COS(2D0*BETA)
29129 C...Define sparticle masses for a general MSSM simulation.
29130 IF(IMSSM.EQ.1) THEN
29131 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
29133 KC=PYCOMP(KSUSY1+I)
29134 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
29135 KC=PYCOMP(KSUSY2+I)
29136 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
29137 KC=PYCOMP(KSUSY1+I+1)
29138 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
29139 KC=PYCOMP(KSUSY2+I+1)
29140 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
29142 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
29143 IF(XARG.LT.0D0) THEN
29144 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
29145 & ' FROM THE SUM RULE. '
29146 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29152 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
29153 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
29154 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
29155 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
29157 IF(IMSS(8).EQ.1) THEN
29162 C...Alternatively derive masses from SUGRA relations.
29163 ELSEIF(IMSSM.EQ.2) THEN
29167 C...Add in extra D-term contributions.
29168 IF(IMSS(7).EQ.1) THEN
29173 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29174 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
29175 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
29176 WRITE(MSTU(11),*) 'C DX = ',DX
29177 WRITE(MSTU(11),*) 'C DY = ',DY
29178 WRITE(MSTU(11),*) 'C DS = ',DS
29179 WRITE(MSTU(11),*) 'C '
29180 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
29181 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
29182 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29183 DQ2=DY/6D0-DX/3D0-DS/3D0
29184 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
29185 DD2=DY/3D0+DX-2D0*DS/3D0
29186 DL2=-DY/2D0+DX-2D0*DS/3D0
29187 DE2=DY-DX/3D0-DS/3D0
29188 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
29189 DHD2=-DY/2D0-2D0*DX/3D0+DS
29190 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
29192 DMA2 = 2D0*DMU2+DHU2+DHD2
29194 KC=PYCOMP(KSUSY1+I)
29195 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
29196 KC=PYCOMP(KSUSY2+I)
29197 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
29198 KC=PYCOMP(KSUSY1+I+1)
29199 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
29200 KC=PYCOMP(KSUSY2+I+1)
29201 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
29204 KC=PYCOMP(KSUSY1+I)
29205 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
29206 KC=PYCOMP(KSUSY2+I)
29207 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
29208 KC=PYCOMP(KSUSY1+I+1)
29209 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
29211 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
29212 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
29215 SGNMU=SIGN(1D0,RMSS(4))
29216 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
29217 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
29218 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
29219 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
29220 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
29221 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
29222 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
29223 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
29224 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
29225 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
29226 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
29227 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
29228 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
29231 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
29232 RMSS(6)=SQRT(RMSS(6)**2+DL2)
29233 RMSS(7)=SQRT(RMSS(7)**2+DE2)
29234 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
29235 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
29236 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
29237 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
29238 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
29241 C...Fix the third generation sfermions.
29243 XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
29244 IF(XARG.LT.0D0) THEN
29245 WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
29246 & ' THE SUM RULE. '
29247 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29250 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
29253 C...Fix the neutralino--chargino--gluino sector.
29256 C...Fix the Higgs sector.
29259 C...Choose the Gunion-Haber convention.
29263 C...Print information on mass parameters.
29264 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
29265 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29266 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
29267 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
29268 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
29269 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
29270 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
29271 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
29272 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
29273 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
29274 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29276 IF(IMSS(20).EQ.1) THEN
29277 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29278 WRITE(MSTU(11),*) ' DEBUG MODE '
29279 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
29280 & UMIX(2,1),UMIX(2,2)
29281 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
29282 & VMIX(2,1),VMIX(2,2)
29283 WRITE(MSTU(11),*) ' ZMIX = ',ZMIX
29284 WRITE(MSTU(11),*) ' ALFA = ',ALFA
29285 WRITE(MSTU(11),*) ' BETA = ',BETA
29286 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
29287 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
29288 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29291 C...Set up the Higgs couplings - needed here since initialization
29292 C...in PYINRE did not yet occur when PYWIDT is called below.
29305 C2B=COSB**2-SINB**2
29306 C...tanb (used for H+)
29310 C...Coupling to d-type quarks
29311 PARU(161)=SINA/COSB
29312 C...Coupling to u-type quarks
29313 PARU(162)=-COSA/SINB
29314 C...Coupling to leptons
29315 PARU(163)=PARU(161)
29319 PARU(165)=PARU(164)
29322 C...Coupling to d-type quarks
29323 PARU(171)=-COSA/COSB
29324 C...Coupling to u-type quarks
29325 PARU(172)=-SINA/SINB
29326 C...Coupling to leptons
29327 PARU(173)=PARU(171)
29331 PARU(175)=PARU(174)
29333 C PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
29334 HHH(3)=HHH(3)+HHH(4)+HHH(5)
29335 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
29336 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
29337 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
29338 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
29341 C PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
29342 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
29343 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
29344 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
29345 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
29347 C PARU(177)=COS(2D0*BE)*COS(BE+AL)
29348 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
29349 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
29350 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
29351 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
29353 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
29355 C...Coupling to d-type quarks
29357 C...Coupling to u-type quarks
29358 PARU(182)=1D0/PARU(181)
29359 C...Coupling to leptons
29360 PARU(183)=PARU(181)
29363 C...Coupling to Z h
29364 PARU(186)=COS(BE-AL)
29365 C...Coupling to Z H
29366 PARU(187)=SIN(BE-AL)
29372 C...Coupling to W h
29373 PARU(195)=COS(BE-AL)
29375 C...Tell that all Higgs couplings have been set.
29378 C...Second part of routine: set decay modes and branching ratios.
29380 C...Allow chi10 -> gravitino + gamma or not.
29381 KC=PYCOMP(KSUSY1+39)
29382 IF( IMSS(11) .NE. 0 ) THEN
29383 PMAS(KC,1)=RMSS(21)/1000000000D0
29384 PMAS(KC,2)=0.0001D0
29386 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
29392 C...Loop over sparticle and Higgs species.
29393 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
29394 C...Find the LSP or NLSP for a gravitino LSP
29399 IF(KF.EQ.1000039) GOTO 150
29401 IF(PMAS(KC,1).LT.PMLSP) THEN
29411 C...Sfermion decays.
29413 C...First check to see if sneutrino is lighter than chi10.
29414 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
29415 & PMAS(KC,1).LT.PMCHI1) THEN
29417 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
29421 ELSEIF(I.EQ.25) THEN
29422 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
29423 IF(I.EQ.ILSP) LKNT=0
29425 C...Neutralino decays.
29426 ELSEIF(I.GE.26.AND.I.LE.29) THEN
29427 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
29428 C...chi10 stable or chi10 -> gravitino + gamma.
29429 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
29435 C...Chargino decays.
29436 ELSEIF(I.GE.30.AND.I.LE.31) THEN
29437 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
29439 C...Gravitino is stable.
29440 ELSEIF(I.EQ.32) THEN
29445 ELSEIF(I.GE.33.AND.I.LE.36) THEN
29446 C...Calculate decays to non-SUSY particles.
29447 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
29452 DO 180 I1=1,MDCY(KC,3)
29454 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
29455 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 180
29457 XLAM(0)=XLAM(0)+XLAM(I1)
29459 IDLAM(I1,J1)=KFDP(K1,J1)
29463 C...Add the decays to SUSY particles.
29464 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
29466 C...Zero the branching ratios for use in loop mode
29467 C...thanks to K. Matchev (FNAL)
29468 DO 185 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
29472 C...Set stable particles.
29480 C...Store branching ratios in the standard tables.
29482 IDC=MDCY(KC,2)+MDCY(KC,3)-1
29488 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
29489 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
29490 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
29491 BRAT(IDC)=XLAM(IL)/XLAM(0)
29493 IF(MDME(IDC,1).GE.1) THEN
29494 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
29495 & PMAS(PYCOMP(KFDP(IDC,2)),1)
29496 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
29497 & PMAS(PYCOMP(KFDP(IDC,3)),1)
29500 IF(XMDIF.GE.0D0) THEN
29501 DELM=MIN(DELM,XMDIF)
29503 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
29504 WRITE(MSTU(11),*) ' KF = ',KF
29505 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
29509 ELSEIF(IDC.EQ.IDCSV) THEN
29510 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
29511 & 'channel not recognized:'
29512 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
29519 C...Store width, cutoff and lifetime.
29521 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
29522 PMAS(KC,3)=PMAS(KC,2)*10D0
29524 PMAS(KC,3)=0.95D0*DELM
29526 IF(PMAS(KC,2).NE.0D0) THEN
29527 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
29535 C*********************************************************************
29538 C...Uses approximate analytical formulae to determine the full set of
29539 C...MSSM parameters from SUGRA input.
29540 C...See M. Drees and S.P. Martin, hep-ph/9504124
29544 C...Double precision and integer declarations.
29545 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29546 IMPLICIT INTEGER(I-N)
29547 INTEGER PYK,PYCHGE,PYCOMP
29548 C...Parameter statement to help give large particle numbers.
29549 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29551 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29552 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29553 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29554 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
29571 SINB=TANB/SQRT(TANB**2+1D0)
29574 DTERM=XMZ2*COS(2D0*BETA)
29575 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
29576 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
29579 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
29580 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
29581 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
29582 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
29584 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
29585 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
29586 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
29587 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
29589 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
29590 IF(XARG.LT.0D0) THEN
29591 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
29592 & ' FROM THE SUM RULE. '
29593 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29599 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
29600 PMAS(PYCOMP(KSUSY2+I),1)=XMER
29601 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
29602 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
29607 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
29608 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
29610 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
29611 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
29612 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
29613 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
29616 C XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
29618 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
29619 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
29620 C XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
29622 XMA2=2D0*(XM02+.52D0*XMG2)-XTOP-XBOT-XTAU/3D0+2D0*XMU2
29623 XMU=SIGN(SQRT(XMU2),RMSS(4))
29625 RMSS(19)=SQRT(XMA2)
29626 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
29627 IF(ARG.GT.0D0) THEN
29630 WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
29633 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
29634 IF(ARG.GT.0D0) THEN
29637 WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
29640 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
29641 IF(ARG.GT.0D0) THEN
29644 RMSS(10)=-SQRT(-ARG)
29646 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
29647 IF(ARG.GT.0D0) THEN
29650 RMSS(12)=-SQRT(-ARG)
29652 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
29653 IF(ARG.GT.0D0) THEN
29656 RMSS(11)=-SQRT(-ARG)
29662 C*********************************************************************
29665 C...Determines the running mass of quarks.
29667 FUNCTION PYRNMQ(ID,DTERM)
29669 C...Double precision and integer declarations.
29670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29671 IMPLICIT INTEGER(I-N)
29672 INTEGER PYK,PYCHGE,PYCOMP
29674 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29677 C...Local variables.
29678 DOUBLE PRECISION PI,R
29679 DOUBLE PRECISION TOL
29680 DOUBLE PRECISION CI(3)
29682 DOUBLE PRECISION PYALPS
29684 DATA PI,R/3.141592654D0,.61803399D0/
29685 DATA CI/0.47D0,0.07D0,0.02D0/
29689 AG=(0.71D0)**2/4D0/PI
29696 AS=PYALPS(XM02+6D0*XMG2)
29697 CG=8D0/9D0*((AS/AG)**2-1D0)
29698 BX=XM02+(CA+CG)*XMG2+DTERM
29699 AX=MIN(50D0**2,0.5D0*BX)
29700 CX=MAX(2000D0**2,2D0*BX)
29704 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
29712 CG=8D0/9D0*((AS1/AG)**2-1D0)
29713 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
29715 CG=8D0/9D0*((AS2/AG)**2-1D0)
29716 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
29717 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
29724 CG=8D0/9D0*((AS2/AG)**2-1D0)
29725 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
29732 CG=8D0/9D0*((AS1/AG)**2-1D0)
29733 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
29748 C*********************************************************************
29751 C...Determines the running mass of the top quark.
29753 FUNCTION PYRNMT(XMT)
29755 C...Double precision and integer declarations.
29756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29757 IMPLICIT INTEGER(I-N)
29758 INTEGER PYK,PYCHGE,PYCOMP
29760 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29763 C...Local variables.
29764 DOUBLE PRECISION XMT
29765 DOUBLE PRECISION PI,R
29766 DOUBLE PRECISION TOL
29768 DOUBLE PRECISION PYALPS
29770 DATA PI,R/3.141592654D0,0.61803399D0/
29775 AX=MIN(50D0,BX*0.5D0)
29776 CX=MAX(300D0,2D0*BX)
29780 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
29787 AS1=PYALPS(X1**2)/PI
29788 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
29789 AS2=PYALPS(X2**2)/PI
29790 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
29791 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
29797 AS2=PYALPS(X2**2)/PI
29798 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
29804 AS1=PYALPS(X1**2)/PI
29805 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
29820 C*********************************************************************
29823 C...Calculates the mass eigenstates of the third generation sfermions.
29824 C...Created: 5-31-96
29828 C...Double precision and integer declarations.
29829 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29830 IMPLICIT INTEGER(I-N)
29831 INTEGER PYK,PYCHGE,PYCOMP
29832 C...Parameter statement to help give large particle numbers.
29833 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29835 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29836 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29837 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29838 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29840 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
29842 C...Local variables.
29843 DOUBLE PRECISION BETA
29844 DOUBLE PRECISION PYRNMT
29845 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
29846 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
29847 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
29848 DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
29849 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
29850 INTEGER IF,I,J,II,JJ,IT,L
29864 COS2B=COS(2D0*BETA)
29866 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
29876 XMQL2=CTT2*XM12+STT2*XM22
29877 XMQR2=STT2*XM12+CTT2*XM22
29879 XMF2=PYRNMT(XMFR)**2
29880 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29881 ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
29882 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
29883 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
29885 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29888 C......SUBTRACT OUT D-TERM AND FERMION MASS
29889 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
29890 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
29891 IF(XMQL2.GE.0D0) THEN
29892 RMSS(10)=SQRT(XMQL2)
29894 RMSS(10)=-SQRT(-XMQL2)
29896 IF(XMQR2.GE.0D0) THEN
29897 RMSS(12)=SQRT(XMQR2)
29899 RMSS(12)=-SQRT(-XMQR2)
29901 C SAME FOR BOTTOM SQUARK
29905 STT=MAX(SQRT(STT2),1D-6)
29909 XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
29910 IF(ABS(CTT).EQ.1D0) THEN
29914 ELSEIF(CTT.EQ.0D0) THEN
29918 XM22=(XMQL2-CTT2*XM12)/STT2
29919 XMQR2=STT2*XM12+CTT2*XM22
29921 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29922 ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
29923 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
29924 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
29926 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29929 C......SUBTRACT OUT D-TERM AND FERMION MASS
29930 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
29931 IF(XMQR2.GE.0D0) THEN
29932 RMSS(11)=SQRT(XMQR2)
29934 RMSS(11)=-SQRT(-XMQR2)
29936 C SAME FOR TAU SLEPTON
29943 XMQL2=CTT2*XM12+STT2*XM22
29944 XMQR2=STT2*XM12+CTT2*XM22
29947 ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29948 ATMT=SQRT(XMF2)*(ATAU+XMU*TANB)
29949 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
29950 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
29952 ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29955 C......SUBTRACT OUT D-TERM AND FERMION MASS
29956 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
29957 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
29958 IF(XMQL2.GE.0D0) THEN
29959 RMSS(13)=SQRT(XMQL2)
29961 RMSS(13)=-SQRT(-XMQL2)
29963 IF(XMQR2.GE.0D0) THEN
29964 RMSS(14)=SQRT(XMQR2)
29966 RMSS(14)=-SQRT(-XMQR2)
29971 IF(AMQL.LT.0D0) THEN
29979 IF(L.EQ.2) XMF=PYRNMT(XMF)
29983 IF(AMQR.LT.0D0) THEN
29988 AM2(1,1)=XMQL2+XMF2
29989 AM2(2,2)=XMQR2+XMF2
29992 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
29993 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
29994 AM2(1,2)=XMF*(ATR+XMU*TANB)
29995 ELSEIF(L.EQ.2) THEN
29996 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
29997 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
29998 AM2(1,2)=XMF*(ATR+XMU/TANB)
29999 ELSEIF(L.EQ.3) THEN
30000 IF(IMSS(8).EQ.1) THEN
30001 AM2(1,1)=RMSS(6)**2
30002 AM2(2,2)=RMSS(7)**2
30007 AM2(1,2)=XMF*(ATR+XMU*TANB)
30012 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
30013 IF(DETM.LT.0D0) THEN
30014 WRITE(MSTU(11),*) ID1(L),DETM
30015 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION ')
30017 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
30018 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
30022 IF(XMF22-XMF12.GT.0D0) THEN
30023 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
30025 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
30026 & AM2(1,2)/(XMF22-XMF12))
30042 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
30048 IF(DI(1,1).GT.DI(2,2)) THEN
30049 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
30050 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
30051 WRITE(MSTU(11),*) AM2
30052 WRITE(MSTU(11),*) DI
30053 WRITE(MSTU(11),*) RT
30064 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
30065 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
30066 & ' OFF DIAGONAL ELEMENTS '
30067 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
30068 WRITE(MSTU(11),*) DI
30069 WRITE(MSTU(11),*) ' ROTATION = ',RT
30071 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
30072 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
30073 & ' NEGATIVE MASSES '
30076 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
30077 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
30078 SFMIX(IF,1)=RT(1,1)
30079 SFMIX(IF,2)=RT(1,2)
30080 SFMIX(IF,3)=RT(2,1)
30081 SFMIX(IF,4)=RT(2,2)
30087 C*********************************************************************
30090 C...Finds the mass eigenstates and mixing matrices for neutralinos
30095 C...Double precision and integer declarations.
30096 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30097 IMPLICIT INTEGER(I-N)
30098 INTEGER PYK,PYCHGE,PYCOMP
30099 C...Parameter statement to help give large particle numbers.
30100 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30103 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30104 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
30105 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
30107 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
30109 C...Local variables.
30110 DOUBLE PRECISION XMW,XMZ
30111 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
30112 DOUBLE PRECISION ZP(4,4)
30113 DOUBLE PRECISION DETX,XI(2,2)
30114 DOUBLE PRECISION XXX,YYY,XMH,XML
30115 DOUBLE PRECISION COSW,SINW
30116 DOUBLE PRECISION XMU
30117 DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
30118 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
30119 DOUBLE PRECISION XM1,XM2,XM3,BETA
30120 DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
30121 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
30122 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
30123 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
30124 DOUBLE PRECISION PYALPS,PYALEM
30125 DOUBLE PRECISION PYRNM3
30126 INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
30127 DATA KFNCHI/1000022,1000023,1000025,1000035/
30130 IF(IMSS(1).EQ.2) THEN
30133 C...M1, M2, AND M3 ARE INDEPENDENT
30138 ELSEIF(IOPT.GE.1) THEN
30142 A1=AEM/(1D0-PARU(102))
30145 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
30147 XM2=XM1*A2/A1*3D0/5D0
30149 ELSEIF(IOPT.EQ.3) THEN
30150 XM1=XM2*5D0/3D0*A1/A2
30155 IF(XM3.LE.0D0) THEN
30156 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
30162 IF(IMSS(3).EQ.1) THEN
30163 PMAS(PYCOMP(KSUSY1+21),1)=XM3
30168 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
30169 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
30170 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
30176 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
30177 RM2=PMAS(I,1)**2/XM3**2
30178 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
30179 IF(ARG.GE.0D0) THEN
30180 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
30182 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
30187 ELSEIF(X0.EQ.0D0) THEN
30191 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
30192 & 0.5D0*X0**2*LOG(AX0)
30193 BT=(-1D0-2D0*X0)/4D0
30198 ELSEIF(X1.EQ.0D0) THEN
30202 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
30203 & X1**2*LOG(AX1)+AT
30204 BT=(-1D0-2D0*X1)/4D0+BT
30208 X0=0.5D0*(1D0+RM2-RM1)
30209 Y0=-0.5D0*SQRT(-ARG)
30210 AMGX0=SQRT(X0**2+Y0**2)
30211 AM1X0=SQRT((1D0-X0)**2+Y0**2)
30212 ARGX0=ATAN2(-X0,-Y0)
30213 AR1X0=ATAN2(1D0-X0,Y0)
30218 ARGX1=ATAN2(-X1,-Y1)
30219 AR1X1=ATAN2(1D0-X1,Y1)
30220 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
30221 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
30222 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
30223 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
30224 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
30225 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
30230 PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
30234 C...NEUTRALINO MASSES
30238 SINW=SQRT(PARU(102))
30239 COSW=SQRT(1D0-PARU(102))
30250 AR(1,3) = -XMZ*SINW*COSB
30252 AR(1,4) = XMZ*SINW*SINB
30254 AR(2,3) = XMZ*COSW*COSB
30256 AR(2,4) = -XMZ*COSW*SINB
30260 CALL PYEIG4(AR,WR,ZR)
30263 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
30266 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
30270 C...CHARGINO MASSES
30273 AR(1,2) = SQRT(2D0)*XMW*SINB
30274 AR(2,1) = SQRT(2D0)*XMW*COSB
30275 TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2
30276 TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2
30277 TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)*
30278 &(AR(1,2)**2+AR(2,1)**2)+
30279 &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1)
30281 IF(DISCR.LT.0D0) THEN
30282 WRITE(MSTU(11),*) ' PROBLEM WITH DISCR '
30286 XML2=0.5D0*(TERMB-DISCR)
30287 XMH2=0.5D0*(TERMB+DISCR)
30290 PMAS(PYCOMP(KSUSY1+24),1)=XML
30291 PMAS(PYCOMP(KSUSY1+37),1)=XMH
30294 XXX=AR(1,1)**2+AR(2,1)**2
30295 YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1)
30296 VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2)
30297 VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
30298 VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2)
30299 VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
30304 DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1)
30305 XI(1,1) = AR(2,2)/DETX
30306 XI(2,2) = AR(1,1)/DETX
30307 XI(1,2) = -AR(1,2)/DETX
30308 XI(2,1) = -AR(2,1)/DETX
30314 UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J)
30325 C*********************************************************************
30328 C...Calculates the running of M3, the SU(3) gluino mass parameter.
30330 FUNCTION PYRNM3(RGUT)
30332 C...Double precision and integer declarations.
30333 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30334 IMPLICIT INTEGER(I-N)
30335 INTEGER PYK,PYCHGE,PYCOMP
30337 C...Local variables.
30338 DOUBLE PRECISION PI,R
30339 DOUBLE PRECISION TOL
30341 DOUBLE PRECISION PYALPS
30343 DATA PI,R/3.141592654D0,0.61803399D0/
30347 BX=RGUT*PYALPS(RGUT**2)
30348 AX=MIN(50D0,BX*0.5D0)
30349 CX=MAX(2000D0,2D0*BX)
30353 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
30361 F1=ABS(X1-RGUT*AS1)
30363 F2=ABS(X2-RGUT*AS2)
30364 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
30371 F2=ABS(X2-RGUT*AS2)
30378 F1=ABS(X1-RGUT*AS1)
30393 C*********************************************************************
30396 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
30397 C...Specific application: mixing in neutralino sector.
30399 SUBROUTINE PYEIG4(A,W,Z)
30401 C...Double precision and integer declarations.
30402 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30403 IMPLICIT INTEGER(I-N)
30404 INTEGER PYK,PYCHGE,PYCOMP
30406 C...Arrays: in call and local.
30407 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
30409 C...Coefficients of fourth-degree equation from matrix.
30410 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
30411 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
30415 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
30424 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
30425 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
30426 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
30427 B0=B0+(-1D0)**(I+1)*A(1,I)*(
30428 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
30429 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
30430 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
30433 C...Coefficients of third-degree equation needed for
30434 C...separation into two second-degree equations.
30435 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
30438 C0=-B1**2-B0*B3**2+4D0*B0*B2
30439 CQ=C1/3D0-C2**2/9D0
30440 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
30443 C...Cases with one or three real roots.
30444 IF(CQR.GE.0D0) THEN
30445 S1=(CR+SQRT(CQR))**(1D0/3D0)
30446 S2=(CR-SQRT(CQR))**(1D0/3D0)
30450 THE=ACOS(CR/SABS**3)/3D0
30455 C...Find and solve two second-degree equations.
30456 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
30457 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
30458 Q1=U/2D0+SQRT(U**2/4D0-B0)
30459 Q2=U/2D0-SQRT(U**2/4D0-B0)
30460 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
30465 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
30466 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
30467 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
30468 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
30470 C...Order eigenvalues in asceding mass.
30473 DO 130 I2=I1-1,1,-1
30474 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
30480 C...Find equation system for eigenvectors.
30483 D(J1,J1)=A(J1,J1)-W(I)
30490 C...Find largest element in matrix.
30494 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
30497 DAMAX=ABS(D(J1,J2))
30501 C...Subtract others by multiple of row selected above.
30503 DO 210 J3=JA+1,JA+3
30505 RL=D(J1,JB)/D(JA,JB)
30507 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
30508 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
30511 DAMAX=ABS(D(J1,J2))
30515 C...Do one more subtraction of a row.
30517 DO 230 J3=JC+1,JC+3
30519 IF(J1.EQ.JA) GOTO 230
30520 RL=D(J1,JD)/D(JC,JD)
30522 IF(J2.EQ.JB) GOTO 220
30523 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
30524 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
30526 DAMAX=ABS(D(J1,J2))
30530 C...Construct unnormalized eigenvector.
30532 JF2=JD+2-4*((JD+1)/4)
30533 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
30534 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
30537 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
30538 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
30541 C...Normalize and fill in final array.
30542 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
30543 SGN=(-1D0)**INT(PYR(0)+0.5D0)
30552 C*********************************************************************
30555 C...Determines the Higgs boson mass spectrum using several inputs.
30557 SUBROUTINE PYHGGM(ALPHA)
30559 C...Double precision and integer declarations.
30560 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30561 IMPLICIT INTEGER(I-N)
30562 INTEGER PYK,PYCHGE,PYCOMP
30563 C...Parameter statement to help give large particle numbers.
30564 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30566 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30567 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30568 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30569 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
30570 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
30572 C...Local variables.
30573 DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
30574 DOUBLE PRECISION ALPHA
30575 INTEGER I,J,IHOPT,II,JJ,IT
30576 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
30577 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
30578 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
30579 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
30582 IF(IHOPT.EQ.2) THEN
30597 DMC=PMAS(PYCOMP(KSUSY1+37),1)
30602 IF(IHOPT.EQ.0) THEN
30603 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
30604 & DMHCH,DSA,DCA,DTANBA)
30605 ELSEIF(IHOPT.EQ.1) THEN
30606 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
30607 & DMHCH,DSA,DCA,DTANBA)
30608 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
30609 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
30610 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA)
30614 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
30615 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
30616 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
30617 & PMAS(PYCOMP(1000006),1),DSTOP2
30619 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
30620 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
30621 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
30622 & PMAS(PYCOMP(2000006),1),DSTOP1
30624 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
30625 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
30626 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
30627 & PMAS(PYCOMP(1000005),1),DSBOT2
30629 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
30630 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
30631 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
30632 & PMAS(PYCOMP(2000005),1),DSBOT1
30647 C*********************************************************************
30650 C...This routine computes the renormalization group improved
30651 C...values of Higgs masses and couplings in the MSSM.
30653 C...Program based on the work by M. Carena, J.R. Espinosa,
30654 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
30656 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
30657 C...All masses in GeV units. MA is the CP-odd Higgs mass,
30658 C...MTOP is the physical top mass, MQ and MUR are the soft
30659 C...supersymmetry breaking mass parameters of left handed
30660 C...and right handed stops respectively, AU and AD are the
30661 C...stop and sbottom trilinear soft breaking terms,
30662 C...respectively, and MU is the supersymmetric
30663 C...Higgs mass parameter. We use the conventions from
30664 C...the physics report of Haber and Kane: left right
30665 C...stop mixing term proportional to (AU - MU/TANB)
30666 C...We use as input TANB defined at the scale MTOP
30668 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
30669 C...where MH and HM are the lightest and heaviest CP-even
30670 C...Higgs masses, MHCH is the charged Higgs mass and
30671 C...ALPHA is the Higgs mixing angle
30672 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
30674 C...Range of validity:
30675 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
30676 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
30677 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
30678 C...are the sbottom mass eigenvalues, respectively. This
30679 C...range automatically excludes the existence of tachyons.
30680 C...For the charged Higgs mass computation, the method is
30682 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
30683 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
30684 C...where M_SUSY**2 is the average of the squared stop mass
30685 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
30686 C...masses have been assumed to be of order of the stop ones
30687 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
30689 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
30690 &XMHCH,SA,CA,TANBA)
30692 C...Double precision and integer declarations.
30693 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30694 IMPLICIT INTEGER(I-N)
30695 INTEGER PYK,PYCHGE,PYCOMP
30696 C...Parameter statement to help give large particle numbers.
30697 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30699 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30700 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30701 COMMON/PYHTRI/HHH(7)
30702 SAVE /PYDAT1/,/PYDAT2/
30704 C...Local variables.
30705 DOUBLE PRECISION PYALEM,PYALPS
30706 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
30707 DOUBLE PRECISION XMHCH,SA,CA
30708 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
30709 DOUBLE PRECISION Q02
30710 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
30711 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
30712 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
30713 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
30714 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
30715 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
30716 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
30717 DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
30722 ALP1=AEM/(1D0-PARU(102))
30735 C...MBOTTOM(MTOP) = 3. GEV
30737 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
30738 &LOG(XMTOP**2/XMZ**2))
30740 C...RMTOP= RUNNING TOP QUARK MASS
30741 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
30742 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
30743 T = LOG(XMS**2/XMTOP**2)
30744 SINB = TANB/((1D0 + TANB**2)**0.5D0)
30746 C...IF(MA.LE.XMTOP) TANBA = TANBT
30748 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
30749 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
30750 &LOG(XMA**2/XMTOP**2))
30752 SINBT = TANBT/SQRT(1D0 + TANBT**2)
30753 COSBT = 1D0/SQRT(1D0 + TANBT**2)
30754 COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
30755 G1 = SQRT(ALP1*4D0*PI)
30756 G2 = SQRT(ALP2*4D0*PI)
30757 G3 = SQRT(ALP3*4D0*PI)
30772 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
30773 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
30774 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
30775 &+ 3D0*(AU + AD)**2/XMS2)/6D0
30776 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
30777 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
30778 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
30779 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
30780 &- 16D0*G3**2) *T/16D0/PI2)
30781 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
30782 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
30783 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
30784 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
30785 &- 16D0*G3**2) *T/16D0/PI2)
30786 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
30787 &(HU2 + HD2)*T/16D0/PI2)
30788 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
30789 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
30790 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
30791 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
30792 &- 16D0*G3**2) *T/16D0/PI2)
30793 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
30794 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
30795 &- 16D0*G3**2) *T/16D0/PI2)
30796 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
30797 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
30798 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
30799 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
30801 &(1+ (6D0*HU2 -2D0* HD2
30802 &- 16D0*G3**2) *T/16D0/PI2)
30803 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
30805 &(1+ (6D0*HD2 -2D0* HU2/2D0
30806 &- 16D0*G3**2) *T/16D0/PI2)
30807 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
30808 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
30809 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
30810 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
30811 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
30812 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
30813 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
30814 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
30815 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
30816 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
30817 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
30818 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
30826 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
30827 &2D0* XLAM6*SINBT*COSBT
30828 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
30830 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
30832 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
30833 &2D0* XLAM6* COSBT*SINBT
30834 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
30835 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
30836 &((XLAM1* COSBT**2 +2D0*
30837 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
30838 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
30840 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
30841 &+ XLAM4) + XLAM6*COSBT**2
30842 &+ XLAM7* SINBT**2))
30844 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
30845 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
30848 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
30849 XMHCH = SQRT(XMHCH2)
30851 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
30852 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
30853 &XLAM6* COSBT*SINBT
30854 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
30855 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
30856 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
30857 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
30859 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
30860 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
30861 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
30862 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
30863 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
30864 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
30865 &XLAM6* COSBT*SINBT
30866 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
30867 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
30868 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
30878 C*********************************************************************
30881 C...This subroutine computes the CP-even higgs and CP-odd pole
30882 c...Higgs masses and mixing angles.
30884 C...Program based on the work by M. Carena, M. Quiros
30885 C...and C.E.M. Wagner, "Effective potential methods and
30886 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
30888 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
30890 C...where MCHI is the largest chargino mass, MA is the running
30891 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
30892 C...expectaion values at the scale MTOP, MQ is the third generation
30893 C...left handed squark mass parameter, MUR is the third generation
30894 C...right handed stop mass parameter, MDR is the third generation
30895 C...right handed sbottom mass parameter, MTOP is the pole top quark
30896 C...mass; AT,AB are the soft supersymmetry breaking trilinear
30897 C...couplings of the stop and sbottoms, respectively, and MU is the
30898 C...supersymmetric mass parameter
30900 C...The parameter IHIGGS=0,1,2,3 corresponds to the
30901 c...number of Higgses whose pole mass is computed
30902 c...by the subroutine PYVACU(...). If IHIGGS=0 only running
30903 c...masses are given, what makes the running of the program
30904 c...much faster and it is quite generally a good approximation
30905 c...(for a theoretical discussion see ref. below).
30906 c...If IHIGGS=1, only the pole
30907 c...mass for H is computed. If IHIGGS=2, then h and H, and
30908 c...if IHIGGS=3, then h,H,A polarizations are computed
30910 C...Output: MH and MHP which are the lightest CP-even Higgs running
30911 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
30912 C...Higgs running and pole masses, repectively; SA and CA are the
30913 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
30914 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
30915 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
30916 C...the value of TANB at the CP-odd Higgs mass scale
30918 C...This subroutine makes use of CERN library subroutine
30919 C...integration package, which makes the computation of the
30920 C...pole Higgs masses somewhat faster. We thank P. Janot for this
30921 C...improvement. Those who are not able to call the CERN
30922 C...libraries, please use the subroutine SUBHPOLE2.F, which
30923 C...although somewhat slower, gives identical results
30925 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
30926 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
30928 C...Double precision and integer declarations.
30929 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30930 IMPLICIT INTEGER(I-N)
30933 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30934 INTEGER PYK,PYCHGE,PYCOMP
30936 C...Local variables.
30937 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
30938 &SSBOT2(2),B(2,2),COUPB(2,2),
30939 &HCOUPT(2,2),HCOUPB(2,2),
30940 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
30950 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
30952 C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
30956 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
30957 &XMU,XMH,HM,SA,CA,TANBA)
30958 SINB = TANB/(TANB**2+1D0)**0.5D0
30959 COSB = 1D0/(TANB**2+1D0)**0.5D0
30960 COS2B = SINB**2 - COSB**2
30961 SINBPA = SINB*CA + COSB*SA
30962 COSBPA = COSB*CA - SINB*SA
30966 IF(XMUR.LT.0D0) XMUR2=-XMUR2
30968 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
30969 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
30970 IF(XMST11.LT.0D0) GOTO 500
30971 IF(XMST22.LT.0D0) GOTO 500
30972 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
30973 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
30974 IF(XMSB11.LT.0D0) GOTO 500
30975 IF(XMSB22.LT.0D0) GOTO 500
30976 WMST11 = RXMT**2 + XMQ2
30977 WMST22 = RXMT**2 + XMUR2
30978 XMST12 = RXMT*(AT - XMU/TANB)
30979 XMSB12 = RMBOT*(AB - XMU*TANB)
30981 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30982 C...STOP EIGENVALUES CALCULATION
30983 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30985 STOP12 = 0.5D0*(XMST11+XMST22) +
30986 &0.5D0*((XMST11+XMST22)**2 -
30987 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
30988 STOP22 = 0.5D0*(XMST11+XMST22) -
30989 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
30990 &XMST12**2))**0.5D0
30992 IF(STOP22.LT.0D0) GOTO 500
30995 STOP1 = STOP12**0.5D0
30996 STOP2 = STOP22**0.5D0
31000 IF(XMST12.EQ.0D0) XST11 = 1D0
31001 IF(XMST12.EQ.0D0) XST12 = 0D0
31002 IF(XMST12.EQ.0D0) XST21 = 0D0
31003 IF(XMST12.EQ.0D0) XST22 = 1D0
31005 IF(XMST12.EQ.0D0) GOTO 110
31007 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
31008 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
31009 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
31010 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
31017 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
31018 &0.5D0*((XMSB11+XMSB22)**2 -
31019 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
31020 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
31021 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
31022 &XMSB12**2))**0.5D0
31023 IF(SBOT22.LT.0D0) GOTO 500
31024 SBOT1 = SBOT12**0.5D0
31025 SBOT2 = SBOT22**0.5D0
31030 IF(XMSB12.EQ.0D0) XSB11 = 1D0
31031 IF(XMSB12.EQ.0D0) XSB12 = 0D0
31032 IF(XMSB12.EQ.0D0) XSB21 = 0D0
31033 IF(XMSB12.EQ.0D0) XSB22 = 1D0
31035 IF(XMSB12.EQ.0D0) GOTO 130
31037 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
31038 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
31039 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
31040 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
31052 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31053 C...STARTING OF LIGHT HIGGS
31054 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31056 IF(IHIGGS.EQ.0) GOTO 490
31061 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
31062 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
31063 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
31064 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
31073 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
31074 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
31075 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
31076 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
31084 180 ITER = ITER + 1
31087 PR(I3)=PRUN+(I3-2)*EPS/2
31092 POLT = POLT + COUPT(I,J)**2*3D0*
31093 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31099 POLB = POLB + COUPB(I,J)**2*3D0*
31100 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31107 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31109 & (-2D0*XMT**2+0.5D0*P2)*
31110 & PYFINT(P2,XMT2,XMT2)
31112 POL = POLT + POLB + POLTT
31113 POLAR(I3) = P2 - XMH**2 - POL
31115 DERIV = (POLAR(3)-POLAR(1))/EPS
31116 DRUN = - POLAR(2)/DERIV
31119 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.100 ) GOTO 240
31125 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31126 C...END OF LIGHT HIGGS
31127 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31129 250 IF(IHIGGS.EQ.1) GOTO 490
31131 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31132 C... STARTING OF HEAVY HIGGS
31133 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31138 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
31139 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
31140 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
31141 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
31149 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
31150 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
31151 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
31152 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
31161 300 ITER = ITER + 1
31163 PR(I3)=PRUN+(I3-2)*EPS/2
31169 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
31170 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31177 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
31178 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31186 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31188 & (-2D0*XMT**2+0.5D0*HP2)*
31189 & PYFINT(HP2,XMT2,XMT2)
31191 HPOL = HPOLT + HPOLB + HPOLTT
31192 POLAR(I3) =HP2-HM**2-HPOL
31194 DERIV = (POLAR(3)-POLAR(1))/EPS
31195 DRUN = - POLAR(2)/DERIV
31198 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.100 ) GOTO 360
31206 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31207 C... END OF HEAVY HIGGS
31208 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31210 IF(IHIGGS.EQ.2) GOTO 490
31212 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31213 C...BEGINNING OF PSEUDOSCALAR HIGGS
31214 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31219 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
31220 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
31226 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
31227 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
31234 420 ITER = ITER + 1
31236 PR(I3)=PRUN+(I3-2)*EPS/2
31241 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
31242 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31248 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
31249 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31255 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31256 & COSB**2/SINB**2 *
31258 & PYFINT(AP2,XMT2,XMT2)
31259 APOL = APOLT + APOLB + APOLTT
31260 POLAR(I3) = AP2 - XMA**2 -APOL
31262 DERIV = (POLAR(3)-POLAR(1))/EPS
31263 DRUN = - POLAR(2)/DERIV
31266 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.100 ) GOTO 480
31272 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31273 C...END OF PSEUDOSCALAR HIGGS
31274 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31276 IF(IHIGGS.EQ.3) GOTO 490
31281 WRITE(MSTU(11),*) ' EXITING IN PYVACU '
31282 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
31283 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
31284 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
31288 C*********************************************************************
31291 C...Computes Higgs masses and mixing angles, see PYPOLE above.
31293 SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
31294 &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
31295 &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
31297 C...Double precision and integer declarations.
31298 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31299 IMPLICIT INTEGER(I-N)
31301 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31302 INTEGER PYK,PYCHGE,PYCOMP
31304 C...Local variables.
31305 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
31306 &SSBOT2(2),B(2,2),COUPB(2,2),
31307 &HCOUPT(2,2),HCOUPB(2,2),
31308 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
31318 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
31320 C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
31324 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
31325 &XMU,XMH,HM,SA,CA,TANBA)
31326 SINB = TANB/(TANB**2+1D0)**0.5D0
31327 COSB = 1D0/(TANB**2+1D0)**0.5D0
31328 COS2B = SINB**2 - COSB**2
31329 SINBPA = SINB*CA + COSB*SA
31330 COSBPA = COSB*CA - SINB*SA
31334 IF(XMUR.LT.0D0) XMUR2=-XMUR2
31336 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
31337 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
31338 IF(XMST11.LT.0D0) GOTO 500
31339 IF(XMST22.LT.0D0) GOTO 500
31340 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
31341 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
31342 IF(XMSB11.LT.0D0) GOTO 500
31343 IF(XMSB22.LT.0D0) GOTO 500
31344 WMST11 = RXMT**2 + XMQ2
31345 WMST22 = RXMT**2 + XMUR2
31346 XMST12 = RXMT*(AT - XMU/TANB)
31347 XMSB12 = RMBOT*(AB - XMU*TANB)
31349 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31350 C...STOP EIGENVALUES CALCULATION
31351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31353 STOP12 = 0.5D0*(XMST11+XMST22) +
31354 &0.5D0*((XMST11+XMST22)**2 -
31355 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
31356 STOP22 = 0.5D0*(XMST11+XMST22) -
31357 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
31358 &XMST12**2))**0.5D0
31360 IF(STOP22.LT.0D0) GOTO 500
31363 STOP1 = STOP12**0.5D0
31364 STOP2 = STOP22**0.5D0
31368 IF(XMST12.EQ.0D0) XST11 = 1D0
31369 IF(XMST12.EQ.0D0) XST12 = 0D0
31370 IF(XMST12.EQ.0D0) XST21 = 0D0
31371 IF(XMST12.EQ.0D0) XST22 = 1D0
31373 IF(XMST12.EQ.0D0) GOTO 110
31375 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
31376 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
31377 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
31378 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
31385 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
31386 &0.5D0*((XMSB11+XMSB22)**2 -
31387 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
31388 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
31389 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
31390 &XMSB12**2))**0.5D0
31391 IF(SBOT22.LT.0D0) GOTO 500
31392 SBOT1 = SBOT12**0.5D0
31393 SBOT2 = SBOT22**0.5D0
31398 IF(XMSB12.EQ.0D0) XSB11 = 1D0
31399 IF(XMSB12.EQ.0D0) XSB12 = 0D0
31400 IF(XMSB12.EQ.0D0) XSB21 = 0D0
31401 IF(XMSB12.EQ.0D0) XSB22 = 1D0
31403 IF(XMSB12.EQ.0D0) GOTO 130
31405 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
31406 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
31407 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
31408 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
31420 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31421 C...STARTING OF LIGHT HIGGS
31422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31424 IF(IHIGGS.EQ.0) GOTO 490
31429 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
31430 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
31431 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
31432 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
31441 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
31442 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
31443 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
31444 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
31452 180 ITER = ITER + 1
31455 PR(I3)=PRUN+(I3-2)*EPS/2
31460 POLT = POLT + COUPT(I,J)**2*3D0*
31461 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31467 POLB = POLB + COUPB(I,J)**2*3D0*
31468 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31475 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31477 & (-2D0*XMT**2+0.5D0*P2)*
31478 & PYFINT(P2,XMT2,XMT2)
31480 POL = POLT + POLB + POLTT
31481 POLAR(I3) = P2 - XMH**2 - POL
31483 DERIV = (POLAR(3)-POLAR(1))/EPS
31484 DRUN = - POLAR(2)/DERIV
31487 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240
31493 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31494 C...END OF LIGHT HIGGS
31495 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31497 250 IF(IHIGGS.EQ.1) GOTO 490
31499 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31500 C... STARTING OF HEAVY HIGGS
31501 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31506 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
31507 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
31508 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
31509 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
31517 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
31518 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
31519 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
31520 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
31529 300 ITER = ITER + 1
31531 PR(I3)=PRUN+(I3-2)*EPS/2
31537 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
31538 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31545 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
31546 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31554 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31556 & (-2D0*XMT**2+0.5D0*HP2)*
31557 & PYFINT(HP2,XMT2,XMT2)
31559 HPOL = HPOLT + HPOLB + HPOLTT
31560 POLAR(I3) =HP2-HM**2-HPOL
31562 DERIV = (POLAR(3)-POLAR(1))/EPS
31563 DRUN = - POLAR(2)/DERIV
31566 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360
31574 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31575 C... END OF HEAVY HIGGS
31576 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31578 IF(IHIGGS.EQ.2) GOTO 490
31580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31581 C...BEGINNING OF PSEUDOSCALAR HIGGS
31582 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31587 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
31588 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
31594 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
31595 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
31602 420 ITER = ITER + 1
31604 PR(I3)=PRUN+(I3-2)*EPS/2
31609 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
31610 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31616 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
31617 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31623 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31624 & COSB**2/SINB**2 *
31626 & PYFINT(AP2,XMT2,XMT2)
31627 APOL = APOLT + APOLB + APOLTT
31628 POLAR(I3) = AP2 - XMA**2 -APOL
31630 DERIV = (POLAR(3)-POLAR(1))/EPS
31631 DRUN = - POLAR(2)/DERIV
31634 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480
31640 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31641 C...END OF PSEUDOSCALAR HIGGS
31642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31644 IF(IHIGGS.EQ.3) GOTO 490
31649 WRITE(MSTU(11),*) ' EXITING IN PYVACU '
31650 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
31651 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
31652 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
31656 C*********************************************************************
31659 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
31661 SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
31662 &XMHP,HMP,SA,CA,TANBA)
31664 C...Double precision and integer declarations.
31665 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31666 IMPLICIT INTEGER(I-N)
31667 INTEGER PYK,PYCHGE,PYCOMP
31668 COMMON/PYHTRI/HHH(7)
31670 C...Local variables.
31671 DIMENSION VH(2,2),XM2(2,2),XM2P(2,2)
31682 C...MBOTTOM(XMT) = 3. GEV
31684 ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z*
31685 &LOG(XMT**2/XMZ**2))
31687 C...RXMT= RUNNING TOP QUARK MASS
31688 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
31689 TQ = LOG((XMQ**2+XMT**2)/XMT**2)
31690 TU = LOG((XMUR**2 + XMT**2)/XMT**2)
31691 TD = LOG((XMDL**2 + XMT**2)/XMT**2)
31692 SINB = TANB/((1D0 + TANB**2)**0.5D0)
31695 &TANBA = TANB*(1D0-3D0/32D0/PI**2*
31696 &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
31697 &LOG(XMA**2/XMT**2))
31698 IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA
31699 SINB = TANBT/((1D0 + TANBT**2)**0.5D0)
31700 COSB = 1D0/((1D0 + TANBT**2)**0.5D0)
31701 COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
31702 G1 = (ALP1*4D0*PI)**0.5D0
31703 G2 = (ALP2*4D0*PI)**0.5D0
31704 G3 = (ALP3*4D0*PI)**0.5D0
31708 CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD,
31709 &XMU,VH,STOP1,STOP2)
31711 IF(XMQ.GT.XMUR) TP = TQ - TU
31712 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ
31713 IF(XMQ.GT.XMUR) TDP = TU
31714 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ
31715 IF(XMQ.GT.XMDL) TPD = TQ - TD
31716 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ
31717 IF(XMQ.GT.XMDL) TDPD = TD
31718 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ
31720 IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
31721 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2*
31722 &HD**2*(G1**2/3D0+G2**2)*TPD
31724 IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP
31725 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2*
31726 &HU**2*(-G1**2/3D0+G2**2)*TP
31731 IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
31732 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2*
31733 &(G2**2-G1**2/3D0)*TPD
31735 IF(XMQ.GT.XMUR) DLAM3 = DLAM3 -
31736 &1D0/16D0/PI**2*G1**2*HU**2*TP
31737 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 +
31738 &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
31740 IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
31741 IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2*
31744 XLAM1 = ((G1**2 + G2**2)/4D0)*
31745 &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
31746 &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0
31747 &+ (3D0*HD**2/2D0 + HU**2/2D0
31748 &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
31749 &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
31750 &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1
31751 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
31752 &(TP + TDP)/8D0/PI**2)
31753 &+(3D0*HU**4/16D0/PI**2) *TP*(1D0
31754 &+ (3D0*HU**2/2D0 + HD**2/2D0
31755 &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
31756 &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
31757 &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2
31758 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
31759 &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
31760 &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3
31761 XLAM4 = (- G2**2/2D0)*(1D0
31762 &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
31763 &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4
31769 C...Defined now in PYSUBH
31778 XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6*
31779 &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2
31781 XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7*
31782 &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2
31783 XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)*
31784 &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB
31786 XM2(2,1) = XM2(1,2)
31788 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31789 C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
31790 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31792 XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0
31794 IF(XMC.GT.XMSSU) GOTO 100
31795 IF(XMC.LT.XMT) XMC=XMT
31797 TCHAR=LOG(XMSSU**2/XMC**2)
31799 DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
31800 DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
31801 &+4D0/32/PI**2*G1**2*G2**2)*TCHAR
31803 DEM112=2D0*DEL12*V**2*COSB**2
31804 DEM222=2D0*DEL12*V**2*SINB**2
31805 DEM122=2D0*DEL3P4*V**2*SINB*COSB
31807 XM2(1,1)=XM2(1,1)+DEM112
31808 XM2(2,2)=XM2(2,2)+DEM222
31809 XM2(1,2)=XM2(1,2)+DEM122
31810 XM2(2,1)=XM2(2,1)+DEM122
31814 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31815 C...END OF CHARGINOS/NEUTRALINOS
31816 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31820 XM2P(I,J) = XM2(I,J) + VH(I,J)
31824 TRM2P = XM2P(1,1) + XM2P(2,2)
31825 DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1)
31827 XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
31828 HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
31830 IF(XMH2P.LT.0D0) GOTO 130
31831 XMHP = XMH2P**0.5D0
31832 S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0
31833 C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0
31834 IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0
31835 IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0
31838 SQBMA = (SINB*CA - COSB*SA)**2
31845 C*********************************************************************
31848 C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
31850 SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
31853 C...Double precision and integer declarations.
31854 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31855 IMPLICIT INTEGER(I-N)
31856 INTEGER PYK,PYCHGE,PYCOMP
31858 C...Local variables.
31859 DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
31860 &VH3T(2,2),VH3B(2,2),
31861 &HMIX(2,2),AL(2,2),XM2(2,2)
31863 C...Statement function.
31864 G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y)
31866 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
31871 SINBA = TANBA/(TANBA**2+1D0)**0.5D0
31872 COSBA = SINBA/TANBA
31874 SINB = TANB/(TANB**2+1D0)**0.5D0
31877 G2 = (0.0336D0*4D0*PI)**0.5D0
31878 G12 = (0.0101D0*4D0*PI)
31882 MW = (G2**2*V**2/2D0)**0.5D0
31883 ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2))
31886 IF(XMQ.GT.XMUR) XMST = XMQ
31887 IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR
31889 XMSUT = (XMST**2 + XMT**2)**0.5D0
31891 IF(XMQ.GT.XMDL) XMSB = XMQ
31892 IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL
31894 XMSUB = (XMSB**2 + XMB**2)**0.5D0
31896 TT = LOG(XMSUT**2/XMT**2)
31897 TB = LOG(XMSUB**2/XMT**2)
31899 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
31900 HT = RXMT/(174.1D0*SINB)
31901 HTST = RXMT/174.1D0
31902 HB = XMB/174.1D0/COSB
31904 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
31905 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
31906 AL2 = 3D0/8D0/PI**2*HT**2
31907 BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2
31908 ALST = 3D0/8D0/PI**2*HTST**2
31909 AL1 = 3D0/8D0/PI**2*HB**2
31912 AL(1,2) = (AL2+AL1)/2D0
31913 AL(2,1) = (AL2+AL1)/2D0
31916 XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT)
31918 XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB)
31919 XMBOT2 = SQRT(XMBOT4)
31921 IF(XMA.GT.XMT) THEN
31922 VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2*
31923 & LOG(XMT**2/XMA**2))
31926 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0
31927 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0
31928 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0
31929 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0
31934 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0
31935 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0
31936 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0
31937 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0
31941 SINBT = TANBST/(1D0+TANBST**2)**0.5D0
31942 COSBT = SINBT/TANBST
31945 SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0
31946 COSBB = SINBB/TANBSB
31948 STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2
31949 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
31950 &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
31951 &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0
31952 STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2
31953 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
31954 &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
31955 &XMQ2 - XMUR2)**2*0.25D0
31956 &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0
31957 IF(STOP22.LT.0D0) GOTO 120
31958 SBOT12 = (XMQ2 + XMDL2)*0.5D0
31959 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
31960 &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
31961 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
31962 SBOT22 = (XMQ2 + XMDL2)*0.5D0
31963 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
31964 &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
31965 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
31966 IF(SBOT22.LT.0D0) GOTO 120
31968 STOP1 = STOP12**0.5D0
31969 STOP2 = STOP22**0.5D0
31970 SBOT1 = SBOT12**0.5D0
31971 SBOT2 = SBOT22**0.5D0
31973 VH1(1,1) = 1D0/TANBST
31980 VH2(2,2) = 1D0/TANBST
31982 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31984 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31987 F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)*
31989 &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2))
31990 &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2))
31992 F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)*
31994 &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2))
31995 &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2))
31997 F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)*
31998 &(-0.5D0*LOG(STOP12/STOP22)
31999 &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)*
32002 F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
32003 &(0.5D0*LOG(SBOT12/SBOT22)
32004 &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)*
32007 VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
32008 &(XMQ2+XMBOT2)/(XMDL2+XMBOT2))
32009 &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
32010 &LOG(SBOT1**2/SBOT2**2)) +
32011 &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
32012 &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
32015 &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
32016 &-STOP2**2))**2*G(STOP12,STOP22)
32018 VH3B(1,1)=VH3B(1,1)+
32019 &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B)
32021 VH3T(1,1) = VH3T(1,1) +
32022 &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T)
32024 VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
32025 &(XMQ2+XMT2)/(XMUR2+XMT2))
32026 &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
32027 &LOG(STOP1**2/STOP2**2)) +
32028 &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
32029 &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
32032 &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
32033 &-SBOT2**2))**2*G(SBOT12,SBOT22)
32035 VH3T(2,2)=VH3T(2,2)+
32036 &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T)
32038 VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B
32041 &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
32042 &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
32043 &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
32046 &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/
32047 &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
32048 &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
32050 VH3T(1,2)=VH3T(1,2) +
32051 &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T)
32053 VH3B(1,2)=VH3B(1,2)
32054 &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B)
32056 VH3T(2,1) = VH3T(1,2)
32057 VH3B(2,1) = VH3B(1,2)
32059 TQ = LOG((XMQ2 + XMT2)/XMT2)
32060 TU = LOG((XMUR2+XMT2)/XMT2)
32061 TQD = LOG((XMQ2 + XMB**2)/XMB**2)
32062 TD = LOG((XMDL2+XMB**2)/XMB**2)
32068 & 6D0/(8D0*PI**2*(H1T**2+H2T**2))
32069 & *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
32070 & 6D0/(8D0*PI**2*(H1B**2+H2B**2))
32071 & *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
32088 C*********************************************************************
32091 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
32093 FUNCTION PYFINT(A,B,C)
32095 C...Double precision and integer declarations.
32096 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32097 IMPLICIT INTEGER(I-N)
32098 INTEGER PYK,PYCHGE,PYCOMP
32100 COMMON/PYINTS/XXM(20)
32103 C...Local variables.
32105 DOUBLE PRECISION PYFISB
32112 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
32117 C*********************************************************************
32120 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
32124 C...Double precision and integer declarations.
32125 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32126 IMPLICIT INTEGER(I-N)
32127 INTEGER PYK,PYCHGE,PYCOMP
32129 COMMON/PYINTS/XXM(20)
32132 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
32133 &(X*(XXM(2)-XXM(3))+XXM(3)))
32138 C*********************************************************************
32141 C...Calculates decays of sfermions.
32143 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
32145 C...Double precision and integer declarations.
32146 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32147 IMPLICIT INTEGER(I-N)
32148 INTEGER PYK,PYCHGE,PYCOMP
32149 C...Parameter statement to help give large particle numbers.
32150 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
32152 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32153 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32154 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32155 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32157 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
32159 C...Local variables.
32161 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
32163 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
32164 DOUBLE PRECISION PYLAMF,XL
32165 DOUBLE PRECISION TANW,XW,AEM,C1,AS
32166 DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
32167 DOUBLE PRECISION CH1,CH2,CH3,CH4
32168 DOUBLE PRECISION XMBOT,XMTOP
32169 DOUBLE PRECISION XLAM(0:200)
32170 INTEGER IDLAM(200,3)
32171 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
32172 DOUBLE PRECISION SR2
32173 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
32174 DOUBLE PRECISION CW
32175 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
32176 DOUBLE PRECISION COSA,SINA,TANB
32177 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
32178 DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
32179 INTEGER IG,KF1,KF2,ILR2,IDP
32180 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
32181 DATA IGG/23,25,35,36/
32182 DATA PI/3.141592654D0/
32183 DATA SR2/1.4142136D0/
32184 DATA KFNCHI/1000022,1000023,1000025,1000035/
32185 DATA KFCCHI/1000024,1000037/
32187 C...COUNT THE NUMBER OF DECAY MODES
32191 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
32192 &KFIN.EQ.KSUSY2+16) RETURN
32199 TANW = SQRT(XW/(1D0-XW))
32204 C...ILR is 1 for left and 2 for right.
32206 C...IFL is matching non-SUSY flavour.
32207 IFL=MOD(KFIN,KSUSY1)
32208 C...IDU is weak isospin, 1 for down and 2 for up.
32220 XMTOP=PYRNMT(PMAS(6,1))
32235 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
32237 IF(IMSS(11).EQ.1) THEN
32240 XMGR=PMAS(PYCOMP(IDG),1)
32241 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
32244 ELSEIF(IFL.EQ.6) THEN
32249 IF(XMI.GT.XMGR+XMF) THEN
32254 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
32258 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
32260 C...CHARGED DECAYS:
32262 C...DI -> U CHI1-,CHI2-
32266 C...UI -> D CHI1+,CHI2+
32273 IF(XMI.GE.AXMJ+XMFP) THEN
32280 ELSEIF(IFL.LT.6) THEN
32285 AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA
32286 BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA
32292 ELSEIF(IFL.LT.5) THEN
32297 AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA
32298 BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA
32302 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
32303 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
32304 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
32305 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
32321 XL=PYLAMF(XMI2,XMA2,XMB2)
32322 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
32323 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
32324 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP)
32327 IDLAM(LKNT,1)=-KFCCHI(IX)
32328 IDLAM(LKNT,2)=IFL+1
32330 IDLAM(LKNT,1)=KFCCHI(IX)
32331 IDLAM(LKNT,2)=IFL-1
32342 IF(XMI.GE.AXMJ+XMF) THEN
32348 ELSEIF(IFL.LT.5) THEN
32351 BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1)
32352 AL=XMF*ZMIX(IX,3)/XMW/CBETA
32353 AR=-2D0*EI*TANW*ZMIX(IX,1)
32358 ELSEIF(IFL.LT.5) THEN
32361 BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1)
32362 AL=XMF*ZMIX(IX,4)/XMW/SBETA
32363 AR=-2D0*EI*TANW*ZMIX(IX,1)
32367 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
32368 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
32369 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
32370 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
32386 XL=PYLAMF(XMI2,XMA2,XMB2)
32387 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
32388 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
32389 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
32390 IDLAM(LKNT,1)=KFNCHI(IX)
32396 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
32400 IF(ILR.EQ.1) GOTO 120
32402 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
32403 IF(XMI.LT.XMSF1+XMB) GOTO 120
32405 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
32408 ELSEIF(IG.EQ.25) THEN
32411 ELSEIF(IFL.EQ.6) THEN
32413 ELSEIF(IFL.LT.5) THEN
32419 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
32420 & XMF**2/XMW*COSA/SBETA
32421 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
32422 & XMF**2/XMW*COSA/SBETA
32424 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
32425 & XMF**2/XMW*(-SINA)/CBETA
32426 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
32427 & XMF**2/XMW*(-SINA)/CBETA
32431 ELSEIF(IFL.EQ.6) THEN
32433 ELSEIF(IFL.EQ.15) THEN
32439 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
32442 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
32448 ELSEIF(IG.EQ.35) THEN
32451 ELSEIF(IFL.EQ.6) THEN
32453 ELSEIF(IFL.LT.5) THEN
32459 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
32460 & XMF**2/XMW*SINA/SBETA
32461 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
32462 & XMF**2/XMW*SINA/SBETA
32464 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
32465 & XMF**2/XMW*COSA/CBETA
32466 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
32467 & XMF**2/XMW*COSA/CBETA
32471 ELSEIF(IFL.EQ.6) THEN
32473 ELSEIF(IFL.EQ.15) THEN
32479 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
32482 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
32488 ELSEIF(IG.EQ.36) THEN
32493 ELSEIF(IFL.EQ.6) THEN
32495 ELSEIF(IFL.LT.5) THEN
32502 ELSEIF(IFL.EQ.6) THEN
32504 ELSEIF(IFL.EQ.15) THEN
32510 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
32512 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
32518 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
32519 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
32520 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
32521 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
32524 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
32526 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
32529 IDLAM(LKNT,1)=KFIN-KSUSY1
32535 IF(MOD(IFL,2).EQ.0) THEN
32541 XMSF1=PMAS(PYCOMP(KF1),1)
32542 XMSF2=PMAS(PYCOMP(KF2),1)
32543 IF(XMI.GT.XMB+XMSF1) THEN
32544 IF(MOD(IFL,2).EQ.0) THEN
32546 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
32548 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
32552 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
32554 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
32557 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
32559 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
32562 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
32564 IF(XMI.GT.XMB+XMSF2) THEN
32565 IF(MOD(IFL,2).EQ.0) THEN
32567 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
32569 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
32573 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
32575 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
32578 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
32580 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
32583 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
32588 IF(MOD(IFL,2).EQ.0) THEN
32594 XMSF1=PMAS(PYCOMP(KF1),1)
32595 XMSF2=PMAS(PYCOMP(KF2),1)
32596 IF(XMI.GT.XMB+XMSF1) THEN
32601 IF(MOD(IFL,2).EQ.0) THEN
32604 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
32605 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
32606 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
32607 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
32610 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
32611 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
32612 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
32613 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
32624 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
32625 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
32626 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
32627 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
32630 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
32631 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
32632 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
32633 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
32642 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
32644 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
32645 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
32646 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
32647 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
32650 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
32652 IF(XMI.GT.XMB+XMSF2) THEN
32657 IF(MOD(IFL,2).EQ.0) THEN
32660 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
32661 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
32662 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
32663 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
32666 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
32667 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
32668 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
32669 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
32680 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
32681 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
32682 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
32683 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
32686 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
32687 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
32688 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
32689 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
32698 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
32700 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
32701 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
32702 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
32703 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
32706 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
32709 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
32714 IF(IFL.EQ.6) XMF=PMAS(6,1)
32715 IF(IFL.EQ.5) XMF=PMAS(5,1)
32716 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
32718 IF(XMI.GE.AXMJ+XMF) THEN
32735 XL=PYLAMF(XMI2,XMA2,XMB2)
32736 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
32737 & (CA**2+CB**2)+4D0*CA*CB*XMJ*XMF)
32738 IDLAM(LKNT,1)=KSUSY1+21
32744 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
32745 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
32746 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
32747 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
32748 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
32749 C...M*M = C1**2 * G**2/(16PI**2)
32750 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
32752 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
32753 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
32754 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
32755 IDLAM(LKNT,1)=KSUSY1+22
32763 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
32764 XLAM(0)=XLAM(0)+XLAM(I)
32766 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
32771 C*********************************************************************
32774 C...Calculates gluino decay modes.
32776 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
32778 C...Double precision and integer declarations.
32779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32780 IMPLICIT INTEGER(I-N)
32781 INTEGER PYK,PYCHGE,PYCOMP
32782 C...Parameter statement to help give large particle numbers.
32783 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
32785 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32786 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32787 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32788 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32790 COMMON/PYINTS/XXM(20)
32791 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
32793 C...Local variables.
32794 INTEGER KFIN,KCIN,KF
32795 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
32796 &XMZ,XMZ2,AXMJ,AXMI
32797 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
32798 DOUBLE PRECISION C1L,C1R,D1L,D1R
32799 DOUBLE PRECISION C2L,C2R,D2L,D2R
32800 DOUBLE PRECISION PYLAMF,XL
32801 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
32802 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
32803 DOUBLE PRECISION ALFA,BETA
32804 DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
32805 DOUBLE PRECISION XLAM(0:200)
32806 INTEGER IDLAM(200,3)
32807 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
32808 DOUBLE PRECISION SR2
32809 DOUBLE PRECISION GAM
32810 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
32811 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
32812 DOUBLE PRECISION PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
32813 DOUBLE PRECISION PREC
32814 INTEGER KFNCHI(4),KFCCHI(2)
32815 DATA PI/3.141592654D0/
32816 DATA SR2/1.4142136D0/
32818 DATA KFNCHI/1000022,1000023,1000025,1000035/
32819 DATA KFCCHI/1000024,1000037/
32821 C...COUNT THE NUMBER OF DECAY MODES
32823 IF(KFIN.NE.KSUSY1+21) RETURN
32831 TANW = SQRT(XW/(1D0-XW))
32842 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
32844 IF(IMSS(11).EQ.1) THEN
32847 XMGR=PMAS(PYCOMP(IDG),1)
32848 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
32849 IF(AXMI.GT.XMGR) THEN
32858 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
32862 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
32865 IDU=3-(1+MOD(IFL,2))
32866 IF(XMI.GE.AXMJ+XMF) THEN
32867 C...Minus sign difference from gluino-quark-squark feynman rules
32884 XL=PYLAMF(XMI2,XMA2,XMB2)
32885 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
32886 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
32887 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
32891 XLAM(LKNT)=XLAM(LKNT-1)
32892 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
32893 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
32899 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
32900 C...GLUINO -> NI Q QBAR
32904 IF(XMI.GE.AXMJ) THEN
32909 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
32910 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
32916 S12MAX=(XMI-AXMJ)**2
32921 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
32923 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
32924 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120
32925 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
32927 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
32928 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
32929 IDLAM(LKNT,1)=KFNCHI(IX)
32933 IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
32935 XLAM(LKNT)=XLAM(LKNT-1)
32936 IDLAM(LKNT,1)=KFNCHI(IX)
32941 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130
32942 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
32943 CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
32946 IDLAM(LKNT,1)=KFNCHI(IX)
32952 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
32953 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
32955 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
32957 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
32958 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140
32959 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
32961 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
32962 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
32963 IDLAM(LKNT,1)=KFNCHI(IX)
32967 IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
32969 XLAM(LKNT)=XLAM(LKNT-1)
32970 IDLAM(LKNT,1)=KFNCHI(IX)
32975 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
32976 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
32977 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150
32979 IF(XMI.GE.AXMJ+2D0*XMF) THEN
32980 CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
32983 IDLAM(LKNT,1)=KFNCHI(IX)
32991 C...GLUINO -> CI Q QBAR'
32995 IF(XMI.GE.AXMJ) THEN
32997 S12MAX=(AXMI-AXMJ)**2
33006 XXM(7)=UMIX(IX,1)*SR2
33007 XXM(8)=VMIX(IX,1)*SR2
33008 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
33009 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
33010 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170
33011 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
33013 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
33014 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
33015 IDLAM(LKNT,1)=KFCCHI(IX)
33019 XLAM(LKNT)=XLAM(LKNT-1)
33020 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
33021 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
33022 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
33024 IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
33026 XLAM(LKNT)=XLAM(LKNT-1)
33027 IDLAM(LKNT,1)=KFCCHI(IX)
33031 XLAM(LKNT)=XLAM(LKNT-1)
33032 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
33033 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
33034 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
33038 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180
33039 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180
33042 IF(XMI.GE.AXMJ+XMF+XMFP) THEN
33043 CALL PYTBBC(IX,80,AXMI,GAM)
33046 IDLAM(LKNT,1)=KFCCHI(IX)
33050 XLAM(LKNT)=XLAM(LKNT-1)
33051 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
33052 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
33053 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
33062 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
33063 XLAM(0)=XLAM(0)+XLAM(I)
33065 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
33070 C*********************************************************************
33073 C...Finds the s-hat dependent eigenvalues of the inverse propagator
33074 C...matrix for gamma, Z, technirho, and techniomega to optimize the
33075 C...phase space generation.
33077 SUBROUTINE PYTECM(S1,S2)
33079 C...Double precision and integer declarations.
33080 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33081 IMPLICIT INTEGER(I-N)
33082 INTEGER PYK,PYCHGE,PYCOMP
33083 C...Parameter statement to help give large particle numbers.
33084 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
33086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33089 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
33091 C...Local variables.
33092 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
33093 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
33094 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:200),WDTE(0:200,0:5)
33100 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
33101 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
33102 QUPD=2D0*PARP(143)-1D0
33104 ALPRHT=2.91D0*(3D0/PARP(144))
33105 FAR=SQRT(AEM/ALPRHT)
33111 AR(2,2) = SH-PMAS(23,1)**2
33112 AR(3,3) = SH-PMAS(54,1)**2
33113 AR(4,4) = SH-PMAS(56,1)**2
33133 CALL PYWIDT(23,SH,WDTP,WDTE)
33134 AT(2,2) = WDTP(0)*SHR
33135 CALL PYWIDT(54,SH,WDTP,WDTE)
33136 AT(3,3) = WDTP(0)*SHR
33137 CALL PYWIDT(56,SH,WDTP,WDTE)
33138 AT(4,4) = WDTP(0)*SHR
33140 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
33142 WI(I)=SQRT(ABS(SH-WR(I)))
33145 R1=MIN(WR(1),WR(2),WR(3),WR(4))
33150 IF(ABS(WR(I)-R1).LT.1D-6) THEN
33154 IF(WR(I).LE.R2) THEN
33166 C*********************************************************************
33169 C...Finds eigenvalues of a general complex matrix
33171 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
33173 INTEGER N,NM,IS1,IS2,IERR,MATZ
33174 DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
33175 X FV1(N),FV2(N),FV3(N)
33177 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
33178 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
33179 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
33180 C OF A COMPLEX GENERAL MATRIX.
33184 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
33185 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33186 C DIMENSION STATEMENT.
33188 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
33190 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33191 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
33193 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
33194 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
33195 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
33199 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33200 C RESPECTIVELY, OF THE EIGENVALUES.
33202 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33203 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
33205 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
33206 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
33207 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
33209 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
33211 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33212 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33214 C THIS VERSION DATED AUGUST 1983.
33216 C ------------------------------------------------------------------
33218 IF (N .LE. NM) GO TO 10
33222 10 CALL CBAL(NM,N,AR,AI,IS1,IS2,FV1)
33223 CALL CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
33224 IF (MATZ .NE. 0) GO TO 20
33225 C .......... FIND EIGENVALUES ONLY ..........
33226 CALL COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
33228 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
33229 20 CALL COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
33230 IF (IERR .NE. 0) GO TO 50
33231 CALL CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
33234 SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
33236 INTEGER I,J,K,M,N,II,NM,IGH,LOW
33237 DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M)
33240 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
33241 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
33242 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
33243 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
33245 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
33246 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
33247 C BALANCED MATRIX DETERMINED BY CBAL.
33251 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33252 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33253 C DIMENSION STATEMENT.
33255 C N IS THE ORDER OF THE MATRIX.
33257 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
33259 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
33260 C AND SCALING FACTORS USED BY CBAL.
33262 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
33264 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33265 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
33266 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
33270 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33271 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
33272 C IN THEIR FIRST M COLUMNS.
33274 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33275 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33277 C THIS VERSION DATED AUGUST 1983.
33279 C ------------------------------------------------------------------
33281 IF (M .EQ. 0) GO TO 200
33282 IF (IGH .EQ. LOW) GO TO 120
33284 DO 110 I = LOW, IGH
33286 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
33287 C IF THE FOREGOING STATEMENT IS REPLACED BY
33288 C S=1.0D0/SCALE(I). ..........
33290 ZR(I,J) = ZR(I,J) * S
33291 ZI(I,J) = ZI(I,J) * S
33295 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
33296 C IGH+1 STEP 1 UNTIL N DO -- ..........
33297 120 DO 140 II = 1, N
33299 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
33300 IF (I .LT. LOW) I = LOW - II
33302 IF (K .EQ. I) GO TO 140
33317 SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE)
33319 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
33320 DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N)
33321 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
33324 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
33325 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
33326 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
33327 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
33329 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
33330 C EIGENVALUES WHENEVER POSSIBLE.
33334 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33335 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33336 C DIMENSION STATEMENT.
33338 C N IS THE ORDER OF THE MATRIX.
33340 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33341 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
33345 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33346 C RESPECTIVELY, OF THE BALANCED MATRIX.
33348 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
33349 C ARE EQUAL TO ZERO IF
33350 C (1) I IS GREATER THAN J AND
33351 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
33353 C SCALE CONTAINS INFORMATION DETERMINING THE
33354 C PERMUTATIONS AND SCALING FACTORS USED.
33356 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
33357 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
33358 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
33359 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
33360 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
33361 C = D(J,J) J = LOW,...,IGH
33362 C = P(J) J = IGH+1,...,N.
33363 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
33366 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
33368 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
33369 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
33370 C K,L HAVE BEEN REVERSED.)
33372 C ARITHMETIC IS REAL THROUGHOUT.
33374 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33375 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33377 C THIS VERSION DATED AUGUST 1983.
33379 C ------------------------------------------------------------------
33387 C .......... IN-LINE PROCEDURE FOR ROW AND
33388 C COLUMN EXCHANGE ..........
33390 IF (J .EQ. M) GO TO 50
33410 50 GO TO (80,130), IEXC
33411 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
33412 C AND PUSH THEM DOWN ..........
33413 80 IF (L .EQ. 1) GO TO 280
33415 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
33416 100 DO 120 JJ = 1, L
33420 IF (I .EQ. J) GO TO 110
33421 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GO TO 120
33430 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
33431 C AND PUSH THEM LEFT ..........
33434 140 DO 170 J = K, L
33437 IF (I .EQ. J) GO TO 150
33438 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GO TO 170
33445 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
33447 180 SCALE(I) = 1.0D0
33448 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
33449 190 NOCONV = .FALSE.
33456 IF (J .EQ. I) GO TO 200
33457 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
33458 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
33460 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
33461 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270
33465 210 IF (C .GE. G) GO TO 220
33470 230 IF (C .LT. G) GO TO 240
33474 C .......... NOW BALANCE ..........
33475 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
33477 SCALE(I) = SCALE(I) * F
33481 AR(I,J) = AR(I,J) * G
33482 AI(I,J) = AI(I,J) * G
33486 AR(J,I) = AR(J,I) * F
33487 AI(J,I) = AI(J,I) * F
33492 IF (NOCONV) GO TO 190
33498 SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI)
33499 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
33501 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
33503 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
33504 S = DABS(BR) + DABS(BI)
33509 S = BRS**2 + BIS**2
33510 CR = (ARS*BRS + AIS*BIS)/S
33511 CI = (AIS*BRS - ARS*BIS)/S
33514 SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
33516 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
33517 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
33518 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
33521 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
33522 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
33524 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
33525 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
33526 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
33528 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
33529 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
33533 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33534 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33535 C DIMENSION STATEMENT.
33537 C N IS THE ORDER OF THE MATRIX.
33539 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
33540 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
33541 C SET LOW=1, IGH=N.
33543 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
33544 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
33545 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
33546 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
33547 C THE REDUCTION BY CORTH, IF PERFORMED.
33551 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
33552 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
33553 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
33554 C EIGENVECTORS IS TO BE PERFORMED.
33556 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33557 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
33558 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
33559 C FOR INDICES IERR+1,...,N.
33562 C ZERO FOR NORMAL RETURN,
33563 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
33564 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
33566 C CALLS CDIV FOR COMPLEX DIVISION.
33567 C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
33568 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
33570 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33571 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33573 C THIS VERSION DATED AUGUST 1983.
33575 C ------------------------------------------------------------------
33578 IF (LOW .EQ. IGH) GO TO 180
33579 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
33584 IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
33585 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
33586 YR = HR(I,I-1) / NORM
33587 YI = HI(I,I-1) / NORM
33592 SI = YR * HI(I,J) - YI * HR(I,J)
33593 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
33598 SI = YR * HI(J,I) + YI * HR(J,I)
33599 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
33604 C .......... STORE ROOTS ISOLATED BY CBAL ..........
33605 180 DO 200 I = 1, N
33606 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
33615 C .......... SEARCH FOR NEXT EIGENVALUE ..........
33616 220 IF (EN .LT. LOW) GO TO 1001
33619 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
33620 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
33621 240 DO 260 LL = LOW, EN
33623 IF (L .EQ. LOW) GO TO 300
33624 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
33625 X + DABS(HR(L,L)) + DABS(HI(L,L))
33626 TST2 = TST1 + DABS(HR(L,L-1))
33627 IF (TST2 .EQ. TST1) GO TO 300
33629 C .......... FORM SHIFT ..........
33630 300 IF (L .EQ. EN) GO TO 660
33631 IF (ITN .EQ. 0) GO TO 1000
33632 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
33635 XR = HR(ENM1,EN) * HR(EN,ENM1)
33636 XI = HI(ENM1,EN) * HR(EN,ENM1)
33637 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
33638 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
33639 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
33640 CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
33641 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
33644 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
33648 C .......... FORM EXCEPTIONAL SHIFT ..........
33649 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
33652 340 DO 360 I = LOW, EN
33653 HR(I,I) = HR(I,I) - SR
33654 HI(I,I) = HI(I,I) - SI
33661 C .......... REDUCE TO TRIANGLE (ROWS) ..........
33667 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
33668 XR = HR(I-1,I-1) / NORM
33670 XI = HI(I-1,I-1) / NORM
33673 HI(I-1,I-1) = 0.0D0
33674 HI(I,I-1) = SR / NORM
33681 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
33682 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
33683 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
33684 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
33690 IF (SI .EQ. 0.0D0) GO TO 540
33691 NORM = PYTHAG(HR(EN,EN),SI)
33692 SR = HR(EN,EN) / NORM
33696 C .......... INVERSE OPERATION (COLUMNS) ..........
33697 540 DO 600 J = LP1, EN
33706 IF (I .EQ. J) GO TO 560
33708 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
33709 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
33710 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
33711 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
33716 IF (SI .EQ. 0.0D0) GO TO 240
33721 HR(I,EN) = SR * YR - SI * YI
33722 HI(I,EN) = SR * YI + SI * YR
33726 C .......... A ROOT FOUND ..........
33727 660 WR(EN) = HR(EN,EN) + TR
33728 WI(EN) = HI(EN,EN) + TI
33731 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
33732 C CONVERGED AFTER 30*N ITERATIONS ..........
33736 SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
33737 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
33738 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
33740 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
33741 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
33742 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
33743 X ORTR(IGH),ORTI(IGH)
33744 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
33747 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
33748 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
33750 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
33751 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
33752 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
33754 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
33755 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
33756 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
33757 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
33758 C THIS GENERAL MATRIX TO HESSENBERG FORM.
33762 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33763 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33764 C DIMENSION STATEMENT.
33766 C N IS THE ORDER OF THE MATRIX.
33768 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
33769 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
33770 C SET LOW=1, IGH=N.
33772 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
33773 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
33774 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
33775 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
33776 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
33778 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
33779 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
33780 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
33781 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
33782 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
33783 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
33788 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
33789 C HAVE BEEN DESTROYED.
33791 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33792 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
33793 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
33794 C FOR INDICES IERR+1,...,N.
33796 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33797 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
33798 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
33799 C THE EIGENVECTORS HAS BEEN FOUND.
33802 C ZERO FOR NORMAL RETURN,
33803 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
33804 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
33806 C CALLS CDIV FOR COMPLEX DIVISION.
33807 C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
33808 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
33810 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33811 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33813 C THIS VERSION DATED OCTOBER 1989.
33815 C ------------------------------------------------------------------
33818 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
33827 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
33828 C FROM THE INFORMATION LEFT BY CORTH ..........
33829 IEND = IGH - LOW - 1
33830 IF (IEND) 180, 150, 105
33831 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
33832 105 DO 140 II = 1, IEND
33834 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140
33835 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140
33836 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
33837 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
33840 DO 110 K = IP1, IGH
33841 ORTR(K) = HR(K,I-1)
33842 ORTI(K) = HI(K,I-1)
33850 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
33851 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
33858 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
33859 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
33865 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
33870 IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
33871 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
33872 YR = HR(I,I-1) / NORM
33873 YI = HI(I,I-1) / NORM
33878 SI = YR * HI(I,J) - YI * HR(I,J)
33879 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
33884 SI = YR * HI(J,I) + YI * HR(J,I)
33885 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
33889 DO 165 J = LOW, IGH
33890 SI = YR * ZI(J,I) + YI * ZR(J,I)
33891 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
33896 C .......... STORE ROOTS ISOLATED BY CBAL ..........
33897 180 DO 200 I = 1, N
33898 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
33907 C .......... SEARCH FOR NEXT EIGENVALUE ..........
33908 220 IF (EN .LT. LOW) GO TO 680
33911 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
33912 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
33913 240 DO 260 LL = LOW, EN
33915 IF (L .EQ. LOW) GO TO 300
33916 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
33917 X + DABS(HR(L,L)) + DABS(HI(L,L))
33918 TST2 = TST1 + DABS(HR(L,L-1))
33919 IF (TST2 .EQ. TST1) GO TO 300
33921 C .......... FORM SHIFT ..........
33922 300 IF (L .EQ. EN) GO TO 660
33923 IF (ITN .EQ. 0) GO TO 1000
33924 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
33927 XR = HR(ENM1,EN) * HR(EN,ENM1)
33928 XI = HI(ENM1,EN) * HR(EN,ENM1)
33929 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
33930 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
33931 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
33932 CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
33933 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
33936 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
33940 C .......... FORM EXCEPTIONAL SHIFT ..........
33941 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
33944 340 DO 360 I = LOW, EN
33945 HR(I,I) = HR(I,I) - SR
33946 HI(I,I) = HI(I,I) - SI
33953 C .......... REDUCE TO TRIANGLE (ROWS) ..........
33959 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
33960 XR = HR(I-1,I-1) / NORM
33962 XI = HI(I-1,I-1) / NORM
33965 HI(I-1,I-1) = 0.0D0
33966 HI(I,I-1) = SR / NORM
33973 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
33974 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
33975 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
33976 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
33982 IF (SI .EQ. 0.0D0) GO TO 540
33983 NORM = PYTHAG(HR(EN,EN),SI)
33984 SR = HR(EN,EN) / NORM
33988 IF (EN .EQ. N) GO TO 540
33994 HR(EN,J) = SR * YR + SI * YI
33995 HI(EN,J) = SR * YI - SI * YR
33997 C .......... INVERSE OPERATION (COLUMNS) ..........
33998 540 DO 600 J = LP1, EN
34007 IF (I .EQ. J) GO TO 560
34009 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
34010 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
34011 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
34012 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
34015 DO 590 I = LOW, IGH
34020 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
34021 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
34022 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
34023 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
34028 IF (SI .EQ. 0.0D0) GO TO 240
34033 HR(I,EN) = SR * YR - SI * YI
34034 HI(I,EN) = SR * YI + SI * YR
34037 DO 640 I = LOW, IGH
34040 ZR(I,EN) = SR * YR - SI * YI
34041 ZI(I,EN) = SR * YI + SI * YR
34045 C .......... A ROOT FOUND ..........
34046 660 HR(EN,EN) = HR(EN,EN) + TR
34048 HI(EN,EN) = HI(EN,EN) + TI
34052 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
34053 C VECTORS OF UPPER TRIANGULAR FORM ..........
34059 TR = DABS(HR(I,J)) + DABS(HI(I,J))
34060 IF (TR .GT. NORM) NORM = TR
34063 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
34064 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
34072 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
34073 DO 780 II = 1, ENM1
34080 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
34081 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
34086 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
34089 760 YR = 0.01D0 * YR
34091 IF (TST2 .GT. TST1) GO TO 760
34093 CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
34094 C .......... OVERFLOW CONTROL ..........
34095 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
34096 IF (TR .EQ. 0.0D0) GO TO 780
34098 TST2 = TST1 + 1.0D0/TST1
34099 IF (TST2 .GT. TST1) GO TO 780
34101 HR(J,EN) = HR(J,EN)/TR
34102 HI(J,EN) = HI(J,EN)/TR
34108 C .......... END BACKSUBSTITUTION ..........
34109 C .......... VECTORS OF ISOLATED ROOTS ..........
34111 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
34119 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
34120 C VECTORS OF ORIGINAL FULL MATRIX.
34121 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
34126 DO 880 I = LOW, IGH
34131 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
34132 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
34140 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
34141 C CONVERGED AFTER 30*N ITERATIONS ..........
34145 SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
34147 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
34148 DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
34149 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
34151 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
34152 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
34153 C BY MARTIN AND WILKINSON.
34154 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
34156 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
34157 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
34158 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
34159 C UNITARY SIMILARITY TRANSFORMATIONS.
34163 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
34164 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
34165 C DIMENSION STATEMENT.
34167 C N IS THE ORDER OF THE MATRIX.
34169 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
34170 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
34171 C SET LOW=1, IGH=N.
34173 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
34174 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
34178 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
34179 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
34180 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
34181 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
34182 C HESSENBERG MATRIX.
34184 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
34185 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
34187 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
34189 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
34190 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
34192 C THIS VERSION DATED AUGUST 1983.
34194 C ------------------------------------------------------------------
34198 IF (LA .LT. KP1) GO TO 200
34205 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
34207 90 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
34209 IF (SCALE .EQ. 0.0D0) GO TO 180
34211 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
34214 ORTR(I) = AR(I,M-1) / SCALE
34215 ORTI(I) = AI(I,M-1) / SCALE
34216 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
34220 F = PYTHAG(ORTR(M),ORTI(M))
34221 IF (F .EQ. 0.0D0) GO TO 103
34224 ORTR(M) = (1.0D0 + G) * ORTR(M)
34225 ORTI(M) = (1.0D0 + G) * ORTI(M)
34230 C .......... FORM (I-(U*UT)/H) * A ..........
34231 105 DO 130 J = M, N
34234 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
34237 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
34238 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
34245 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
34246 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
34250 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
34254 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
34257 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
34258 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
34265 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
34266 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
34271 ORTR(M) = SCALE * ORTR(M)
34272 ORTI(M) = SCALE * ORTI(M)
34273 AR(M,M-1) = -G * AR(M,M-1)
34274 AI(M,M-1) = -G * AI(M,M-1)
34279 SUBROUTINE CSROOT(XR,XI,YR,YI)
34280 DOUBLE PRECISION XR,XI,YR,YI
34282 C (YR,YI) = COMPLEX DSQRT(XR,XI)
34283 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
34285 DOUBLE PRECISION S,TR,TI,PYTHAG
34288 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
34289 IF (TR .GE. 0.0D0) YR = S
34290 IF (TI .LT. 0.0D0) S = -S
34291 IF (TR .LE. 0.0D0) YI = S
34292 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
34293 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
34296 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
34297 DOUBLE PRECISION A,B
34299 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
34301 DOUBLE PRECISION P,R,S,T,U
34302 P = DMAX1(DABS(A),DABS(B))
34303 IF (P .EQ. 0.0D0) GO TO 20
34304 R = (DMIN1(DABS(A),DABS(B))/P)**2
34307 IF (T .EQ. 4.0D0) GO TO 20
34309 U = 1.0D0 + 2.0D0*S
34317 C*********************************************************************
34320 C...Calculates the three-body decay of gluinos into
34321 C...neutralinos and third generation fermions.
34323 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
34325 C...Double precision and integer declarations.
34326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34327 IMPLICIT INTEGER(I-N)
34328 INTEGER PYK,PYCHGE,PYCOMP
34329 C...Parameter statement to help give large particle numbers.
34330 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
34332 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34333 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34334 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34335 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34337 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
34339 C...Local variables.
34340 EXTERNAL PYSIMP,PYLAMF
34341 DOUBLE PRECISION PYSIMP,PYLAMF
34343 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
34344 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
34345 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
34346 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
34347 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
34348 DOUBLE PRECISION XLN1,XLN2,B1,B2
34349 DOUBLE PRECISION E,XMGLU,GAM
34350 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
34351 SAVE HRB,HLB,FLB,FRB
34352 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
34353 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
34354 SAVE HLT,HRT,FLT,FRT
34355 DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
34357 SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD
34358 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
34359 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
34361 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
34362 DOUBLE PRECISION ROT1(4,4)
34365 DATA IFIRST/.TRUE./
34368 SINB=TANB/SQRT(1D0+TANB**2)
34380 AMTOP=PYRNMT(PMAS(6,1))
34382 FAKT1=AMBOT/W2/AMW/COSB
34383 FAKT2=AMTOP/W2/AMW/SINB
34394 ROT1(2,1)=-ROT1(1,2)
34395 ROT1(2,2)=ROT1(1,1)
34398 ROT1(4,3)=-ROT1(3,4)
34399 ROT1(4,4)=ROT1(3,3)
34403 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
34408 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
34409 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
34410 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
34412 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
34413 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
34414 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
34415 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
34418 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
34419 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
34420 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
34421 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
34422 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
34423 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
34424 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
34428 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
34429 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
34430 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
34431 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
34435 IF(NINT(3D0*E).EQ.2) THEN
34442 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
34443 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
34452 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
34453 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
34459 SIN2D=SIND*COSD*2D0
34473 ALPHAW=PYALEM(XMG2)
34474 ALPHAS=PYALPS(XMG2)
34478 XM24=(XMG2+XM2)*(XM2+XMR2)
34480 SMAX=(XMG-ABS(XMR))**2
34481 XMQA=XMG2+2D0*XM2+XMR2
34483 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
34485 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
34487 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
34488 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
34489 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
34490 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
34491 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
34492 & +2D0*(FF*SIND2-HH*COSD2))*W
34493 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
34494 & +4D0*HFL*XM*XMR)*XLN1
34495 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
34496 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
34497 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
34498 & +8D0*HFL*XMQ4*SIN2D)*B1
34499 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
34500 & +4D0*HFR*XMR*XM)*XLN2
34501 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
34502 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
34503 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
34504 & -8D0*HFR*XMQ4*SIN2D)*B2
34505 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
34506 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
34507 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
34508 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
34509 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
34510 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
34511 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
34512 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
34513 G(5)=(2D0*(HH*COSD2-FF*SIND2)
34514 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
34515 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
34516 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
34517 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
34518 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
34519 & +COS2D*XM*(SBAR+XMG2-XMR2))
34520 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
34521 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
34522 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
34523 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
34524 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
34525 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
34526 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
34529 SUMME(LIN)=SUMME(LIN)+G(J)
34534 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
34535 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
34540 C*********************************************************************
34543 C...Calculates the three-body decay of gluinos into
34544 C...charginos and third generation fermions.
34546 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
34548 C...Double precision and integer declarations.
34549 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34550 IMPLICIT INTEGER(I-N)
34551 INTEGER PYK,PYCHGE,PYCOMP
34552 C...Parameter statement to help give large particle numbers.
34553 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
34555 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34556 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34557 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34558 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34560 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
34562 C...Local variables.
34563 EXTERNAL PYSIMP,PYLAMF
34564 DOUBLE PRECISION PYSIMP,PYLAMF
34566 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
34567 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
34568 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
34569 DOUBLE PRECISION SUMME(0:100),A(4,8)
34570 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
34571 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
34572 DOUBLE PRECISION XMGLU,GAM
34573 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
34574 &DDD(2),EEE(2),FFF(2)
34575 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
34576 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
34577 DOUBLE PRECISION AMC(2),AMN(4)
34579 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
34580 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
34582 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
34585 DATA IFIRST/.TRUE./
34588 SINB=TANB/SQRT(1D0+TANB**2)
34599 AMTOP=PYRNMT(PMAS(6,1))
34602 FAKT1=AMBOT/W2/AMW/COSB
34603 FAKT2=AMTOP/W2/AMW/SINB
34608 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
34609 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
34610 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
34611 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
34612 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
34613 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
34614 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
34615 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
34617 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
34618 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
34619 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
34620 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
34625 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
34626 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
34627 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
34628 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
34630 COS2A=COSA**2-SINA**2
34631 SIN2A=SINA*COSA*2D0
34632 COS2C=COSC**2-SINC**2
34633 SIN2C=SINC*COSC*2D0
34640 ALPHAW=PYALEM(XMG2)
34641 ALPHAS=PYALPS(XMG2)
34645 XMQ2=XMG2+XMT2+XMB2+XMR2
34646 XMQ4=XMG*XMT*XMB*XMR
34647 XMQ3=XMG2*XMR2+XMT2*XMB2
34648 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
34649 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
34651 XMST(1)=AMST(1)*AMST(1)
34652 XMST(2)=AMST(1)*AMST(1)
34653 XMST(3)=AMST(2)*AMST(2)
34654 XMST(4)=AMST(2)*AMST(2)
34655 XMSB(1)=AMSB(1)*AMSB(1)
34656 XMSB(2)=AMSB(2)*AMSB(2)
34657 XMSB(3)=AMSB(1)*AMSB(1)
34658 XMSB(4)=AMSB(2)*AMSB(2)
34660 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
34661 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
34662 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
34663 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
34664 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
34665 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
34666 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
34667 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
34669 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
34670 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
34671 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
34672 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
34673 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
34674 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
34675 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
34676 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
34678 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
34679 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
34680 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
34681 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
34682 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
34683 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
34684 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
34685 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
34687 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
34688 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
34689 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
34690 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
34691 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
34692 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
34693 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
34694 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
34696 SMAX=(XMG-ABS(XMR))**2
34697 SMIN=(XMB+XMT)**2+0.1D0
34700 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
34701 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
34703 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
34704 W=DSQRT(W)/2D0/SBAR
34705 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
34706 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
34707 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
34708 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
34709 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
34710 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
34711 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
34712 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
34713 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
34714 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
34715 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
34716 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
34717 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
34718 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
34719 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
34720 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
34721 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
34722 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
34723 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
34724 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
34725 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
34726 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
34727 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
34728 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
34729 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
34730 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
34731 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
34732 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
34733 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
34734 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
34735 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
34736 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
34737 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
34738 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
34739 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
34740 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
34741 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
34742 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
34743 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
34744 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
34745 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
34746 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
34747 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
34749 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
34750 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
34751 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
34752 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
34753 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
34754 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
34755 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
34756 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
34757 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
34758 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
34759 & -A(J,6)*(XMG2+XMR2-SBAR)
34760 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
34761 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
34762 & /(GRS+XMSB(J)+XMST(J))
34766 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
34767 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
34772 C*********************************************************************
34775 C...Calculates decay widths for the neutralinos (admixtures of
34776 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
34778 C...Input: KCIN = KF code for particle
34779 C...Output: XLAM = widths
34780 C... IDLAM = KF codes for decay particles
34781 C... IKNT = number of decay channels defined
34782 C...AUTHOR: STEPHEN MRENNA
34784 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
34785 C...when CHIGAMMA .NE. 0
34786 C...10 FEB 96: Calculate this decay for small tan(beta)
34788 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
34790 C...Double precision and integer declarations.
34791 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34792 IMPLICIT INTEGER(I-N)
34793 INTEGER PYK,PYCHGE,PYCOMP
34794 C...Parameter statement to help give large particle numbers.
34795 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
34797 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34798 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34799 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34800 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34802 COMMON/PYINTS/XXM(20)
34803 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
34805 C...Local variables.
34807 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
34808 &XMZ,XMZ2,AXMJ,AXMI
34809 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
34810 DOUBLE PRECISION S12MIN,S12MAX
34811 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
34812 DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
34813 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
34814 DOUBLE PRECISION PYX2XH,PYX2XG
34815 DOUBLE PRECISION XLAM(0:200)
34816 INTEGER IDLAM(200,3)
34817 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
34818 INTEGER ITH(3),KF1,KF2
34820 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
34821 DOUBLE PRECISION SR2
34822 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
34823 DOUBLE PRECISION GAMCON,XMT1,XMT2
34824 DOUBLE PRECISION PYALEM,PI,PYALPS
34825 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
34826 DOUBLE PRECISION RAT1,RAT2
34827 DOUBLE PRECISION T3T,CA,CB,FCOL
34828 DOUBLE PRECISION ALFA,BETA,TANB
34829 DOUBLE PRECISION PYXXGA
34830 EXTERNAL PYXXW5,PYGAUS,PYXXZ5
34831 DOUBLE PRECISION PYXXW5,PYGAUS,PYXXZ5
34832 DOUBLE PRECISION PREC
34833 INTEGER KFNCHI(4),KFCCHI(2)
34834 DATA ETAH/1D0,1D0,-1D0/
34838 DATA PI/3.141592654D0/
34839 DATA SR2/1.4142136D0/
34840 DATA KFNCHI/1000022,1000023,1000025,1000035/
34841 DATA KFCCHI/1000024,1000037/
34843 C...COUNT THE NUMBER OF DECAY MODES
34851 TANW = SQRT(XW/(1D0-XW))
34853 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
34856 IF(KFIN.EQ.KFNCHI(2)) IX=2
34857 IF(KFIN.EQ.KFNCHI(3)) IX=3
34858 IF(KFIN.EQ.KFNCHI(4)) IX=4
34876 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
34877 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 260
34879 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
34880 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
34884 GAMCON=AEM**3/8D0/PI/XMW2/XW
34885 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
34886 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
34887 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
34888 IDLAM(LKNT,1)=KSUSY1+22
34891 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
34895 C...GRAVITINO DECAY MODES
34897 IF(IMSS(11).EQ.1) THEN
34900 XMGR=PMAS(PYCOMP(IDG),1)
34903 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
34904 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
34909 XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2
34911 IF(AXMI.GT.XMGR+XMZ) THEN
34916 XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 +
34917 $ .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4
34919 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
34924 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)*
34925 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
34927 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
34932 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)*
34933 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
34935 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
34940 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)*
34941 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
34943 IF(IX.EQ.1) GOTO 260
34951 C...CHI0_I -> CHI0_J + GAMMA
34952 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
34953 RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2
34954 RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 )
34955 RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2
34956 RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 )
34957 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
34958 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
34960 IDLAM(LKNT,1)=KFNCHI(IJ)
34963 GAMCON=AEM**3/8D0/PI/XMW2/XW
34964 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
34965 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
34966 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
34970 C...CHI0_I -> CHI0_J + Z0
34971 IF(AXMI.GE.AXMJ+XMZ) THEN
34973 GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
34975 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
34976 IDLAM(LKNT,1)=KFNCHI(IJ)
34979 ELSEIF(AXMI.GE.AXMJ) THEN
34987 XXM(5)=PMAS(PYCOMP(KSUSY1+11),1)
34988 XXM(6)=PMAS(PYCOMP(KSUSY2+11),1)
34991 XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
34993 XXM(11)=(T3-EI*XW)/(1D0-XW)
34994 XXM(12)=-EI*XW/(1D0-XW)
34995 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
34996 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
34997 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
34998 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
35000 S12MAX=(AXMI-AXMJ)**2
35002 C...CHARGED LEPTONS
35003 IF( XXM(5).LT.AXMI ) THEN
35006 IF(XXM(6).LT.AXMI ) THEN
35009 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
35011 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35012 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35013 IDLAM(LKNT,1)=KFNCHI(IJ)
35016 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
35018 XLAM(LKNT)=XLAM(LKNT-1)
35019 IDLAM(LKNT,1)=KFNCHI(IJ)
35025 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
35026 XXM(5)=PMAS(PYCOMP(KSUSY1+15),1)
35027 XXM(6)=PMAS(PYCOMP(KSUSY2+15),1)
35029 XXM(6)=PMAS(PYCOMP(KSUSY1+15),1)
35030 XXM(5)=PMAS(PYCOMP(KSUSY2+15),1)
35032 IF( XXM(5).LT.AXMI ) THEN
35035 IF(XXM(6).LT.AXMI ) THEN
35039 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
35041 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35042 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35043 IDLAM(LKNT,1)=KFNCHI(IJ)
35053 XXM(5)=PMAS(PYCOMP(KSUSY1+12),1)
35055 XXM(11)=(T3-EI*XW)/(1D0-XW)
35056 XXM(12)=-EI*XW/(1D0-XW)
35057 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
35058 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
35059 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
35060 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
35062 IF( XXM(5).LT.AXMI ) THEN
35067 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35068 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35069 IDLAM(LKNT,1)=KFNCHI(IJ)
35073 XLAM(LKNT)=XLAM(LKNT-1)
35074 IDLAM(LKNT,1)=KFNCHI(IJ)
35078 XXM(5)=PMAS(PYCOMP(KSUSY1+16),1)
35079 IF( XXM(5).LT.AXMI ) THEN
35083 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35084 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35085 IDLAM(LKNT,1)=KFNCHI(IJ)
35091 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
35092 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
35097 XXM(11)=(T3-EI*XW)/(1D0-XW)
35098 XXM(12)=-EI*XW/(1D0-XW)
35099 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
35100 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
35101 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
35102 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
35104 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140
35105 IF( XXM(5).LT.AXMI ) THEN
35107 ELSEIF( XXM(6).LT.AXMI ) THEN
35110 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35112 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35113 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
35114 IDLAM(LKNT,1)=KFNCHI(IJ)
35117 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35119 XLAM(LKNT)=XLAM(LKNT-1)
35120 IDLAM(LKNT,1)=KFNCHI(IJ)
35126 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
35127 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
35128 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
35130 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
35131 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
35133 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150
35134 IF(XXM(5).LT.AXMI) THEN
35136 ELSEIF(XXM(6).LT.AXMI) THEN
35139 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35141 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35142 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
35143 IDLAM(LKNT,1)=KFNCHI(IJ)
35150 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
35151 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
35156 XXM(11)=(T3-EI*XW)/(1D0-XW)
35157 XXM(12)=-EI*XW/(1D0-XW)
35158 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
35159 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
35160 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
35161 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
35163 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160
35164 IF(XXM(5).LT.AXMI) THEN
35166 ELSEIF(XXM(6).LT.AXMI) THEN
35169 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35171 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35172 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
35173 IDLAM(LKNT,1)=KFNCHI(IJ)
35176 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35178 XLAM(LKNT)=XLAM(LKNT-1)
35179 IDLAM(LKNT,1)=KFNCHI(IJ)
35187 C...CHI0_I -> CHI0_J + H0_K
35195 QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)-
35196 & TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1))
35197 RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)-
35198 & TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1))
35201 XMH=PMAS(ITH(IH),1)
35203 IF(AXMI.GE.AXMJ+XMH) THEN
35205 XL=PYLAMF(XMI2,XMJ2,XMH2)
35206 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
35208 C...SIGN OF MASSES I,J
35210 IF(IH.EQ.3) XMK=-XMK
35211 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
35212 IDLAM(LKNT,1)=KFNCHI(IJ)
35213 IDLAM(LKNT,2)=ITH(IH)
35219 C...CHI0_I -> CHI+_J + W-
35224 IF(AXMI.GE.AXMJ+XMW) THEN
35226 GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
35227 GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
35228 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
35229 IDLAM(LKNT,1)=KFCCHI(IJ)
35233 XLAM(LKNT)=XLAM(LKNT-1)
35234 IDLAM(LKNT,1)=-KFCCHI(IJ)
35237 ELSEIF(AXMI.GE.AXMJ) THEN
35239 S12MAX=(AXMI-AXMJ)**2
35240 XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
35241 XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
35247 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
35251 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
35259 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
35260 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
35261 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190
35262 IF(XXM(11).LT.AXMI) THEN
35264 ELSEIF(XXM(12).LT.AXMI) THEN
35267 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
35269 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35270 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35271 IDLAM(LKNT,1)=KFCCHI(IJ)
35275 XLAM(LKNT)=XLAM(LKNT-1)
35276 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35277 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35278 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35279 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
35281 XLAM(LKNT)=XLAM(LKNT-1)
35282 IDLAM(LKNT,1)=KFCCHI(IJ)
35286 XLAM(LKNT)=XLAM(LKNT-1)
35287 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35288 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35289 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35293 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
35294 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
35295 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
35297 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
35298 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
35301 IF(XXM(11).LT.AXMI) THEN
35304 IF(XXM(12).LT.AXMI) THEN
35307 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
35309 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35310 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35311 XLAM(LKNT)=XLAM(LKNT-1)
35312 IDLAM(LKNT,1)=KFCCHI(IJ)
35316 XLAM(LKNT)=XLAM(LKNT-1)
35317 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35318 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35319 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35322 C...NOW, DO THE QUARKS
35327 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
35331 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
35333 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
35334 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
35335 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210
35336 IF(XXM(11).LT.AXMI) THEN
35338 ELSEIF(XXM(12).LT.AXMI) THEN
35341 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
35343 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
35344 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35345 IDLAM(LKNT,1)=KFCCHI(IJ)
35349 XLAM(LKNT)=XLAM(LKNT-1)
35350 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35351 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35352 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35353 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
35355 XLAM(LKNT)=XLAM(LKNT-1)
35356 IDLAM(LKNT,1)=KFCCHI(IJ)
35360 XLAM(LKNT)=XLAM(LKNT-1)
35361 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35362 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35363 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35371 C...CHI0_I -> CHI+_I + H-
35378 IF(AXMI.GE.AXMJ+XMHP) THEN
35380 GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+
35381 & ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2)
35382 GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+
35383 & ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2)
35384 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
35385 IDLAM(LKNT,1)=KFCCHI(IJ)
35386 IDLAM(LKNT,2)=-ITHC
35389 XLAM(LKNT)=XLAM(LKNT-1)
35390 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35391 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35392 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35398 C...2-BODY DECAYS TO FERMION SFERMION
35400 IF(J.GE.7.AND.J.LE.10) GOTO 250
35403 XMSF1=PMAS(PYCOMP(KF1),1)
35404 XMSF2=PMAS(PYCOMP(KF2),1)
35414 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
35415 IF(MOD(J,2).EQ.0) THEN
35416 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
35417 AL=XMF*ZMIX(IX,4)/XMW/SBETA
35418 AR=-2D0*EI*TANW*ZMIX(IX,1)
35421 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
35422 AL=XMF*ZMIX(IX,3)/XMW/CBETA
35423 AR=-2D0*EI*TANW*ZMIX(IX,1)
35428 IF(AXMI.GE.XMF+XMSF1) THEN
35432 XL=PYLAMF(XMI2,XMA2,XMB2)
35433 CA=AL*SFMIX(J,1)+AR*SFMIX(J,2)
35434 CB=BL*SFMIX(J,1)+BR*SFMIX(J,2)
35435 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
35436 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
35441 XLAM(LKNT)=XLAM(LKNT-1)
35442 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35443 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35448 IF(AXMI.GE.XMF+XMSF2) THEN
35452 CA=AL*SFMIX(J,3)+AR*SFMIX(J,4)
35453 CB=BL*SFMIX(J,3)+BR*SFMIX(J,4)
35454 XL=PYLAMF(XMI2,XMA2,XMB2)
35455 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
35456 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
35461 XLAM(LKNT)=XLAM(LKNT-1)
35462 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35463 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35468 C...3-BODY DECAY TO Q Q~ GLUINO
35469 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
35470 IF(AXMI.GE.XMJ) THEN
35476 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
35477 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
35483 S12MAX=(AXMI-AXMJ)**2
35484 C...ALL QUARKS BUT T
35488 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
35490 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
35491 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270
35492 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35494 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
35495 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35496 IDLAM(LKNT,1)=KSUSY1+21
35499 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35501 XLAM(LKNT)=XLAM(LKNT-1)
35502 IDLAM(LKNT,1)=KSUSY1+21
35508 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
35509 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
35510 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
35512 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
35513 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
35515 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280
35516 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35518 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
35519 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35520 IDLAM(LKNT,1)=KSUSY1+21
35526 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
35527 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
35529 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
35531 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
35532 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 290
35533 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35535 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
35536 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35537 IDLAM(LKNT,1)=KSUSY1+21
35540 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35542 XLAM(LKNT)=XLAM(LKNT-1)
35543 IDLAM(LKNT,1)=KSUSY1+21
35554 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
35555 XLAM(0)=XLAM(0)+XLAM(I)
35557 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
35562 C*********************************************************************
35565 C...Calculate decay widths for the charginos (admixtures of
35566 C...charged Wino and charged Higgsino.
35568 C...Input: KCIN = KF code for particle
35569 C...Output: XLAM = widths
35570 C... IDLAM = KF codes for decay particles
35571 C... IKNT = number of decay channels defined
35572 C...AUTHOR: STEPHEN MRENNA
35574 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
35575 C...when CHIENU .NE. 0
35577 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
35579 C...Double precision and integer declarations.
35580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35581 IMPLICIT INTEGER(I-N)
35582 INTEGER PYK,PYCHGE,PYCOMP
35583 C...Parameter statement to help give large particle numbers.
35584 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
35586 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35587 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35588 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35589 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35591 COMMON/PYINTS/XXM(20)
35592 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
35594 C...Local variables.
35596 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
35597 &XMZ,XMZ2,AXMJ,AXMI
35598 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
35599 DOUBLE PRECISION S12MIN,S12MAX
35600 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
35601 DOUBLE PRECISION PYLAMF,XL
35602 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
35603 DOUBLE PRECISION PYX2XH,PYX2XG
35604 DOUBLE PRECISION XLAM(0:200)
35605 INTEGER IDLAM(200,3)
35606 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
35609 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
35610 DOUBLE PRECISION SR2
35611 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
35613 DOUBLE PRECISION PYALEM,PI,PYALPS
35614 DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
35615 DOUBLE PRECISION CA,CB,FCOL
35616 INTEGER KF1,KF2,ISF
35617 INTEGER KFNCHI(4),KFCCHI(2)
35619 DOUBLE PRECISION TEMP
35620 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
35621 DOUBLE PRECISION PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
35622 DOUBLE PRECISION PREC
35625 DATA ETAH/1D0,1D0,-1D0/
35626 DATA SR2/1.4142136D0/
35627 DATA PI/3.141592654D0/
35629 DATA KFNCHI/1000022,1000023,1000025,1000035/
35630 DATA KFCCHI/1000024,1000037/
35632 C...COUNT THE NUMBER OF DECAY MODES
35639 TANW = SQRT(XW/(1D0-XW))
35641 C...1 OR 2 DEPENDING ON CHARGINO TYPE
35643 IF(KFIN.EQ.KFCCHI(2)) IX=2
35659 C...GRAVITINO DECAY MODES
35661 IF(IMSS(11).EQ.1) THEN
35664 XMGR=PMAS(PYCOMP(IDG),1)
35667 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
35668 IF(AXMI.GT.XMGR+XMW) THEN
35673 XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+
35674 & .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))*
35675 & (1D0-XMW2/XMI2)**4
35677 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
35682 XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+
35683 & (UMIX(IX,2)*SBETA)**2))
35684 & *(1D0-PMAS(37,1)**2/XMI2)**4
35688 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
35689 IF(IX.EQ.1) GOTO 150
35694 C...CHI_2+ -> CHI_1+ + Z0
35695 IF(AXMI.GE.AXMJ+XMZ) THEN
35697 GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)
35698 GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)
35699 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
35700 IDLAM(LKNT,1)=KFCCHI(1)
35704 C...CHARGED LEPTONS
35705 ELSEIF(AXMI.GE.AXMJ) THEN
35706 XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2))
35707 XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2))
35715 S12MAX=(AXMJ-AXMI)**2
35716 XXM(7)= (-0.5D0+XW)/(1D0-XW)
35717 XXM(8)= XW/(1D0-XW)
35718 XXM(11)=PMAS(PYCOMP(KSUSY1+12),1)
35719 XXM(12)=VMIX(2,1)*VMIX(1,1)
35720 IF( XXM(11).LT.AXMI ) THEN
35723 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
35725 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35726 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
35727 IDLAM(LKNT,1)=KFCCHI(1)
35730 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
35732 XLAM(LKNT)=XLAM(LKNT-1)
35733 IDLAM(LKNT,1)=KFCCHI(1)
35736 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
35738 XLAM(LKNT)=XLAM(LKNT-1)
35739 IDLAM(LKNT,1)=KFCCHI(1)
35748 XXM(7)= (0.5D0)/(1D0-XW)
35750 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
35751 XXM(12)=UMIX(2,1)*UMIX(1,1)
35752 IF( XXM(11).LT.AXMI ) THEN
35755 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
35757 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35758 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
35759 IDLAM(LKNT,1)=KFCCHI(1)
35763 XLAM(LKNT)=XLAM(LKNT-1)
35764 IDLAM(LKNT,1)=KFCCHI(1)
35768 XLAM(LKNT)=XLAM(LKNT-1)
35769 IDLAM(LKNT,1)=KFCCHI(1)
35776 XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW)
35777 XXM(8)= XW/3D0/(1D0-XW)
35778 XXM(11)=PMAS(PYCOMP(KSUSY1+2),1)
35779 XXM(12)=VMIX(2,1)*VMIX(1,1)
35780 IF( XXM(11).LT.AXMI ) GOTO 120
35781 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35783 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
35784 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
35785 IDLAM(LKNT,1)=KFCCHI(1)
35788 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35790 XLAM(LKNT)=XLAM(LKNT-1)
35791 IDLAM(LKNT,1)=KFCCHI(1)
35794 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35796 XLAM(LKNT)=XLAM(LKNT-1)
35797 IDLAM(LKNT,1)=KFCCHI(1)
35806 XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW)
35807 XXM(8)= -2D0*XW/3D0/(1D0-XW)
35808 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
35809 XXM(12)=UMIX(2,1)*UMIX(1,1)
35810 IF( XXM(11).LT.AXMI ) GOTO 130
35811 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35813 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
35814 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
35815 IDLAM(LKNT,1)=KFCCHI(1)
35818 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35820 XLAM(LKNT)=XLAM(LKNT-1)
35821 IDLAM(LKNT,1)=KFCCHI(1)
35829 C...CHI_2+ -> CHI_1+ + H0_K
35837 XMH=PMAS(ITH(IH),1)
35839 C...NO 3-BODY OPTION
35840 IF(AXMI.GE.AXMJ+XMH) THEN
35842 XL=PYLAMF(XMI2,XMJ2,XMH2)
35843 F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) -
35844 & VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2
35845 F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) -
35846 & VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2
35848 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
35849 IDLAM(LKNT,1)=KFCCHI(1)
35850 IDLAM(LKNT,2)=ITH(IH)
35855 C...CHI1 JUMPS TO HERE
35858 C...CHI+_I -> CHI0_J + W+
35863 IF(AXMI.GE.AXMJ+XMW) THEN
35865 GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2
35866 GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2
35867 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
35868 IDLAM(LKNT,1)=KFNCHI(IJ)
35873 ELSEIF(AXMI.GE.AXMJ) THEN
35876 S12MIN=(XMF1+XMF2)**2
35877 S12MAX=(AXMJ-AXMI)**2
35878 XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1)
35879 XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1)
35883 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
35887 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
35895 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
35896 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
35898 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
35899 C...--> 1/(16PI)/M**3*(AEM/XW)**2
35901 IF(XXM(11).LT.AXMI) THEN
35904 IF(XXM(12).LT.AXMI) THEN
35907 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
35909 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35910 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
35911 IDLAM(LKNT,1)=KFNCHI(IJ)
35915 C...ONLY DECAY CHI+1 -> E+ NU_E
35916 IF( IMSS(12).NE. 0 ) GOTO 220
35917 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
35919 XXM(11)=PMAS(PYCOMP(KSUSY1+13),1)
35920 XXM(12)=PMAS(PYCOMP(KSUSY1+14),1)
35921 IF(XXM(11).LT.AXMI) THEN
35923 ELSEIF(XXM(12).LT.AXMI) THEN
35926 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35927 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
35928 IDLAM(LKNT,1)=KFNCHI(IJ)
35931 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
35933 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
35934 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
35936 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
35938 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
35939 IF(XXM(11).LT.AXMI) THEN
35942 IF(XXM(12).LT.AXMI) THEN
35945 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35946 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
35947 IDLAM(LKNT,1)=KFNCHI(IJ)
35954 C...NOW, DO THE QUARKS
35959 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
35963 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
35965 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
35966 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
35967 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170
35968 IF(XXM(11).LT.AXMI) THEN
35970 ELSEIF(XXM(12).LT.AXMI) THEN
35973 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
35975 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
35976 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35977 IDLAM(LKNT,1)=KFNCHI(IJ)
35980 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
35982 XLAM(LKNT)=XLAM(LKNT-1)
35983 IDLAM(LKNT,1)=KFNCHI(IJ)
35992 C...CHI+_I -> CHI0_J + H+
35999 IF(AXMI.GE.AXMJ+XMHP) THEN
36001 GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+
36002 & ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2)
36003 GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+
36004 & ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2)
36005 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
36006 IDLAM(LKNT,1)=KFNCHI(IJ)
36014 C...2-BODY DECAYS TO FERMION SFERMION
36016 IF(J.GE.7.AND.J.LE.10) GOTO 200
36017 IF(MOD(J,2).EQ.0) THEN
36023 XMSF1=PMAS(PYCOMP(KF1),1)
36024 XMSF2=PMAS(PYCOMP(KF2),1)
36033 IF(MOD(J,2).EQ.0) THEN
36036 BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2
36037 AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2
36043 BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2
36045 AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2
36050 IF(AXMI.GE.XMF+XMSF1) THEN
36054 XL=PYLAMF(XMI2,XMA2,XMB2)
36055 CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2)
36056 CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2)
36057 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36058 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
36060 IF(MOD(J,2).EQ.0) THEN
36070 IF(AXMI.GE.XMF+XMSF2) THEN
36074 CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4)
36075 CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4)
36076 XL=PYLAMF(XMI2,XMA2,XMB2)
36077 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36078 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
36080 IF(MOD(J,2).EQ.0) THEN
36090 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
36091 C...A 2-BODY -- 2-BODY CHAIN
36092 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36093 IF(AXMI.GE.XMJ) THEN
36096 S12MAX=(AXMI-AXMJ)**2
36105 XXM(7)=UMIX(IX,1)*SR2
36106 XXM(8)=VMIX(IX,1)*SR2
36107 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
36108 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
36109 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210
36110 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
36112 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
36113 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
36114 IDLAM(LKNT,1)=KSUSY1+21
36117 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36119 XLAM(LKNT)=XLAM(LKNT-1)
36120 IDLAM(LKNT,1)=KSUSY1+21
36131 XLAM(0)=XLAM(0)+XLAM(I)
36132 IF(XLAM(I).LT.0D0) THEN
36133 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
36134 & (IDLAM(I,J),J=1,3)
36138 IF(XLAM(0).EQ.0D0) THEN
36140 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
36141 WRITE(MSTU(11),*) LKNT
36142 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
36148 C*********************************************************************
36151 C...Calculates chi0 -> chi0 + f + ~f.
36155 C...Double precision and integer declarations.
36156 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36157 IMPLICIT INTEGER(I-N)
36158 INTEGER PYK,PYCHGE,PYCOMP
36159 C...Parameter statement to help give large particle numbers.
36160 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
36162 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36163 COMMON/PYINTS/XXM(20)
36164 SAVE /PYDAT1/,/PYINTS/
36166 C...Local variables.
36167 DOUBLE PRECISION PYXXZ5,X
36168 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
36169 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
36170 DOUBLE PRECISION SIJ
36171 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
36172 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
36173 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36175 DATA SR2/1.4142136D0/
36177 C...Statement functions.
36178 C...Integral from x to y of (t-a)(b-t) dt.
36179 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
36180 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36181 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
36182 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
36183 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36184 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
36185 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
36186 C...Integral from x to y of (t-a)/(b-t) dt.
36187 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
36188 C...Integral from x to y of 1/(t-a) dt.
36189 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
36197 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
36198 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
36199 &( (X-XM22-S)**2 -4D0*XM22*S ) )
36201 S23MIN=(S23AVE-S23DEL)
36202 S23MAX=(S23AVE+S23DEL)
36221 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
36222 SIJ=2D0*XXM(2)*XXM(4)*S13
36224 IF(XMV.LE.1000D0) THEN
36225 WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S)
36226 & +SIJ*(S23MAX-S23MIN) )/WPROP2
36227 IF(XXM(5).LE.10000D0) THEN
36228 WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
36229 & + SIJ*TPROP(S23MAX,S23MIN,XMSD) )
36230 WFL1=WFL1*(S13-XMV**2)/WPROP2
36234 IF(XXM(6).LE.10000D0) THEN
36235 WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
36236 & + SIJ*TPROP(S23MAX,S23MIN,XMSU) )
36237 WFL2=WFL2*(S13-XMV**2)/WPROP2
36246 IF(XXM(5).LE.10000D0) THEN
36247 WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
36248 & + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) )
36252 IF(XXM(6).LE.10000D0) THEN
36253 WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
36254 & + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) )
36261 PYXXZ5=(WW+WF1+WF2+WFL1+WFL2)
36262 IF(PYXXZ5.LT.0D0) THEN
36263 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 '
36264 WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4)
36265 WRITE(MSTU(11),*) (XXM(I),I=5,8)
36266 WRITE(MSTU(11),*) (XXM(I),I=9,12)
36267 WRITE(MSTU(11),*) (XXM(I),I=13,16)
36268 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
36269 WRITE(MSTU(11),*) S23MIN,S23MAX
36276 C*********************************************************************
36279 C...Calculates chi0(+) -> chi+(0) + f + ~f'.
36283 C...Double precision and integer declarations.
36284 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36285 IMPLICIT INTEGER(I-N)
36286 INTEGER PYK,PYCHGE,PYCOMP
36287 C...Parameter statement to help give large particle numbers.
36288 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
36290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36291 COMMON/PYINTS/XXM(20)
36292 SAVE /PYDAT1/,/PYINTS/
36294 C...Local variables.
36295 DOUBLE PRECISION PYXXW5,X
36296 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
36297 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
36298 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
36299 DOUBLE PRECISION SIJ
36300 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36304 DATA SR2/1.4142136D0/
36306 C...Statement functions.
36307 C...Integral from x to y of (t-a)(b-t) dt.
36308 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
36309 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36310 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
36311 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
36312 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36313 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
36314 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
36315 C...Integral from x to y of (t-a)/(b-t) dt.
36316 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
36317 C...Integral from x to y of 1/(t-a) dt.
36318 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
36325 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
36326 S23AVE=0.5D0*(XM22+S-S13)
36327 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
36329 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
36330 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
36331 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
36333 S23MIN=(S23AVE-S23DEL)
36334 S23MAX=(S23AVE+S23DEL)
36335 IF(S23DEL.LT.1D-3) THEN
36348 WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2)
36349 SIJ=S13*XXM(2)*XXM(4)
36350 IF(XMV.LE.1000D0) THEN
36351 WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S)
36352 & -2D0*OL*OR*SIJ*(S23MAX-S23MIN)
36354 IF(XXM(11).LE.10000D0) THEN
36355 WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD)
36356 & -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
36358 WWD=WWD*(S13-XMV**2)/WPROP2
36362 IF(XXM(12).LE.10000D0) THEN
36363 WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU)
36364 & -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
36366 WWU=WWU*(S13-XMV**2)/WPROP2
36375 IF(XXM(12).LE.10000D0) THEN
36376 WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
36380 IF(XXM(11).LE.10000D0) THEN
36381 WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
36385 IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN
36386 WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU)
36391 PYXXW5=WW+WU+WD+WWU+WWD+WUD
36393 IF(PYXXW5.LT.0D0) THEN
36395 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 '
36396 WRITE(MSTU(11),*) WW,WU,WD
36397 WRITE(MSTU(11),*) WWD,WWU,WUD
36398 WRITE(MSTU(11),*) SQRT(S13)
36399 WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S)
36408 C*********************************************************************
36411 C...Calculates chi0_i -> chi0_j + gamma.
36413 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
36415 C...Double precision and integer declarations.
36416 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36417 IMPLICIT INTEGER(I-N)
36418 INTEGER PYK,PYCHGE,PYCOMP
36420 C...Local variables.
36421 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
36422 DOUBLE PRECISION F1,F2
36424 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
36425 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
36426 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
36427 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
36432 C*********************************************************************
36435 C...Calculates the decay rate for ino -> ino + gauge boson.
36437 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
36439 C...Double precision and integer declarations.
36440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36441 IMPLICIT INTEGER(I-N)
36442 INTEGER PYK,PYCHGE,PYCOMP
36444 C...Local variables.
36445 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
36446 DOUBLE PRECISION XL,PYLAMF,C1
36447 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
36453 XL=PYLAMF(XMI2,XMJ2,XMV2)
36454 PYX2XG=C1/8D0/XMI3*SQRT(XL)
36455 &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
36456 &12D0*GL*GR*XM1*XM2*XMV2)
36461 C*********************************************************************
36464 C...Calculates the decay rate for ino -> ino + H.
36466 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR)
36468 C...Double precision and integer declarations.
36469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36470 IMPLICIT INTEGER(I-N)
36471 INTEGER PYK,PYCHGE,PYCOMP
36473 C...Local variables.
36474 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
36475 DOUBLE PRECISION XL,PYLAMF,C1
36476 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
36482 XL=PYLAMF(XMI2,XMJ2,XMV2)
36483 PYX2XH=C1/8D0/XMI3*SQRT(XL)
36484 &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+
36485 &4D0*GL*GR*XM1*XM2)
36490 C*********************************************************************
36493 C...Calculates chi+ -> chi+ + f + ~f.
36497 C...Double precision and integer declarations.
36498 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36499 IMPLICIT INTEGER(I-N)
36500 INTEGER PYK,PYCHGE,PYCOMP
36501 C...Parameter statement to help give large particle numbers.
36502 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
36504 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36505 COMMON/PYINTS/XXM(20)
36506 SAVE /PYDAT1/,/PYINTS/
36508 C...Local variables.
36509 DOUBLE PRECISION PYXXZ2,X
36510 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
36511 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
36512 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
36513 DOUBLE PRECISION SIJ
36514 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
36515 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36517 DATA SR2/1.4142136D0/
36519 C...Statement functions.
36520 C...Integral from x to y of (t-a)(b-t) dt.
36521 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
36522 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36523 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
36524 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
36525 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36526 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
36527 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
36528 C...Integral from x to y of 1/(t-a) dt.
36529 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
36536 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
36537 S23AVE=0.5D0*(XM22+S-S13)
36538 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
36540 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
36541 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
36542 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
36544 S23MIN=(S23AVE-S23DEL)
36545 S23MAX=(S23AVE+S23DEL)
36546 IF(S23DEL.LT.1D-3) THEN
36564 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
36565 SIJ=XXM(2)*XXM(4)*S13
36566 WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S)
36567 &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN)
36569 IF(XMSL.GT.1D4*S) THEN
36573 WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL)
36574 WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)-
36575 & OR*SIJ*TPROP(S23MAX,S23MIN,XMSL)
36576 WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2
36580 IF(PYXXZ2.LT.0D0) THEN
36581 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 '
36582 WRITE(MSTU(11),*) WW,WD,WWD
36583 WRITE(MSTU(11),*) S23MIN,S23MAX
36584 WRITE(MSTU(11),*) (XXM(I),I=1,4)
36585 WRITE(MSTU(11),*) (XXM(I),I=5,8)
36586 WRITE(MSTU(11),*) (XXM(I),I=9,12)
36593 C*********************************************************************
36596 C...Calculates the non-standard decay modes of the Higgs boson.
36598 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
36600 C...Double precision and integer declarations.
36601 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36602 IMPLICIT INTEGER(I-N)
36603 INTEGER PYK,PYCHGE,PYCOMP
36604 C...Parameter statement to help give large particle numbers.
36605 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
36607 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36608 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36609 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36610 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36611 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36613 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
36615 C...Local variables.
36617 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
36618 &XMZ,XMZ2,AXMJ,AXMI
36619 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
36620 DOUBLE PRECISION S12MIN,S12MAX
36621 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
36622 DOUBLE PRECISION PYLAMF,XL,CF,EI
36623 INTEGER IDU,IC,ILR,IFL
36624 DOUBLE PRECISION TANW,XW,AEM,C1,AS
36625 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
36626 DOUBLE PRECISION XLAM(0:200)
36627 INTEGER IDLAM(200,3)
36628 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
36630 INTEGER KFNCHI(4),KFCCHI(2)
36631 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
36632 DOUBLE PRECISION SR2
36633 DOUBLE PRECISION BETA,ALFA
36634 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
36635 DOUBLE PRECISION PYALEM,PI,PYALPS
36636 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
36637 DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
36638 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
36639 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
36640 DATA ITH/25,35,36,37/
36641 DATA ETAH/1D0,1D0,-1D0/
36642 DATA SR2/1.4142136D0/
36643 DATA PI/3.141592654D0/
36644 DATA KFNCHI/1000022,1000023,1000025,1000035/
36645 DATA KFCCHI/1000024,1000037/
36647 C...COUNT THE NUMBER OF DECAY MODES
36655 TANW = SQRT(XW/(1D0-XW))
36658 C...1 - 4 DEPENDING ON Higgs species.
36660 IF(KFIN.EQ.ITH(2)) IH=2
36661 IF(KFIN.EQ.ITH(3)) IH=3
36662 IF(KFIN.EQ.ITH(4)) IH=4
36684 IF(IH.EQ.4) GOTO 180
36686 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
36687 C...H0_K -> CHI0_I + CHI0_J
36700 IF(AXMI.GE.AXMJ+AXMK) THEN
36703 & EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2)
36704 & -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+
36705 & 0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2)
36706 & -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) )
36708 & EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2)
36709 & -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+
36710 & 0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2)
36711 & -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) )
36712 C...SIGN OF MASSES I,J
36714 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
36715 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
36716 IDLAM(LKNT,1)=KFNCHI(IJ)
36717 IDLAM(LKNT,2)=KFNCHI(IK)
36723 C...H0_K -> CHI+_I CHI-_J
36730 IF(AXMI.GE.AXMJ+AXMK) THEN
36732 F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) -
36733 & VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2
36734 F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) -
36735 & VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2
36737 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
36738 IDLAM(LKNT,1)=KFCCHI(IJ)
36739 IDLAM(LKNT,2)=-KFCCHI(IK)
36745 C...HIGGS TO SFERMION SFERMION
36747 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160
36749 XMJL=PMAS(PYCOMP(IJ),1)
36750 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
36751 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
36754 XL=PYLAMF(XMI2,XMJ2,XMJ2)
36761 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
36762 & XMF**2/XMW*SINA/CBETA
36763 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
36764 & XMF**2/XMW*SINA/CBETA
36766 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
36768 ELSEIF(IFL.EQ.15) THEN
36769 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
36775 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
36776 & XMF**2/XMW*COSA/SBETA
36777 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
36778 & XMF**2/XMW*COSA/SBETA
36780 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
36787 ELSEIF(IH.EQ.2) THEN
36789 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
36790 & XMF**2/XMW*COSA/CBETA
36791 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
36792 & XMF**2/XMW*COSA/CBETA
36794 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
36796 ELSEIF(IFL.EQ.15) THEN
36797 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
36803 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
36804 & XMF**2/XMW*SINA/SBETA
36805 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
36806 & XMF**2/XMW*SINA/SBETA
36808 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
36815 ELSEIF(IH.EQ.3) THEN
36821 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
36822 ELSEIF(IFL.EQ.15) THEN
36823 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
36827 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
36831 IF(IH.EQ.3) GOTO 140
36835 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
36842 IF(AXMI.GE.2D0*XMJ) THEN
36844 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36846 & +2D0*GHLR*ALR)**2
36852 IF(AXMI.GE.2D0*XMJR) THEN
36856 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
36859 XL=PYLAMF(XMI2,XMJ2,XMJ2)
36860 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36862 & +2D0*GHLR*ALR)**2
36863 IDLAM(LKNT,1)=IJ+KSUSY1
36864 IDLAM(LKNT,2)=-(IJ+KSUSY1)
36869 IF(AXMI.GE.XMJL+XMJR) THEN
36871 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
36872 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
36873 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
36876 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
36877 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36878 & (GHLL*AL+GHRR*AR)**2
36880 IDLAM(LKNT,2)=-(IJ+KSUSY1)
36884 IDLAM(LKNT,2)=IJ+KSUSY1
36886 XLAM(LKNT)=XLAM(LKNT-1)
36896 C...H+ -> CHI+_I + CHI0_J
36905 IF(AXMI.GE.AXMJ+AXMK) THEN
36907 GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)*
36908 & TANW)*VMIX(IK,2)/SR2)
36909 GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)*
36910 & TANW)*UMIX(IK,2)/SR2)
36911 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR)
36912 IDLAM(LKNT,1)=KFNCHI(IJ)
36913 IDLAM(LKNT,2)=KFCCHI(IK)
36919 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
36920 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
36926 XM1=PMAS(PYCOMP(KSUSY1+6),1)
36927 XM2=PMAS(PYCOMP(KSUSY1+5),1)
36928 IF(XMI.GE.XM1+XM2) THEN
36929 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36931 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36932 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
36933 IDLAM(LKNT,1)=KSUSY1+6
36934 IDLAM(LKNT,2)=-(KSUSY1+5)
36939 XM1=PMAS(PYCOMP(KSUSY2+6),1)
36940 XM2=PMAS(PYCOMP(KSUSY1+5),1)
36941 IF(XMI.GE.XM1+XM2) THEN
36942 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36944 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36945 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
36946 IDLAM(LKNT,1)=KSUSY2+6
36947 IDLAM(LKNT,2)=-(KSUSY1+5)
36952 XM1=PMAS(PYCOMP(KSUSY1+6),1)
36953 XM2=PMAS(PYCOMP(KSUSY2+5),1)
36954 IF(XMI.GE.XM1+XM2) THEN
36955 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36957 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36958 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
36959 IDLAM(LKNT,1)=KSUSY1+6
36960 IDLAM(LKNT,2)=-(KSUSY2+5)
36965 XM1=PMAS(PYCOMP(KSUSY2+6),1)
36966 XM2=PMAS(PYCOMP(KSUSY2+5),1)
36967 IF(XMI.GE.XM1+XM2) THEN
36968 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36970 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36971 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
36972 IDLAM(LKNT,1)=KSUSY2+6
36973 IDLAM(LKNT,2)=-(KSUSY2+5)
36978 GL=-XMW/SR2*SIN(2D0*BETA)
36980 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
36981 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
36982 IF(XMI.GE.XM1+XM2) THEN
36983 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36985 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
36986 IDLAM(LKNT,1)=-(KSUSY1+IJ)
36987 IDLAM(LKNT,2)=KSUSY1+IJ+1
36995 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
36996 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
36997 IF(XMI.GE.XM1+XM2) THEN
36998 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37000 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
37001 IDLAM(LKNT,1)=-(KSUSY1+IJ)
37002 IDLAM(LKNT,2)=KSUSY1+IJ+1
37007 C...H+ -> TAU1 NUTAUL
37008 XM1=PMAS(PYCOMP(KSUSY1+15),1)
37009 XM2=PMAS(PYCOMP(KSUSY1+16),1)
37010 IF(XMI.GE.XM1+XM2) THEN
37011 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37013 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2
37014 IDLAM(LKNT,1)=-(KSUSY1+15)
37015 IDLAM(LKNT,2)= KSUSY1+16
37019 C...H+ -> TAU2 NUTAUL
37020 XM1=PMAS(PYCOMP(KSUSY2+15),1)
37021 XM2=PMAS(PYCOMP(KSUSY1+16),1)
37022 IF(XMI.GE.XM1+XM2) THEN
37023 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37025 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2
37026 IDLAM(LKNT,1)=-(KSUSY2+15)
37027 IDLAM(LKNT,2)= KSUSY1+16
37035 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
37036 XLAM(0)=XLAM(0)+XLAM(I)
37038 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
37043 C*********************************************************************
37046 C...Calculates the decay rate for a Higgs to an ino pair.
37048 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR)
37050 C...Double precision and integer declarations.
37051 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37052 IMPLICIT INTEGER(I-N)
37053 INTEGER PYK,PYCHGE,PYCOMP
37055 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37058 C...Local variables.
37059 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
37060 DOUBLE PRECISION XL,PYLAMF,C1
37061 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
37067 XL=PYLAMF(XMI2,XMJ2,XMK2)
37068 PYH2XX=C1/4D0/XMI3*SQRT(XL)
37069 &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)-
37070 &4D0*GL*GR*XM3*XM2)
37071 IF(PYH2XX.LT.0D0) THEN
37072 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
37073 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3
37080 C*********************************************************************
37083 C...Integration by adaptive Gaussian quadrature.
37084 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
37086 FUNCTION PYGAUS(F, A, B, EPS)
37088 C...Double precision and integer declarations.
37089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37090 IMPLICIT INTEGER(I-N)
37091 INTEGER PYK,PYCHGE,PYCOMP
37093 C...Local declarations.
37095 DOUBLE PRECISION F,W(12), X(12)
37096 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
37097 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
37098 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
37099 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
37100 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
37101 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
37102 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
37103 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
37104 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
37105 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
37106 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
37107 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
37109 C...The Gaussian quadrature algorithm.
37111 IF(B .EQ. A) GO TO 140
37112 CONST = 5D-3 / ABS(B-A)
37123 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
37128 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
37131 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
37133 IF(BB .NE. B) GO TO 100
37136 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110
37138 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
37147 C*********************************************************************
37150 C...Simpson formula for an integral.
37152 FUNCTION PYSIMP(Y,X0,X1,N)
37154 C...Double precision and integer declarations.
37155 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37156 IMPLICIT INTEGER(I-N)
37157 INTEGER PYK,PYCHGE,PYCOMP
37159 C...Local variables.
37160 DOUBLE PRECISION Y,X0,X1,H,S
37166 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
37173 C*********************************************************************
37176 C...The standard lambda function.
37178 FUNCTION PYLAMF(X,Y,Z)
37180 C...Double precision and integer declarations.
37181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37182 IMPLICIT INTEGER(I-N)
37183 INTEGER PYK,PYCHGE,PYCOMP
37185 C...Local variables.
37186 DOUBLE PRECISION PYLAMF,X,Y,Z
37188 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
37189 IF(PYLAMF.LT.0D0) PYLAMF=0D0
37194 C*********************************************************************
37197 C...Generates 3-body decays of gauginos.
37199 SUBROUTINE PYTBDY(XM)
37201 C...Double precision and integer declarations.
37202 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37203 IMPLICIT INTEGER(I-N)
37204 INTEGER PYK,PYCHGE,PYCOMP
37205 C...Parameter statement to help give large particle numbers.
37206 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
37208 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37209 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37210 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37211 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
37212 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37213 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/
37215 C...Local variables.
37216 DOUBLE PRECISION XM(5)
37217 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
37218 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
37219 DOUBLE PRECISION CPHI1,SPHI1
37220 DOUBLE PRECISION S23DEL,EPS
37221 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
37222 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
37223 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
37227 S12MIN=(XM(1)+XM(2))**2
37228 S12MAX=(XM(5)-XM(3))**2
37229 YJACO1=S12MAX-S12MIN
37234 BX=S12MIN+0.5D0*YJACO1
37237 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
37245 C...SOLVE FOR F1 AND F2
37246 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
37247 &-(2D0*XM(1)*XM(2))**2
37248 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
37249 &-(2D0*XM(3)*XM(5))**2
37252 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
37254 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
37255 &-(2D0*XM(1)*XM(2))**2
37256 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
37257 &-(2D0*XM(3)*XM(5))**2
37260 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
37263 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
37269 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
37270 & -(2D0*XM(1)*XM(2))**2
37271 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
37272 & -(2D0*XM(3)*XM(5))**2
37275 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
37282 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
37283 & -(2D0*XM(1)*XM(2))**2
37284 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
37285 & -(2D0*XM(3)*XM(5))**2
37288 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
37293 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
37303 110 S12=S12MIN+PYR(0)*YJACO1
37306 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
37307 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
37308 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
37309 &-(2D0*XM(1)*XM(2))**2
37310 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
37311 &-(2D0*XM(3)*XM(5))**2
37314 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12)
37316 S23MIN=S23AVE-S23DEL
37317 S23MAX=S23AVE+S23DEL
37318 YJACO2=S23MAX-S23MIN
37319 S23=S23MIN+PYR(0)*YJACO2
37321 C...CHECK THE SAMPLING
37322 IF(IKNT.GT.100) THEN
37323 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
37326 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110
37327 120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
37328 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
37330 P1=SQRT(D1*D1-XM(1)**2)
37331 P2=SQRT(D2*D2-XM(2)**2)
37332 P3=SQRT(D3*D3-XM(3)**2)
37333 CTHE1=2D0*PYR(0)-1D0
37334 ANG1=2D0*PYR(0)*PARU(1)
37338 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
37340 P(N+1,1)=P1*STHE1*CPHI1
37341 P(N+1,2)=P1*STHE1*SPHI1
37346 ANG3=2D0*PYR(0)*PARU(1)
37349 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
37351 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
37353 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
37354 &+P3*STHE3*SPHI3*SPHI1
37355 &+P3*CTHE3*STHE1*CPHI1
37356 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
37357 &-P3*STHE3*SPHI3*CPHI1
37358 &+P3*CTHE3*STHE1*SPHI1
37359 P(N+3,3)=P3*STHE3*CPHI3*STHE1
37364 P(N+2,I)=-P(N+1,I)-P(N+3,I)
37371 C*********************************************************************
37374 C...Stores one parton/particle in commonblock PYJETS.
37376 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
37378 C...Double precision and integer declarations.
37379 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37380 IMPLICIT INTEGER(I-N)
37381 INTEGER PYK,PYCHGE,PYCOMP
37383 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37384 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37385 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37386 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37388 C...Standard checks.
37390 IF(MSTU(12).GE.1) CALL PYLIST(0)
37391 IPA=MAX(1,IABS(IP))
37392 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
37393 &'(PY1ENT:) writing outside PYJETS memory')
37395 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
37397 C...Find mass. Reset K, P and V vectors.
37399 IF(MSTU(10).EQ.1) PM=P(IPA,5)
37400 IF(MSTU(10).GE.2) PM=PYMASS(KF)
37407 C...Store parton/particle in K and P vectors.
37409 IF(IP.LT.0) K(IPA,1)=2
37412 P(IPA,4)=MAX(PE,PM)
37413 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
37414 P(IPA,1)=PA*SIN(THE)*COS(PHI)
37415 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
37416 P(IPA,3)=PA*COS(THE)
37418 C...Set N. Optionally fragment/decay.
37420 IF(IP.EQ.0) CALL PYEXEC
37425 C*********************************************************************
37428 C...Stores two partons/particles in their CM frame,
37429 C...with the first along the +z axis.
37431 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
37433 C...Double precision and integer declarations.
37434 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37435 IMPLICIT INTEGER(I-N)
37436 INTEGER PYK,PYCHGE,PYCOMP
37438 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37439 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37440 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37441 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37443 C...Standard checks.
37445 IF(MSTU(12).GE.1) CALL PYLIST(0)
37446 IPA=MAX(1,IABS(IP))
37447 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
37448 &'(PY2ENT:) writing outside PYJETS memory')
37451 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
37452 &'(PY2ENT:) unknown flavour code')
37454 C...Find masses. Reset K, P and V vectors.
37456 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
37457 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
37459 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
37460 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
37469 C...Check flavours.
37470 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
37471 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
37472 IF(MSTU(19).EQ.1) THEN
37475 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
37476 & '(PY2ENT:) unphysical flavour combination')
37481 C...Store partons/particles in K vectors for normal case.
37484 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
37487 C...Store partons in K vectors for parton shower evolution.
37491 K(IPA,4)=MSTU(5)*(IPA+1)
37493 K(IPA+1,4)=MSTU(5)*IPA
37494 K(IPA+1,5)=K(IPA+1,4)
37497 C...Check kinematics and store partons/particles in P vectors.
37498 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
37499 &'(PY2ENT:) energy smaller than sum of masses')
37500 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
37503 P(IPA,4)=SQRT(PM1**2+PA**2)
37506 P(IPA+1,4)=SQRT(PM2**2+PA**2)
37509 C...Set N. Optionally fragment/decay.
37511 IF(IP.EQ.0) CALL PYEXEC
37516 C*********************************************************************
37519 C...Stores three partons or particles in their CM frame,
37520 C...with the first along the +z axis and the third in the (x,z)
37521 C...plane with x > 0.
37523 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
37525 C...Double precision and integer declarations.
37526 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37527 IMPLICIT INTEGER(I-N)
37528 INTEGER PYK,PYCHGE,PYCOMP
37530 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37531 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37532 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37533 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37535 C...Standard checks.
37537 IF(MSTU(12).GE.1) CALL PYLIST(0)
37538 IPA=MAX(1,IABS(IP))
37539 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
37540 &'(PY3ENT:) writing outside PYJETS memory')
37544 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
37545 &'(PY3ENT:) unknown flavour code')
37547 C...Find masses. Reset K, P and V vectors.
37549 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
37550 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
37552 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
37553 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
37555 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
37556 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
37565 C...Check flavours.
37566 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
37567 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
37568 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
37569 IF(MSTU(19).EQ.1) THEN
37571 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
37572 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
37573 & KQ1+KQ3.EQ.4)) THEN
37575 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
37581 C...Store partons/particles in K vectors for normal case.
37584 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
37586 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
37589 C...Store partons in K vectors for parton shower evolution.
37595 IF(KQ1.EQ.-1) KCS=5
37596 K(IPA,KCS)=MSTU(5)*(IPA+1)
37597 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
37598 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
37599 K(IPA+1,9-KCS)=MSTU(5)*IPA
37600 K(IPA+2,KCS)=MSTU(5)*IPA
37601 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
37604 C...Check kinematics.
37606 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
37607 &0.5D0*X3*PECM.LE.PM3) MKERR=1
37608 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
37609 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
37610 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
37611 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
37612 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
37613 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
37614 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
37615 IF(MKERR.NE.0) CALL PYERRM(13,
37616 &'(PY3ENT:) unphysical kinematical variable setup')
37618 C...Store partons/particles in P vectors.
37620 P(IPA,4)=SQRT(PA1**2+PM1**2)
37622 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
37623 P(IPA+2,3)=PA3*CTHE3
37624 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
37626 P(IPA+1,1)=-P(IPA+2,1)
37627 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
37628 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
37631 C...Set N. Optionally fragment/decay.
37633 IF(IP.EQ.0) CALL PYEXEC
37638 C*********************************************************************
37641 C...Stores four partons or particles in their CM frame, with
37642 C...the first along the +z axis, the last in the xz plane with x > 0
37643 C...and the second having y < 0 and y > 0 with equal probability.
37645 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
37647 C...Double precision and integer declarations.
37648 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37649 IMPLICIT INTEGER(I-N)
37650 INTEGER PYK,PYCHGE,PYCOMP
37652 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37653 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37654 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37655 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37657 C...Standard checks.
37659 IF(MSTU(12).GE.1) CALL PYLIST(0)
37660 IPA=MAX(1,IABS(IP))
37661 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
37662 &'(PY4ENT:) writing outside PYJETS momory')
37667 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
37668 &'(PY4ENT:) unknown flavour code')
37670 C...Find masses. Reset K, P and V vectors.
37672 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
37673 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
37675 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
37676 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
37678 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
37679 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
37681 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
37682 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
37691 C...Check flavours.
37692 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
37693 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
37694 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
37695 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
37696 IF(MSTU(19).EQ.1) THEN
37698 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
37699 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
37700 & KQ1+KQ4.EQ.4)) THEN
37701 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
37704 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
37711 C...Store partons/particles in K vectors for normal case.
37714 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
37716 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
37719 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
37722 C...Store partons for parton shower evolution from q-g-g-qbar or
37724 ELSEIF(KQ1+KQ2.NE.0) THEN
37730 IF(KQ1.EQ.-1) KCS=5
37731 K(IPA,KCS)=MSTU(5)*(IPA+1)
37732 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
37733 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
37734 K(IPA+1,9-KCS)=MSTU(5)*IPA
37735 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
37736 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
37737 K(IPA+3,KCS)=MSTU(5)*IPA
37738 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
37740 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
37746 K(IPA,4)=MSTU(5)*(IPA+1)
37748 K(IPA+1,4)=MSTU(5)*IPA
37749 K(IPA+1,5)=K(IPA+1,4)
37750 K(IPA+2,4)=MSTU(5)*(IPA+3)
37751 K(IPA+2,5)=K(IPA+2,4)
37752 K(IPA+3,4)=MSTU(5)*(IPA+2)
37753 K(IPA+3,5)=K(IPA+3,4)
37756 C...Check kinematics.
37758 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
37759 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
37761 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
37762 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
37763 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
37764 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
37765 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
37766 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
37767 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
37768 STHE4=SQRT(1D0-CTHE4**2)
37769 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
37770 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
37771 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
37772 STHE2=SQRT(1D0-CTHE2**2)
37773 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
37774 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
37775 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
37776 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
37777 IF(MKERR.EQ.1) CALL PYERRM(13,
37778 &'(PY4ENT:) unphysical kinematical variable setup')
37780 C...Store partons/particles in P vectors.
37782 P(IPA,4)=SQRT(PA1**2+PM1**2)
37784 P(IPA+3,1)=PA4*STHE4
37785 P(IPA+3,3)=PA4*CTHE4
37786 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
37788 P(IPA+1,1)=PA2*STHE2*CPHI2
37789 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
37790 P(IPA+1,3)=PA2*CTHE2
37791 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
37793 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
37794 P(IPA+2,2)=-P(IPA+1,2)
37795 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
37796 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
37799 C...Set N. Optionally fragment/decay.
37801 IF(IP.EQ.0) CALL PYEXEC
37806 C*********************************************************************
37809 C...An interface from a two-fermion generator to include
37810 C...parton showers and hadronization.
37812 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
37814 C...Double precision and integer declarations.
37815 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37816 IMPLICIT INTEGER(I-N)
37817 INTEGER PYK,PYCHGE,PYCOMP
37819 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37820 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37821 SAVE /PYJETS/,/PYDAT1/
37823 DIMENSION IJOIN(2),INTAU(2)
37825 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
37831 C...Loop through entries and pick up all final fermions/antifermions.
37835 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
37837 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
37838 IF(K(I,2).GT.0) THEN
37842 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
37848 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
37854 C...Check that event is arranged according to conventions.
37855 IF(I1.EQ.0.OR.I2.EQ.0) THEN
37856 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
37859 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
37862 C...Check whether fermion pair is quarks or leptons.
37863 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
37865 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
37868 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
37871 C...Decide whether to allow or not photon radiation in showers.
37873 IF(IRAD.EQ.0) MSTJ(41)=1
37875 C...Do colour joining and parton showers.
37878 IF(IQL12.EQ.1) THEN
37881 CALL PYJOIN(2,IJOIN)
37883 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
37884 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
37885 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
37886 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
37889 C...Do fragmentation and decays. Possibly except tau decay.
37893 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
37907 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
37915 C*********************************************************************
37918 C...An interface from a four-fermion generator to include
37919 C...parton showers and hadronization.
37921 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
37923 C...Double precision and integer declarations.
37924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37925 IMPLICIT INTEGER(I-N)
37926 INTEGER PYK,PYCHGE,PYCOMP
37928 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37929 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37930 SAVE /PYJETS/,/PYDAT1/
37932 DIMENSION IJOIN(2),INTAU(4)
37934 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
37940 C...Loop through entries and pick up all final fermions/antifermions.
37946 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
37948 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
37949 IF(K(I,2).GT.0) THEN
37952 ELSEIF(I3.EQ.0) THEN
37955 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
37960 ELSEIF(I4.EQ.0) THEN
37963 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
37969 C...Check that event is arranged according to conventions.
37970 IF(I3.EQ.0.OR.I4.EQ.0) THEN
37971 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
37973 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
37974 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
37977 C...Check which fermion pairs are quarks and which leptons.
37978 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
37980 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
37983 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
37985 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
37987 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
37990 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
37993 C...Decide whether to allow or not photon radiation in showers.
37995 IF(IRAD.EQ.0) MSTJ(41)=1
37997 C...Decide on dipole pairing.
38002 IF(IQL12.EQ.IQL34) THEN
38005 DELTA=ATOTSQ-A1SQ-A2SQ
38006 IF(ISTRAT.EQ.1) THEN
38007 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
38008 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
38009 ELSEIF(ISTRAT.EQ.2) THEN
38010 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
38011 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
38013 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
38019 C...Do colour joinings and parton showers.
38020 IF(IQL12.EQ.1) THEN
38023 CALL PYJOIN(2,IJOIN)
38025 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
38026 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
38027 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
38028 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
38030 IF(IQL34.EQ.1) THEN
38033 CALL PYJOIN(2,IJOIN)
38035 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
38036 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
38037 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
38038 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
38041 C...Do fragmentation and decays. Possibly except tau decay.
38045 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
38059 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38067 C*********************************************************************
38070 C...An interface from a six-fermion generator to include
38071 C...parton showers and hadronization.
38073 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
38075 C...Double precision and integer declarations.
38076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38077 IMPLICIT INTEGER(I-N)
38078 INTEGER PYK,PYCHGE,PYCOMP
38080 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38082 SAVE /PYJETS/,/PYDAT1/
38084 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
38086 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
38092 C...Loop through entries and pick up all final fermions/antifermions.
38100 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
38102 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
38103 IF(K(I,2).GT.0) THEN
38106 ELSEIF(I3.EQ.0) THEN
38108 ELSEIF(I5.EQ.0) THEN
38111 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
38116 ELSEIF(I4.EQ.0) THEN
38118 ELSEIF(I6.EQ.0) THEN
38121 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
38127 C...Check that event is arranged according to conventions.
38128 IF(I5.EQ.0.OR.I6.EQ.0) THEN
38129 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
38131 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
38132 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
38135 C...Check which fermion pairs are quarks and which leptons.
38136 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
38138 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
38141 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
38143 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
38145 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
38148 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
38150 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
38152 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
38155 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
38158 C...Decide whether to allow or not photon radiation in showers.
38160 IF(IRAD.EQ.0) MSTJ(41)=1
38162 C...Allow dipole pairings only among leptons and quarks separately.
38165 IF(IQL34.EQ.IQL56) P13D=P13
38167 IF(IQL12.EQ.IQL34) P21D=P21
38169 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
38171 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
38173 IF(IQL12.EQ.IQL56) P32D=P32
38175 C...Decide whether t+tbar.
38177 IF(PYR(0).LT.PTOP) THEN
38180 C...If t+tbar: reconstruct t's.
38186 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
38187 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
38195 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
38197 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
38201 C...If t+tbar: colour join t's and let them shower.
38204 CALL PYJOIN(2,IJOIN)
38205 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
38206 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
38207 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
38209 C...If t+tbar: pick up the t's after shower.
38213 IF(K(I,2).EQ.6) ITNEW=I
38214 IF(K(I,2).EQ.-6) ITBNEW=I
38217 C...If t+tbar: loop over two top systems.
38232 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
38233 & '(PY6FRM:) not b in t decay')
38235 C...If t+tbar: find boost from original to new top frame.
38237 BETAO(J)=P(ITO,J)/P(ITO,4)
38238 BETAN(J)=P(ITN,J)/P(ITN,4)
38241 C...If t+tbar: boost copy of b by t shower and connect it in colour.
38251 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
38252 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
38253 K(IB,4)=MSTU(5)*ITN
38254 K(IB,5)=MSTU(5)*ITN
38255 K(ITN,4)=K(ITN,4)+IB
38256 K(ITN,5)=K(ITN,5)+IB
38257 K(ITN,1)=K(ITN,1)+10
38258 K(IBO,1)=K(IBO,1)+10
38260 C...If t+tbar: construct W recoiling against b.
38268 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
38269 IF(IABS(KCHW).EQ.3) THEN
38270 K(IW,2)=ISIGN(24,KCHW)
38272 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
38276 C...If t+tbar: construct W momentum, including boost by t shower.
38278 P(IW,J)=P(IW1,J)+P(IW2,J)
38280 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
38282 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
38283 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
38285 C...If t+tbar: boost b and W to top rest frame.
38287 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
38289 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38290 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38292 C...If t+tbar: let b shower and pick up modified W.
38293 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
38294 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
38295 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
38297 IF(IABS(K(I,2)).EQ.24) IWM=I
38300 C...If t+tbar: take copy of W decay products.
38309 K(IW1,1)=K(IW1,1)+10
38310 K(IW2,1)=K(IW2,1)+10
38311 K(IWM,1)=K(IWM,1)+10
38325 C...If t+tbar: boost W decay products, first by effects of t shower,
38326 C...then by those of b shower. b and its shower simple boost back.
38327 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
38328 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
38329 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38330 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
38331 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
38332 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
38333 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
38334 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
38335 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
38339 C...Decide on dipole pairing.
38343 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
38344 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
38348 ELSEIF(PRN.LT.P12D+P13D) THEN
38352 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
38356 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
38360 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
38370 C...Do colour joinings and parton showers
38371 C...(except ones already made for t+tbar).
38373 IF(IQL12.EQ.1) THEN
38376 CALL PYJOIN(2,IJOIN)
38378 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
38379 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
38380 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
38381 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
38384 IF(IQL34.EQ.1) THEN
38387 CALL PYJOIN(2,IJOIN)
38389 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
38390 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
38391 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
38392 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
38394 IF(IQL56.EQ.1) THEN
38397 CALL PYJOIN(2,IJOIN)
38399 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
38400 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
38401 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
38402 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
38405 C...Do fragmentation and decays. Possibly except tau decay.
38409 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
38423 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38431 C*********************************************************************
38434 C...An interface from a four-parton generator to include
38435 C...parton showers and hadronization.
38437 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
38439 C...Double precision and integer declarations.
38440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38441 IMPLICIT INTEGER(I-N)
38442 INTEGER PYK,PYCHGE,PYCOMP
38444 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38445 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38446 SAVE /PYJETS/,/PYDAT1/
38448 DIMENSION IJOIN(2),PTOT(4),BETA(3)
38450 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
38456 C...Loop through entries and pick up all final partons.
38462 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
38464 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
38465 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
38468 ELSEIF(I3.EQ.0) THEN
38471 CALL PYERRM(16,'(PY4JET:) more than two quarks')
38473 ELSEIF(K(I,2).LT.0) THEN
38476 ELSEIF(I4.EQ.0) THEN
38479 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
38484 ELSEIF(I4.EQ.0) THEN
38487 CALL PYERRM(16,'(PY4JET:) more than two gluons')
38493 C...Check that event is arranged according to conventions.
38494 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
38495 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
38497 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
38498 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
38501 C...Check whether second pair are quarks or gluons.
38502 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
38504 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
38507 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
38510 C...Boost partons to their cm frame.
38512 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
38514 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
38516 BETA(J)=PTOT(J)/PTOT(4)
38518 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38519 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38520 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38521 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38524 C...Decide and set up shower history for q qbar q' qbar' events.
38525 IF(IQG34.EQ.1) THEN
38526 W1=PY4JTW(0,I1,I3,I4)
38527 W2=PY4JTW(0,I2,I3,I4)
38528 IF(W1.GT.PYR(0)*(W1+W2)) THEN
38529 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
38531 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
38534 C...Decide and set up shower history for q qbar g g events.
38536 W1=PY4JTW(I1,I3,I2,I4)
38537 W2=PY4JTW(I1,I4,I2,I3)
38538 W3=PY4JTW(0,I3,I1,I4)
38539 W4=PY4JTW(0,I4,I1,I3)
38540 W5=PY4JTW(0,I3,I2,I4)
38541 W6=PY4JTW(0,I4,I2,I3)
38542 W7=PY4JTW(0,I1,I3,I4)
38543 W8=PY4JTW(0,I2,I3,I4)
38544 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
38546 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
38547 ELSEIF(W1+W2.GT.WR) THEN
38548 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
38549 ELSEIF(W1+W2+W3.GT.WR) THEN
38550 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
38551 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
38552 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
38553 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
38554 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
38555 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
38556 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
38557 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
38558 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
38560 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
38564 C...Boost back original partons and mark them as deleted.
38565 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
38566 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
38567 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
38568 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
38574 C...Rotate shower initiating partons to be along z axis.
38575 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
38576 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
38577 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
38578 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
38580 C...Set up copy of shower initiating partons as on mass shell.
38590 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
38601 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
38602 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
38604 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
38606 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
38609 C...Decide whether to allow or not photon radiation in showers.
38610 C...Connect up colours.
38612 IF(IRAD.EQ.0) MSTJ(41)=1
38615 CALL PYJOIN(2,IJOIN)
38617 C...Decide on maximum virtuality and do parton shower.
38618 IF(PMAX.LT.PARJ(82)) THEN
38623 CALL PYSHOW(NSAV+1,-8,PQMAX)
38625 C...Rotate and boost back system.
38626 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
38628 C...Do fragmentation and decays.
38631 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38640 C*********************************************************************
38643 C...Auxiliary to PY4JET, to evaluate weight of configuration.
38645 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
38647 C...Double precision and integer declarations.
38648 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38649 IMPLICIT INTEGER(I-N)
38650 INTEGER PYK,PYCHGE,PYCOMP
38652 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38655 C...First case: when both original partons radiate.
38656 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
38659 P(N+1,J)=P(IA1,J)+P(IA2,J)
38660 P(N+2,J)=P(IA3,J)+P(IA4,J)
38662 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38664 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
38666 Z1=P(IA1,4)/P(N+1,4)
38667 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
38668 Z2=P(IA3,4)/P(N+2,4)
38669 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
38671 C...Second case: when one original parton radiates to three.
38672 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
38675 P(N+2,J)=P(IA3,J)+P(IA4,J)
38676 P(N+1,J)=P(N+2,J)+P(IA2,J)
38678 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38680 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
38682 IF(K(IA2,2).EQ.21) THEN
38683 Z1=P(N+2,4)/P(N+1,4)
38684 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
38687 Z1=P(IA2,4)/P(N+1,4)
38688 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
38691 Z2=P(IA3,4)/P(N+2,4)
38692 IF(K(IA2,2).EQ.21) THEN
38693 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
38695 ELSEIF(K(IA3,2).EQ.21) THEN
38696 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
38698 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
38708 C*********************************************************************
38711 C...Auxiliary to PY4JET, to set up chosen configuration.
38713 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
38715 C...Double precision and integer declarations.
38716 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38717 IMPLICIT INTEGER(I-N)
38718 INTEGER PYK,PYCHGE,PYCOMP
38720 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38732 C...First case: when both original partons radiate.
38733 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
38736 C...Set up flavour and history pointers for new partons.
38754 C...Set up momenta for new partons.
38756 P(N+1,J)=P(IA1,J)+P(IA2,J)
38757 P(N+2,J)=P(IA3,J)+P(IA4,J)
38763 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38765 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
38767 QMAX=MIN(P(N+1,5),P(N+2,5))
38769 C...Second case: q radiates twice.
38770 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
38771 C...IA5=N+2 does not radiate.
38772 ELSEIF(K(IA2,2).EQ.21) THEN
38774 C...Set up flavour and history pointers for new partons.
38792 C...Set up momenta for new partons.
38794 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
38796 P(N+3,J)=P(IA3,J)+P(IA4,J)
38801 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38803 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
38807 C...Third case: q radiates g, g branches.
38808 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
38809 C...IA5=N+2 does not radiate.
38812 C...Set up flavour and history pointers for new partons.
38830 C...Set up momenta for new partons.
38832 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
38835 P(N+4,J)=P(IA3,J)+P(IA4,J)
38839 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38841 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
38851 C*********************************************************************
38854 C...Connects a sequence of partons with colour flow indices,
38855 C...as required for subsequent shower evolution (or other operations).
38857 SUBROUTINE PYJOIN(NJOIN,IJOIN)
38859 C...Double precision and integer declarations.
38860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38861 IMPLICIT INTEGER(I-N)
38862 INTEGER PYK,PYCHGE,PYCOMP
38864 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38865 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38866 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38867 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
38871 C...Check that partons are of right types to be connected.
38872 IF(NJOIN.LT.2) GOTO 120
38876 IF(I.LE.0.OR.I.GT.N) GOTO 120
38877 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
38879 IF(KC.EQ.0) GOTO 120
38880 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
38881 IF(KQ.EQ.0) GOTO 120
38882 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
38883 IF(KQ.NE.2) KQSUM=KQSUM+KQ
38884 IF(IJN.EQ.1) KQS=KQ
38886 IF(KQSUM.NE.0) GOTO 120
38888 C...Connect the partons sequentially (closing for gluon loop).
38890 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
38894 IF(IJN.NE.1) IP=IJOIN(IJN-1)
38895 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
38896 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
38897 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
38898 K(I,KCS)=MSTU(5)*IN
38899 K(I,9-KCS)=MSTU(5)*IP
38900 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
38901 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
38904 C...Error exit: no action taken.
38906 120 CALL PYERRM(12,
38907 &'(PYJOIN:) given entries can not be joined by one string')
38912 C*********************************************************************
38915 C...Sets values of commonblock variables.
38917 SUBROUTINE PYGIVE(CHIN)
38919 C...Double precision and integer declarations.
38920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38921 IMPLICIT INTEGER(I-N)
38922 INTEGER PYK,PYCHGE,PYCOMP
38924 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38926 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38927 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38928 COMMON/PYDAT4/CHAF(500,2)
38930 COMMON/PYDATR/MRPY(6),RRPY(100)
38931 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
38932 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38933 COMMON/PYINT1/MINT(400),VINT(400)
38934 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
38935 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
38936 COMMON/PYINT4/MWID(500),WIDS(500,5)
38937 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
38938 COMMON/PYINT6/PROC(0:500)
38940 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
38941 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38943 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
38944 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
38945 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
38946 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/
38947 C...Local arrays and character variables.
38948 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
38949 &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10,
38951 DIMENSION MSVAR(49,8)
38953 C...For each variable to be translated give: name,
38954 C...integer/real/character, no. of indices, lower&upper index bounds.
38955 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
38956 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
38957 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
38958 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
38959 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
38960 &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
38961 DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
38962 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
38963 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
38964 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
38965 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
38966 &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
38967 &1,1,1,6,4*0, 2,1,1,100,4*0,
38968 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
38969 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
38970 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
38971 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
38972 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
38973 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
38974 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
38975 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
38976 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
38977 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
38978 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
38980 C...Length of character variable. Subdivide it into instructions.
38981 IF(MSTU(12).GE.1) CALL PYLIST(0)
38985 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
38988 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
38990 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
38995 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
38997 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
38999 C...Identify commonblock variable.
39002 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
39003 &LNAM.LE.6) GOTO 140
39004 CHNAM=CHBIT(1:LNAM-1)//' '
39005 DO 160 LCOM=1,LNAM-1
39007 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
39008 & CHALP(2)(LALP:LALP)
39013 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
39016 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
39018 IF(LLOW.LT.LTOT) GOTO 120
39022 C...Identify any indices.
39027 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
39030 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
39032 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
39033 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17))
39035 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
39036 READ(CHIND,'(I8)') KF
39038 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
39040 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
39043 IF(LLOW.LT.LTOT) GOTO 120
39046 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
39047 READ(CHIND,'(I8)') I1
39050 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
39053 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
39056 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
39058 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
39059 READ(CHIND,'(I8)') I2
39061 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
39064 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
39067 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
39069 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
39070 READ(CHIND,'(I8)') I3
39075 C...Check that indices allowed.
39077 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
39078 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
39080 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
39082 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
39084 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
39086 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
39089 IF(LLOW.LT.LTOT) GOTO 120
39093 C...Save old value of variable.
39096 ELSEIF(IVAR.EQ.2) THEN
39098 ELSEIF(IVAR.EQ.3) THEN
39100 ELSEIF(IVAR.EQ.4) THEN
39102 ELSEIF(IVAR.EQ.5) THEN
39104 ELSEIF(IVAR.EQ.6) THEN
39106 ELSEIF(IVAR.EQ.7) THEN
39108 ELSEIF(IVAR.EQ.8) THEN
39110 ELSEIF(IVAR.EQ.9) THEN
39112 ELSEIF(IVAR.EQ.10) THEN
39114 ELSEIF(IVAR.EQ.11) THEN
39116 ELSEIF(IVAR.EQ.12) THEN
39118 ELSEIF(IVAR.EQ.13) THEN
39120 ELSEIF(IVAR.EQ.14) THEN
39122 ELSEIF(IVAR.EQ.15) THEN
39124 ELSEIF(IVAR.EQ.16) THEN
39126 ELSEIF(IVAR.EQ.17) THEN
39128 ELSEIF(IVAR.EQ.18) THEN
39130 ELSEIF(IVAR.EQ.19) THEN
39132 ELSEIF(IVAR.EQ.20) THEN
39134 ELSEIF(IVAR.EQ.21) THEN
39136 ELSEIF(IVAR.EQ.22) THEN
39138 ELSEIF(IVAR.EQ.23) THEN
39140 ELSEIF(IVAR.EQ.24) THEN
39142 ELSEIF(IVAR.EQ.25) THEN
39144 ELSEIF(IVAR.EQ.26) THEN
39146 ELSEIF(IVAR.EQ.27) THEN
39148 ELSEIF(IVAR.EQ.28) THEN
39150 ELSEIF(IVAR.EQ.29) THEN
39152 ELSEIF(IVAR.EQ.30) THEN
39154 ELSEIF(IVAR.EQ.31) THEN
39156 ELSEIF(IVAR.EQ.32) THEN
39158 ELSEIF(IVAR.EQ.33) THEN
39159 IOLD=ICOL(I1,I2,I3)
39160 ELSEIF(IVAR.EQ.34) THEN
39162 ELSEIF(IVAR.EQ.35) THEN
39164 ELSEIF(IVAR.EQ.36) THEN
39166 ELSEIF(IVAR.EQ.37) THEN
39168 ELSEIF(IVAR.EQ.38) THEN
39170 ELSEIF(IVAR.EQ.39) THEN
39172 ELSEIF(IVAR.EQ.40) THEN
39174 ELSEIF(IVAR.EQ.41) THEN
39176 ELSEIF(IVAR.EQ.42) THEN
39177 ROLD=SIGT(I1,I2,I3)
39178 ELSEIF(IVAR.EQ.43) THEN
39180 ELSEIF(IVAR.EQ.44) THEN
39182 ELSEIF(IVAR.EQ.45) THEN
39184 ELSEIF(IVAR.EQ.46) THEN
39186 ELSEIF(IVAR.EQ.47) THEN
39188 ELSEIF(IVAR.EQ.48) THEN
39190 ELSEIF(IVAR.EQ.49) THEN
39194 C...Print current value of variable. Loop back.
39195 IF(LNAM.GE.LBIT) THEN
39197 CHBIT(15:60)=' has the value '
39198 IF(MSVAR(IVAR,1).EQ.1) THEN
39199 WRITE(CHBIT(51:60),'(I10)') IOLD
39200 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
39201 WRITE(CHBIT(47:60),'(F14.5)') ROLD
39202 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
39207 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
39209 IF(LLOW.LT.LTOT) GOTO 120
39213 C...Read in new variable value.
39214 IF(MSVAR(IVAR,1).EQ.1) THEN
39216 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
39217 READ(CHINI,'(I10)') INEW
39218 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
39220 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
39222 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
39223 CHNEW=CHBIT(LNAM+1:LBIT)//' '
39225 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
39228 C...Store new variable value.
39231 ELSEIF(IVAR.EQ.2) THEN
39233 ELSEIF(IVAR.EQ.3) THEN
39235 ELSEIF(IVAR.EQ.4) THEN
39237 ELSEIF(IVAR.EQ.5) THEN
39239 ELSEIF(IVAR.EQ.6) THEN
39241 ELSEIF(IVAR.EQ.7) THEN
39243 ELSEIF(IVAR.EQ.8) THEN
39245 ELSEIF(IVAR.EQ.9) THEN
39247 ELSEIF(IVAR.EQ.10) THEN
39249 ELSEIF(IVAR.EQ.11) THEN
39251 ELSEIF(IVAR.EQ.12) THEN
39253 ELSEIF(IVAR.EQ.13) THEN
39255 ELSEIF(IVAR.EQ.14) THEN
39257 ELSEIF(IVAR.EQ.15) THEN
39259 ELSEIF(IVAR.EQ.16) THEN
39261 ELSEIF(IVAR.EQ.17) THEN
39263 ELSEIF(IVAR.EQ.18) THEN
39265 ELSEIF(IVAR.EQ.19) THEN
39267 ELSEIF(IVAR.EQ.20) THEN
39269 ELSEIF(IVAR.EQ.21) THEN
39271 ELSEIF(IVAR.EQ.22) THEN
39273 ELSEIF(IVAR.EQ.23) THEN
39275 ELSEIF(IVAR.EQ.24) THEN
39277 ELSEIF(IVAR.EQ.25) THEN
39279 ELSEIF(IVAR.EQ.26) THEN
39281 ELSEIF(IVAR.EQ.27) THEN
39283 ELSEIF(IVAR.EQ.28) THEN
39285 ELSEIF(IVAR.EQ.29) THEN
39287 ELSEIF(IVAR.EQ.30) THEN
39289 ELSEIF(IVAR.EQ.31) THEN
39291 ELSEIF(IVAR.EQ.32) THEN
39293 ELSEIF(IVAR.EQ.33) THEN
39294 ICOL(I1,I2,I3)=INEW
39295 ELSEIF(IVAR.EQ.34) THEN
39297 ELSEIF(IVAR.EQ.35) THEN
39299 ELSEIF(IVAR.EQ.36) THEN
39301 ELSEIF(IVAR.EQ.37) THEN
39303 ELSEIF(IVAR.EQ.38) THEN
39305 ELSEIF(IVAR.EQ.39) THEN
39307 ELSEIF(IVAR.EQ.40) THEN
39309 ELSEIF(IVAR.EQ.41) THEN
39311 ELSEIF(IVAR.EQ.42) THEN
39312 SIGT(I1,I2,I3)=RNEW
39313 ELSEIF(IVAR.EQ.43) THEN
39315 ELSEIF(IVAR.EQ.44) THEN
39317 ELSEIF(IVAR.EQ.45) THEN
39319 ELSEIF(IVAR.EQ.46) THEN
39321 ELSEIF(IVAR.EQ.47) THEN
39323 ELSEIF(IVAR.EQ.48) THEN
39325 ELSEIF(IVAR.EQ.49) THEN
39329 C...Write old and new value. Loop back.
39331 CHBIT(15:60)=' changed from to '
39332 IF(MSVAR(IVAR,1).EQ.1) THEN
39333 WRITE(CHBIT(33:42),'(I10)') IOLD
39334 WRITE(CHBIT(51:60),'(I10)') INEW
39335 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
39336 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
39337 WRITE(CHBIT(29:42),'(F14.5)') ROLD
39338 WRITE(CHBIT(47:60),'(F14.5)') RNEW
39339 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
39340 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
39343 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
39345 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
39346 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
39349 IF(LLOW.LT.LTOT) GOTO 120
39351 C...Format statement for output on unit MSTU(11) (by default 6).
39352 5000 FORMAT(5X,A60)
39353 5100 FORMAT(5X,A88)
39358 C*********************************************************************
39361 C...Administrates the fragmentation and decay chain.
39365 C...Double precision and integer declarations.
39366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39367 IMPLICIT INTEGER(I-N)
39368 INTEGER PYK,PYCHGE,PYCOMP
39370 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39371 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39372 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39373 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
39374 COMMON/PYINT4/MWID(500),WIDS(500,5)
39375 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
39377 DIMENSION PS(2,6),IJOIN(100)
39379 C...Initialize and reset.
39381 IF(MSTU(12).GE.1) CALL PYLIST(0)
39382 MSTU(31)=MSTU(31)+1
39386 IF(MSTU(17).LE.0) MSTU(90)=0
39389 C...Sum up momentum, energy and charge for starting entries.
39397 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
39399 PS(1,J)=PS(1,J)+P(I,J)
39401 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
39405 C...Prepare system for subsequent fragmentation/decay.
39408 C...Loop through jet fragmentation and particle decays.
39414 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
39417 C...Deal with any remaining undecayed resonance
39418 C...(normally the task of PYEVNT, so seldom used).
39419 ELSEIF(MWID(KC).NE.0) THEN
39421 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
39424 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
39425 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
39428 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
39429 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
39432 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
39441 C...Particle decay if unstable and allowed. Save long-lived particle
39442 C...decays until second pass after Bose-Einstein effects.
39443 ELSEIF(KCHG(KC,2).EQ.0) THEN
39444 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
39445 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
39448 C...Decay products may develop a shower.
39449 IF(MSTJ(92).GT.0) THEN
39451 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
39452 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
39453 CALL PYSHOW(IP1,IP1+1,QMAX)
39456 ELSEIF(MSTJ(92).LT.0) THEN
39458 CALL PYSHOW(IP1,-3,P(IP,5))
39463 C...Jet fragmentation: string or independent fragmentation.
39464 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
39466 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
39467 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
39468 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
39469 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
39470 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
39473 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
39474 IF(MFRAG.EQ.2) CALL PYINDF(IP)
39475 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
39476 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
39479 C...Loop back if enough space left in PYJETS and no error abort.
39480 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
39481 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
39483 ELSEIF(IP.LT.N) THEN
39484 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
39487 C...Include simple Bose-Einstein effect parametrization if desired.
39488 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
39493 C...Check that momentum, energy and charge were conserved.
39495 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
39497 PS(2,J)=PS(2,J)+P(I,J)
39499 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
39501 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
39502 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
39503 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
39504 &'(PYEXEC:) four-momentum was not conserved')
39505 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
39506 &'(PYEXEC:) charge was not conserved')
39511 C*********************************************************************
39514 C...Rearranges partons along strings.
39515 C...Allows small systems to collapse into one or two particles.
39516 C...Checks flavours and colour singlet invarient masses.
39518 SUBROUTINE PYPREP(IP)
39520 C...Double precision and integer declarations.
39521 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39522 INTEGER PYK,PYCHGE,PYCOMP
39524 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39525 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39526 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39527 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
39528 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
39530 DIMENSION DPS(5),DPC(5),UE(3),PG(5),
39531 &E1(3),E2(3),E3(3),E4(3),ECL(3)
39533 C...Function to give four-product.
39534 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)
39536 C...Rearrange parton shower product listing along strings: begin loop.
39539 DO 120 I=MAX(1,IP),N
39540 IF(K(I,1).NE.3) GOTO 120
39542 IF(KC.EQ.0) GOTO 120
39544 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
39546 C...Pick up loose string end.
39548 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
39552 IF(NSTP.GT.4*N) THEN
39553 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
39557 C...Copy undecayed parton.
39558 IF(K(IA,1).EQ.3) THEN
39559 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
39560 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
39565 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
39575 IF(K(I1,1).EQ.1) GOTO 120
39578 C...Go to next parton in colour space.
39580 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
39582 IA=MOD(K(IB,KCS),MSTU(5))
39583 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
39586 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
39587 & MSTU(5)).EQ.0) KCS=9-KCS
39588 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
39589 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
39592 IF(IA.LE.0.OR.IA.GT.N) THEN
39593 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
39596 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
39597 & MSTU(5)).EQ.IB) THEN
39598 IF(MREV.EQ.1) KCS=9-KCS
39599 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
39600 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
39602 IF(MREV.EQ.0) KCS=9-KCS
39603 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
39604 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
39606 IF(IA.NE.I) GOTO 100
39612 C...Done if no checks on small-mass systems.
39613 IF(MSTJ(14).LT.0) RETURN
39614 IF(MSTJ(14).EQ.0) GOTO 540
39616 C...Find lowest-mass colour singlet jet system.
39621 DO 190 I=MAX(1,IP),N
39622 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
39623 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
39630 DPS(5)=PYMASS(K(I,2))
39631 ELSEIF(K(I,1).EQ.2) THEN
39633 DPS(J)=DPS(J)+P(I,J)
39635 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
39637 DPS(J)=DPS(J)+P(I,J)
39640 DPS(5)=DPS(5)+PYMASS(K(I,2))
39641 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
39643 IF(PD.LT.PDMIN) THEN
39657 C...Done if lowest-mass system above threshold for string frag.
39658 IF(PDMIN.GE.PARJ(32)) GOTO 540
39660 C...Fill small-mass system as cluster.
39662 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
39672 C...Set up history, assuming cluster -> 2 hadrons.
39678 IF(MSTU(16).NE.2) THEN
39693 C...Form two particles from flavours of lowest-mass system, if feasible.
39695 200 NTRY = NTRY + 1
39697 IF(IABS(K(IC1,2)).NE.21) THEN
39698 KC1=PYCOMP(K(IC1,2))
39699 KC2=PYCOMP(K(IC2,2))
39700 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 540
39701 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
39702 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
39703 IF(KQ1+KQ2.NE.0) GOTO 540
39704 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
39706 IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
39708 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
39709 CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
39710 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
39713 IF(IABS(K(IC2,2)).NE.21) GOTO 540
39714 C...No room for popcorn mesons in closed string -> 2 hadrons.
39716 220 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
39717 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
39718 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
39719 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 220
39721 P(N+2,5)=PYMASS(K(N+2,2))
39722 P(N+3,5)=PYMASS(K(N+3,2))
39724 C...If it does not work: try again (a number of times), give up
39725 C...(if no place to shuffle momentum), or form one hadron.
39726 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
39727 IF(NTRY.LT.MSTJ(17)) THEN
39729 ELSEIF(NSIN.EQ.1) THEN
39736 C...Perform two-particle decay of jet system.
39737 C...First step: find reference axis in decaying system rest frame.
39738 C...(Borrow slot N+2 for temporary direction.)
39742 DO 250 I=IC1+1,IC2-1
39743 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
39744 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
39745 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
39747 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
39751 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
39753 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
39754 PHI1=PYANGL(P(N+2,1),P(N+2,2))
39756 C...Second step: generate isotropic/anisotropic decay.
39757 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
39758 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
39760 PT2=(1D0-UE(3)**2)*PA**2
39761 IF(MSTJ(16).LE.0) THEN
39764 IF(EXP(-PT2/(2D0*PARJ(21)**2)).LT.PYR(0)) GOTO 260
39765 PR1=P(N+2,5)**2+PT2
39766 PR2=P(N+3,5)**2+PT2
39767 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
39769 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
39770 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD)))
39772 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
39774 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
39775 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
39780 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
39781 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
39783 C...Third step: move back to event frame and set production vertex.
39784 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
39794 C...Else form one particle, if possible.
39802 C...Select hadron flavour from available quark flavours.
39803 310 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
39805 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
39806 CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
39808 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
39809 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
39811 IF(K(N+2,2).EQ.0) GOTO 310
39812 P(N+2,5)=PYMASS(K(N+2,2))
39814 C...Use old algorithm for E/p conservation? (EN)
39815 IF (MSTJ(16).LE.0) GOTO 480
39817 C...Find the string piece closest to the cluster by a loop
39818 C...over the undecayed partons not in present cluster. (EN)
39822 DO 340 I1=MAX(1,IP),N-1
39823 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
39825 ELSEIF(K(I1,1).EQ.2) THEN
39829 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 320
39831 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
39833 E1(J)=P(I1,J)/P(I1,4)
39834 E2(J)=P(I2,J)/P(I2,4)
39835 ECL(J)=P(N+1,J)/P(N+1,4)
39840 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
39841 E3S=E3(1)**2+E3(2)**2+E3(3)**2
39842 E4S=E4(1)**2+E4(2)**2+E4(3)**2
39843 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
39844 IF(E34.LE.0D0) THEN
39846 ELSEIF(E34.LT.E3S) THEN
39847 DDMIN=E4S-E34**2/E3S
39849 DDMIN=E4S-2D0*E34+E3S
39852 C...Is this the smallest so far?
39853 IF(DDMIN.LT.DGLOMI) THEN
39858 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
39863 C... Check if there are any strings to connect to the new gluon. (EN)
39864 IF (IBEG.EQ.0) GOTO 480
39866 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
39867 IF (P(N+1,5).GE.P(N+2,5)) THEN
39869 C...Construct 'gluon' that is needed to put hadron on the mass shell.
39870 FRAC=P(N+2,5)/P(N+1,5)
39872 P(N+2,J)=FRAC*P(N+1,J)
39873 PG(J)=(1D0-FRAC)*P(N+1,J)
39876 C... Copy string with new gluon put in.
39880 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 360
39881 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 360
39902 IF(K(I,1).EQ.12) GOTO 360
39905 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
39906 C...from string piece endpoints.
39909 C...Begin by copying string that should give energy to cluster.
39913 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 390
39914 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 390
39926 IF(K(I,1).EQ.12) GOTO 390
39929 C...Set initial Phad.
39931 P(NSAV+2,J)=P(NSAV+1,J)
39934 C...Calculate Pg, a part of which will be added to Phad later. (EN)
39935 420 IF(MSTJ(16).EQ.1) THEN
39939 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
39940 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
39943 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
39945 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
39947 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
39948 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
39950 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
39951 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
39952 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
39954 C...If all gluon energy eaten, zero it and take a step back.
39956 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
39959 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
39965 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
39968 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
39974 IF(ITER.EQ.1) GOTO 420
39976 C...If also all endpoint energy eaten, revert to old procedure.
39977 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
39978 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5)) THEN
39989 C... Construct the collapsed hadron and modified string partons.
39991 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
39992 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
39993 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
39995 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
39996 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
39998 C...Finished with string collapse in new scheme.
40002 C... Use old algorithm; by choice or when in trouble.
40004 C...Find parton/particle which combines to largest extra mass.
40009 IF(IR.NE.0) GOTO 500
40010 DO 490 I=MAX(1,IP),N
40011 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
40012 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 490
40013 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
40014 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 490
40015 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 490
40016 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
40018 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
40019 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
40020 IF(HSR.GT.HSM) THEN
40028 C...Shuffle energy and momentum to put new particle on mass shell.
40033 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
40034 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
40035 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
40037 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
40038 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
40042 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
40046 C...Mark collapsed system and store daughter pointers. Iterate.
40047 520 DO 530 I=IC1,IC2
40048 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
40049 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
40051 IF(MSTU(16).NE.2) THEN
40056 K(I,5)=NSAV+1+NBODY
40060 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
40062 C...Check flavours and invariant masses in parton systems.
40069 DO 580 I=MAX(1,IP),N
40070 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 580
40072 IF(KC.EQ.0) GOTO 580
40073 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
40074 IF(KQ.EQ.0) GOTO 580
40080 DPS(5)=DPS(5)+PYMASS(K(I,2))
40083 DPS(J)=DPS(J)+P(I,J)
40085 IF(K(I,1).EQ.1) THEN
40086 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
40087 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
40088 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
40089 & (0.9D0*PARJ(32)+DPS(5))**2) THEN
40090 CALL PYERRM(3,'(PYPREP:) too small mass in jet system')
40104 C*********************************************************************
40107 C...Handles the fragmentation of an arbitrary colour singlet
40108 C...jet system according to the Lund string fragmentation model.
40110 SUBROUTINE PYSTRF(IP)
40112 C...Double precision and integer declarations.
40113 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40114 IMPLICIT INTEGER(I-N)
40115 INTEGER PYK,PYCHGE,PYCOMP
40117 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40118 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40119 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40120 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40121 C...Local arrays. All MOPS variables ends with MO
40122 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
40123 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
40124 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
40125 &INMO(9),PM2QMO(2),XTMO(2)
40127 C...Function: four-product of two vectors.
40128 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)
40129 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
40132 C...Reset counters. Identify parton system.
40145 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
40146 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
40147 IF(MSTU(21).GE.1) RETURN
40149 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
40151 IF(KC.EQ.0) GOTO 110
40152 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
40153 IF(KQ.EQ.0) GOTO 110
40154 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
40155 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
40156 IF(MSTU(21).GE.1) RETURN
40159 C...Take copy of partons to be considered. Check flavour sum.
40164 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
40166 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
40168 IF(KQ.NE.2) KQSUM=KQSUM+KQ
40169 IF(K(I,1).EQ.41) THEN
40171 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
40172 IF(KQSUM.NE.KQ) MJU(2)=N+NP
40174 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
40175 IF(KQSUM.NE.0) THEN
40176 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
40177 IF(MSTU(21).GE.1) RETURN
40180 C...Boost copied system to CM frame (for better numerical precision).
40181 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
40184 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
40188 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
40190 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
40191 IF(P(I,3).GT.0D0) THEN
40192 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
40193 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
40194 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
40196 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
40197 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
40198 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
40203 C...Search for very nearby partons that may be recombined.
40210 140 IF(NR.GE.3) THEN
40213 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
40215 IF(I.EQ.N+NR) I1=N+1
40216 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
40217 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
40219 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
40221 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
40222 & P(I1,2)**2+P(I1,3)**2))
40223 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
40224 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
40225 IF(PDR.LT.PDRMIN) THEN
40231 C...Recombine very nearby partons to avoid machine precision problems.
40232 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
40234 P(N+1,J)=P(N+1,J)+P(N+NR,J)
40236 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
40240 ELSEIF(PDRMIN.LT.PARU12) THEN
40242 P(IR,J)=P(IR,J)+P(IR+1,J)
40244 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
40246 DO 190 I=IR+1,N+NR-1
40252 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
40254 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
40255 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
40261 C...Reset particle counter. Skip ahead if no junctions are present;
40262 C...this is usually the case!
40263 NRS=MAX(5*NR+11,NP)
40266 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
40270 ELSEIF(NTRY.GT.100) THEN
40271 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
40272 IF(MSTU(21).GE.1) RETURN
40276 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
40277 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
40278 & ' junction strings not handled by MSTJ(12)>3 options')
40281 IF(MJU(JT).EQ.0) GOTO 570
40284 C...Find and sum up momentum on three sides of junction. Check flavours.
40292 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
40293 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
40298 PJU(IU,J)=PJU(IU,J)+P(I1,J)
40302 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
40304 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
40305 & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
40306 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
40307 IF(MSTU(21).GE.1) RETURN
40310 C...Calculate (approximate) boost to rest frame of junction.
40311 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
40312 & (PJU(1,5)*PJU(2,5))
40313 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
40314 & (PJU(1,5)*PJU(3,5))
40315 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
40316 & (PJU(2,5)*PJU(3,5))
40317 T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
40318 T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
40319 TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
40320 T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
40321 T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
40323 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
40325 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
40327 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
40331 C...Put junction at rest if motion could give inconsistencies.
40332 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
40342 C...Start preparing for fragmentation of two strings from junction.
40345 NS=IJU(IU+1)-IJU(IU)
40347 C...Junction strings: find longitudinal string directions.
40352 DP(1,J)=0.5D0*P(IS1,J)
40353 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
40354 DP(2,J)=0.5D0*P(IS2,J)
40355 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
40357 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
40359 IF(IS.EQ.NS) DP(2,5)=0D0
40363 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
40364 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
40365 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
40370 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
40371 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
40372 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
40374 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
40376 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
40377 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
40381 C...Junction strings: initialize flavour, momentum and starting pos.
40385 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
40389 ELSEIF(NTRY.GT.100) THEN
40390 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
40391 IF(MSTU(21).GE.1) RETURN
40396 IE(1)=K(N+1+(JT/2)*(NP-1),3)
40401 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
40407 KFL(1)=K(IJU(IU),2)
40415 C...Junction strings: find initial transverse directions.
40418 DP(2,J)=P(IN(4)+1,J)
40422 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
40423 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
40424 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
40425 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
40426 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
40427 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
40428 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
40429 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
40430 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
40432 DHCX1=DFOUR(3,1)/DHC12
40433 DHCX2=DFOUR(3,2)/DHC12
40434 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
40435 DHCY1=DFOUR(4,1)/DHC12
40436 DHCY2=DFOUR(4,2)/DHC12
40437 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
40438 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
40440 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
40442 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
40446 C...Junction strings: produce new particle, origin.
40448 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
40449 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
40450 IF(MSTU(21).GE.1) RETURN
40458 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
40459 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
40460 IF(K(I,2).EQ.0) GOTO 320
40461 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
40462 & IABS(KFL(3)).GT.10) THEN
40463 IF(PYR(0).GT.PARJ(19)) GOTO 390
40465 P(I,5)=PYMASS(K(I,2))
40466 CALL PYPTDI(KFL(1),PX(3),PY(3))
40467 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
40468 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
40469 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
40470 & MSTU(90).LT.8) THEN
40471 MSTU(90)=MSTU(90)+1
40472 MSTU(90+MSTU(90))=I
40473 PARU(90+MSTU(90))=Z
40475 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
40480 C...Junction strings: stepping within or from 'low' string region easy.
40481 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
40482 & P(IN(1),5)**2.GE.PR(1)) THEN
40483 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
40484 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
40486 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
40489 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
40490 P(IN(2)+2,4)=P(IN(2)+2,3)
40493 IF(IN(2).GT.N+NR+4*NS) GOTO 320
40494 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
40495 P(IN(1)+2,4)=P(IN(1)+2,3)
40501 C...Junction strings: find new transverse directions.
40502 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
40503 & IN(1).GT.IN(2)) GOTO 320
40504 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
40511 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
40512 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
40514 IF(DHC12.LE.1D-2) THEN
40515 P(IN(1)+2,4)=P(IN(1)+2,3)
40521 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
40522 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
40523 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
40524 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
40525 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
40526 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
40527 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
40528 DHCX1=DFOUR(3,1)/DHC12
40529 DHCX2=DFOUR(3,2)/DHC12
40530 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
40531 DHCY1=DFOUR(4,1)/DHC12
40532 DHCY2=DFOUR(4,2)/DHC12
40533 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
40534 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
40536 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
40538 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
40541 C...Express pT with respect to new axes, if sensible.
40542 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
40543 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
40544 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
40550 C...Junction strings: sum up known four-momentum, coefficients for m2.
40553 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
40554 & PY(3)*P(IN(3)+1,J)
40555 DO 450 IN1=IN(4),IN(1)-4,4
40556 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
40558 DO 460 IN2=IN(5),IN(2)-4,4
40559 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
40563 DHM(2)=2D0*FOUR(I,IN(1))
40564 DHM(3)=2D0*FOUR(I,IN(2))
40565 DHM(4)=2D0*FOUR(IN(1),IN(2))
40567 C...Junction strings: find coefficients for Gamma expression.
40568 DO 490 IN2=IN(1)+1,IN(2),4
40569 DO 480 IN1=IN(1),IN2-1,4
40570 DHC=2D0*FOUR(IN1,IN2)
40571 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
40572 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
40573 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
40574 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
40578 C...Junction strings: solve (m2, Gamma) equation system for energies.
40579 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
40580 IF(ABS(DHS1).LT.1D-4) GOTO 320
40581 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
40582 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
40583 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
40584 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
40585 & ABS(DHS1)-DHS2/DHS1)
40586 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
40587 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
40588 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
40590 C...Junction strings: step to new region if necessary.
40591 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
40592 P(IN(2)+2,4)=P(IN(2)+2,3)
40595 IF(IN(2).GT.N+NR+4*NS) GOTO 320
40596 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
40597 P(IN(1)+2,4)=P(IN(1)+2,3)
40602 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
40603 P(IN(1)+2,4)=P(IN(1)+2,3)
40609 C...Junction strings: particle four-momentum, remainder, loop back.
40611 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
40612 & P(IN(2)+2,4)*P(IN(2),J)
40613 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
40615 IF(P(I,4).LT.P(I,5)) GOTO 320
40616 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
40617 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
40618 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
40623 IF(IN(3).NE.IN(6)) THEN
40625 P(IN(6),J)=P(IN(3),J)
40626 P(IN(6)+1,J)=P(IN(3)+1,J)
40631 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
40632 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
40637 C...Junction strings: save quantities left after each string.
40638 IF(IABS(KFL(1)).GT.10) GOTO 320
40642 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
40646 C...Junction strings: put together to new effective string endpoint.
40648 KFJS(JT)=K(K(MJU(JT+2),3),2)
40649 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
40650 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
40651 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
40652 & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
40655 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
40656 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
40658 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
40662 C...Open versus closed strings. Choose breakup region for latter.
40663 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
40666 ELSEIF(MJU(1).NE.0) THEN
40669 ELSEIF(MJU(2).NE.0) THEN
40672 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
40679 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
40680 W2SUM=W2SUM+P(N+NR+IS,1)
40685 W2SUM=W2SUM-P(N+NR+NB,1)
40686 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
40689 C...Find longitudinal string directions (i.e. lightlike four-vectors).
40691 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
40692 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
40695 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
40696 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
40698 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
40699 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
40704 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
40707 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
40708 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
40711 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
40712 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
40713 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
40715 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
40717 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
40718 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
40722 C...Begin initialization: sum up energy, set starting position.
40726 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
40730 ELSEIF(NTRY.GT.100) THEN
40731 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
40732 IF(MSTU(21).GE.1) RETURN
40739 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
40744 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
40745 IF(NS.GT.NR) IRANK(JT)=1
40746 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
40747 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
40748 IN(3*JT+2)=IN(3*JT+1)+1
40749 IN(3*JT+3)=N+NR+4*NS+2*JT-1
40750 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
40756 C.. MOPS variables and switches
40762 C...Initialize flavour and pT variables for open string.
40766 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
40770 KFL(JT)=K(IE(JT),2)
40771 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
40773 PMQ(JT)=PYMASS(KFL(JT))
40777 C...Closed string: random initial breakup flavour, pT and vertex.
40779 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
40781 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
40782 C.. Closed string: first vertex diq attempt => enforced second
40784 IF(IABS(KFL(1)).GT.10)THEN
40789 IF(IBMO.EQ.1) MSTU(121)=-1
40791 CALL PYPTDI(KFL(1),PX(1),PY(1))
40794 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
40795 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
40796 ZR=PR3/(Z*P(N+NR+1,5)**2)
40797 IF(ZR.GE.1D0) GOTO 710
40800 PMQ(JT)=PYMASS(KFL(JT))
40801 GAM(JT)=PR3*(1D0-Z)/Z
40802 IN1=N+NR+3+4*(JT/2)*(NS-1)
40805 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
40808 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
40814 PM2QMO(JT)=PMQ(JT)**2
40815 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
40818 C...Find initial transverse directions (i.e. spacelike four-vectors).
40820 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
40829 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
40830 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
40831 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
40832 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
40833 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
40834 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
40835 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
40836 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
40837 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
40839 DHCX1=DFOUR(3,1)/DHC12
40840 DHCX2=DFOUR(3,2)/DHC12
40841 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
40842 DHCY1=DFOUR(4,1)/DHC12
40843 DHCY2=DFOUR(4,2)/DHC12
40844 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
40845 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
40847 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
40849 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
40854 P(IN3+2,J)=P(IN3,J)
40855 P(IN3+3,J)=P(IN3+1,J)
40860 C...Remove energy used up in junction string fragmentation.
40861 IF(MJU(1)+MJU(2).GT.0) THEN
40863 IF(NJS(JT).EQ.0) GOTO 790
40865 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
40870 C...Produce new particle: side, origin.
40872 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
40873 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
40874 IF(MSTU(21).GE.1) RETURN
40876 C.. New side priority for popcorn systems
40877 IF(MSTU(121).LE.0)THEN
40879 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
40880 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
40884 IRANK(JT)=IRANK(JT)+1
40890 C...Generate flavour, hadron and pT.
40892 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
40893 IF(K(I,2).EQ.0) GOTO 640
40895 IF(MSTU(121).EQ.-1) GOTO 840
40896 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
40897 &IABS(KFL(3)).GT.10) THEN
40898 IF(PYR(0).GT.PARJ(19)) GOTO 810
40900 P(I,5)=PYMASS(K(I,2))
40901 CALL PYPTDI(KFL(JT),PX(3),PY(3))
40902 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
40904 C...Final hadrons for small invariant mass.
40906 PMQ(3)=PYMASS(KFL(3))
40908 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
40909 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
40910 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
40911 &WMIN-0.5D0*PARJ(36)*PMQ(3)
40912 WREM2=FOUR(N+NRS,N+NRS)
40913 IF(WREM2.LT.0.10D0) GOTO 640
40914 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
40915 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
40917 C...Choose z, which gives Gamma. Shift z for heavy flavours.
40918 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
40919 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
40920 &MSTU(90).LT.8) THEN
40921 MSTU(90)=MSTU(90)+1
40922 MSTU(90+MSTU(90))=I
40923 PARU(90+MSTU(90))=Z
40927 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
40928 &MOD(KFL2A/1000,10)).GE.4) THEN
40929 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
40930 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
40931 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
40932 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
40933 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
40935 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
40937 C.. MOPS baryon model modification
40938 XTMO3=(1D0-Z)*XTMO(JT)
40939 IF(IABS(KFL(3)).LE.10) NRVMO=0
40940 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
40944 IF(IABS(KFL(JT)).LE.10)THEN
40945 XBMO=MIN(XTMO3,1D0-(2D-10))
40948 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
40949 GTSTMO=1D0-PARF(192)**PGMO
40951 IF(IRANK(JT).EQ.1) THEN
40956 IF(XBMO.LT.1D0-(1D-10))THEN
40957 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
40958 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
40961 IF(MSTJ(12).GE.5)THEN
40962 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
40963 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
40964 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
40969 C.. MOPS Accepting popcorn system hadron.
40970 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
40971 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
40973 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
40975 & '(PYSTRF:) no more memory left in PYJETS')
40976 IF(MSTU(21).GE.1) RETURN
40988 DO 820 LINE=1,I-N-NR
40989 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
40990 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
40997 C..Reject popcorn system, flag=-1 if enforcing new one
40999 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
41004 C..Lift restoring string outside MOPS block
41005 840 IF(MSTU(121).LT.0) THEN
41006 IF(MSTU(121).EQ.-2) MSTU(121)=0
41009 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
41020 DO 850 LINE=1,I-N-NR
41021 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
41022 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
41030 C.. MOPS end of modification
41036 C...Stepping within or from 'low' string region easy.
41037 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
41038 &P(IN(1),5)**2.GE.PR(JT)) THEN
41039 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
41040 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
41042 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
41045 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
41046 P(IN(JR)+2,4)=P(IN(JR)+2,3)
41049 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
41050 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
41051 P(IN(JT)+2,4)=P(IN(JT)+2,3)
41057 C...Find new transverse directions (i.e. spacelike string vectors).
41058 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
41059 &IN(1).GT.IN(2)) GOTO 640
41060 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
41067 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
41068 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
41070 IF(DHC12.LE.1D-2) THEN
41071 P(IN(JT)+2,4)=P(IN(JT)+2,3)
41077 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
41078 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
41079 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
41080 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
41081 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
41082 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
41083 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
41084 DHCX1=DFOUR(3,1)/DHC12
41085 DHCX2=DFOUR(3,2)/DHC12
41086 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
41087 DHCY1=DFOUR(4,1)/DHC12
41088 DHCY2=DFOUR(4,2)/DHC12
41089 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
41090 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
41092 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
41094 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
41097 C...Express pT with respect to new axes, if sensible.
41098 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
41099 & FOUR(IN(3*JT+3)+1,IN(3)))
41100 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
41101 & FOUR(IN(3*JT+3)+1,IN(3)+1))
41102 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
41108 C...Sum up known four-momentum. Gives coefficients for m2 expression.
41111 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
41112 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
41113 DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
41114 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
41116 DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
41117 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
41121 DHM(2)=2D0*FOUR(I,IN(1))
41122 DHM(3)=2D0*FOUR(I,IN(2))
41123 DHM(4)=2D0*FOUR(IN(1),IN(2))
41125 C...Find coefficients for Gamma expression.
41126 DO 960 IN2=IN(1)+1,IN(2),4
41127 DO 950 IN1=IN(1),IN2-1,4
41128 DHC=2D0*FOUR(IN1,IN2)
41129 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
41130 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
41131 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
41132 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
41136 C...Solve (m2, Gamma) equation system for energies taken.
41137 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
41138 IF(ABS(DHS1).LT.1D-4) GOTO 640
41139 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
41140 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
41141 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
41142 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
41143 &ABS(DHS1)-DHS2/DHS1)
41144 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
41145 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
41146 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
41148 C...Step to new region if necessary.
41149 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
41150 P(IN(JR)+2,4)=P(IN(JR)+2,3)
41153 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
41154 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
41155 P(IN(JT)+2,4)=P(IN(JT)+2,3)
41160 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
41161 P(IN(JT)+2,4)=P(IN(JT)+2,3)
41167 C...Four-momentum of particle. Remaining quantities. Loop back.
41169 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
41170 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
41172 IF(P(I,4).LT.P(I,5)) GOTO 640
41178 IF(IN(3).NE.IN(3*JT+3)) THEN
41180 P(IN(3*JT+3),J)=P(IN(3),J)
41181 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
41186 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
41187 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
41191 C...Final hadron: side, flavour, hadron, mass.
41197 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
41198 IF(K(I,2).EQ.0) GOTO 640
41199 P(I,5)=PYMASS(K(I,2))
41200 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
41202 C...Final two hadrons: find common setup of four-vectors.
41204 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
41205 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
41206 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
41207 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
41208 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
41209 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
41210 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
41211 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
41212 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
41213 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
41216 C...Solve kinematics for final two hadrons, if possible.
41217 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
41218 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
41219 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
41220 IF(FD.GE.1D0) GOTO 640
41221 FA=WREM2+PR(JT)-PR(JR)
41222 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
41224 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
41225 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB)))
41226 FB=SIGN(FB,JS*(PYR(0)-PREV))
41229 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
41230 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
41231 &4D0*WREM2*PR(JT))),DBLE(JS))
41233 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
41234 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
41235 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
41236 P(I,J)=P(N+NRS,J)-P(I-1,J)
41238 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
41240 C...Mark jets as fragmented and give daughter pointers.
41242 DO 1030 I=NSAV+1,NSAV+NP
41245 IF(MSTU(16).NE.2) THEN
41254 C...Document string system. Move up particles.
41265 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
41269 K(I,J)=K(I+NRS-1,J)
41270 P(I,J)=P(I+NRS-1,J)
41275 DO 1070 IZ=MSTU90+1,MSTU91
41276 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
41277 PARU9T(IZ)=PARU(90+IZ)
41281 C...Order particles in rank along the chain. Update mother pointer.
41284 K(I-NSAV+N,J)=K(I,J)
41285 P(I-NSAV+N,J)=P(I,J)
41289 DO 1120 I=N+1,2*N-NSAV
41290 IF(K(I,3).NE.IE(1)) GOTO 1120
41296 IF(MSTU(16).NE.2) K(I1,3)=NSAV
41297 DO 1110 IZ=MSTU90+1,MSTU91
41298 IF(MSTU9T(IZ).EQ.I) THEN
41299 MSTU(90)=MSTU(90)+1
41300 MSTU(90+MSTU(90))=I1
41301 PARU(90+MSTU(90))=PARU9T(IZ)
41305 DO 1150 I=2*N-NSAV,N+1,-1
41306 IF(K(I,3).EQ.IE(1)) GOTO 1150
41312 IF(MSTU(16).NE.2) K(I1,3)=NSAV
41313 DO 1140 IZ=MSTU90+1,MSTU91
41314 IF(MSTU9T(IZ).EQ.I) THEN
41315 MSTU(90)=MSTU(90)+1
41316 MSTU(90+MSTU(90))=I1
41317 PARU(90+MSTU(90))=PARU9T(IZ)
41322 C...Boost back particle system. Set production vertices.
41325 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
41329 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
41330 IF(P(I,3).GT.0D0) THEN
41331 HHPEZ=(P(I,4)+P(I,3))*HHBZ
41332 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
41333 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
41335 HHPEZ=(P(I,4)-P(I,3))/HHBZ
41336 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
41337 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
41350 C*********************************************************************
41353 C...Handles the fragmentation of a jet system (or a single
41354 C...jet) according to independent fragmentation models.
41356 SUBROUTINE PYINDF(IP)
41358 C...Double precision and integer declarations.
41359 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41360 IMPLICIT INTEGER(I-N)
41361 INTEGER PYK,PYCHGE,PYCOMP
41363 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41364 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41365 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41366 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41368 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
41369 &KFLO(2),PXO(2),PYO(2),WO(2)
41371 C.. MOPS error message
41372 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
41373 &' are not treated as expected in independent fragmentation')
41375 C...Reset counters. Identify parton system and take copy. Check flavour.
41385 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
41386 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
41387 IF(MSTU(21).GE.1) RETURN
41389 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
41391 IF(KC.EQ.0) GOTO 110
41392 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
41393 IF(KQ.EQ.0) GOTO 110
41395 IF(KQ.NE.2) KQSUM=KQSUM+KQ
41397 K(NSAV+NJET,J)=K(I,J)
41398 P(NSAV+NJET,J)=P(I,J)
41399 DPS(J)=DPS(J)+P(I,J)
41402 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
41403 &K(I+1,1).EQ.2)) GOTO 110
41404 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
41405 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
41406 IF(MSTU(21).GE.1) RETURN
41409 C...Boost copied system to CM frame. Find CM energy and sum flavours.
41412 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
41413 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
41419 DO 140 I=NSAV+1,NSAV+NJET
41423 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
41424 ELSEIF(KFA.GT.1000) THEN
41425 KFLA=MOD(KFA/1000,10)
41426 KFLB=MOD(KFA/100,10)
41427 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
41428 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
41432 C...Loop over attempts made. Reset counters.
41435 IF(NTRY.GT.200) THEN
41436 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
41437 IF(MSTU(21).GE.1) RETURN
41447 C...Loop over jets to be fragmented.
41448 DO 230 IP1=NSAV+1,NSAV+NJET
41453 C...Initial flavour and momentum values. Jet along +z axis.
41454 KFLH=IABS(K(IP1,2))
41455 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
41457 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
41459 C...Initial values for quark or diquark jet.
41460 170 IF(IABS(K(IP1,2)).NE.21) THEN
41463 CALL PYPTDI(0,PXO(1),PYO(1))
41466 C...Initial values for gluon treated like random quark jet.
41467 ELSEIF(MSTJ(2).LE.2) THEN
41469 IF(MSTJ(2).EQ.2) MSTJ(91)=1
41470 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
41471 CALL PYPTDI(0,PXO(1),PYO(1))
41474 C...Initial values for gluon treated like quark-antiquark jet pair,
41475 C...sharing energy according to Altarelli-Parisi splitting function.
41478 IF(MSTJ(2).EQ.4) MSTJ(91)=1
41479 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
41481 CALL PYPTDI(0,PXO(1),PYO(1))
41484 WO(1)=WF*PYR(0)**(1D0/3D0)
41488 C...Initial values for rank, flavour, pT and W+.
41498 C...New hadron. Generate flavour and hadron species.
41500 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
41501 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
41502 IF(MSTU(21).GE.1) RETURN
41509 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
41510 IF(K(I,2).EQ.0) GOTO 180
41511 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
41512 IF(PYR(0).GT.PARJ(19)) GOTO 200
41515 C...Find hadron mass. Generate four-momentum.
41516 P(I,5)=PYMASS(K(I,2))
41517 CALL PYPTDI(KFL1,PX2,PY2)
41520 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
41521 CALL PYZDIS(KFL1,KFL2,PR,Z)
41523 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
41525 MSTU(90)=MSTU(90)+1
41526 MSTU(90+MSTU(90))=I
41527 PARU(90+MSTU(90))=Z
41529 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
41530 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
41531 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
41532 & P(I,3).LE.0.001D0) THEN
41533 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
41539 C...Remaining flavour and momentum.
41548 C...Check if pL acceptable. Go back for new hadron if enough energy.
41549 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
41551 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
41553 IF(W.GT.PARJ(31)) GOTO 190
41556 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
41557 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
41559 C...Rotate jet to new direction.
41560 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
41561 PHI=PYANGL(P(IP1,1),P(IP1,2))
41563 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
41564 K(K(IP1,3),4)=NSAV1+1
41567 C...End of jet generation loop. Skip conservation in some cases.
41569 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
41570 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
41572 C...Subtract off produced hadron flavours, finished if zero.
41573 DO 240 I=NSAV+NJET+1,N
41575 KFLA=MOD(KFA/1000,10)
41576 KFLB=MOD(KFA/100,10)
41577 KFLC=MOD(KFA/10,10)
41579 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
41580 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
41582 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
41583 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
41584 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
41587 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
41588 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
41589 IF(NREQ.EQ.0) GOTO 320
41591 C...Take away flavour of low-momentum particles until enough freedom.
41595 DO 260 I=NSAV+NJET+1,N
41596 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
41597 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
41598 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
41600 IF(IREM.EQ.0) GOTO 150
41602 KFA=IABS(K(IREM,2))
41603 KFLA=MOD(KFA/1000,10)
41604 KFLB=MOD(KFA/100,10)
41605 KFLC=MOD(KFA/10,10)
41606 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
41607 IF(K(IREM,1).EQ.8) GOTO 250
41609 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
41610 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
41611 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
41613 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
41614 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
41615 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
41618 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
41619 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
41620 IF(NREQ.GT.NREM) GOTO 250
41621 DO 270 I=NSAV+NJET+1,N
41622 IF(K(I,1).EQ.8) K(I,1)=1
41625 C...Find combination of existing and new flavours for hadron.
41627 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
41628 IF(NREQ.LT.NREM) NFET=1
41629 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
41631 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
41632 KFLF(J)=ISIGN(1,NFL(1))
41633 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
41634 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
41636 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
41638 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
41639 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
41640 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
41641 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
41642 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
41643 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
41644 IF(NFET.LE.2) KFLF(3)=0
41645 IF(KFLF(3).NE.0) THEN
41646 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
41647 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
41648 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
41649 & KFLFC=KFLFC+ISIGN(2,KFLFC)
41653 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
41654 IF(KF.EQ.0) GOTO 280
41655 DO 300 J=1,MAX(2,NFET)
41656 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
41659 C...Store hadron at random among free positions.
41660 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
41661 DO 310 I=NSAV+NJET+1,N
41662 IF(K(I,1).EQ.7) NPOS=NPOS-1
41663 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
41666 P(I,5)=PYMASS(K(I,2))
41667 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
41670 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
41671 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
41672 IF(NREM.GT.0) GOTO 280
41674 C...Compensate for missing momentum in global scheme (3 options).
41675 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
41678 DO 330 I=NSAV+NJET+1,N
41679 PSI(J)=PSI(J)+P(I,J)
41682 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
41684 DO 350 I=NSAV+NJET+1,N
41685 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
41686 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
41687 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
41688 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
41690 DO 370 I=NSAV+NJET+1,N
41691 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
41692 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
41693 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
41694 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
41696 P(I,J)=P(I,J)-PSI(J)*PW/PWS
41698 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
41701 C...Compensate for missing momentum withing each jet separately.
41702 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
41703 DO 390 I=N+1,N+NJET
41709 DO 410 I=NSAV+NJET+1,N
41712 K(IR2,1)=K(IR2,1)+1
41713 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
41714 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
41716 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
41718 P(IR2,4)=P(IR2,4)+P(I,4)
41719 P(IR2,5)=P(IR2,5)+PLS
41722 DO 420 I=N+1,N+NJET
41723 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
41725 DO 440 I=NSAV+NJET+1,N
41728 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
41729 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
41731 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
41734 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
41738 C...Scale momenta for energy conservation.
41739 IF(MOD(MSTJ(3),5).NE.0) THEN
41743 DO 450 I=NSAV+NJET+1,N
41746 PQS=PQS+P(I,5)**2/P(I,4)
41748 IF(PMS.GE.PECM) GOTO 150
41751 PFAC=(PECM-PQS)/(PES-PQS)
41754 DO 480 I=NSAV+NJET+1,N
41758 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
41760 PQS=PQS+P(I,5)**2/P(I,4)
41762 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
41765 C...Origin of produced particles and parton daughter pointers.
41766 490 DO 500 I=NSAV+NJET+1,N
41767 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
41768 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
41770 DO 510 I=NSAV+1,NSAV+NJET
41773 IF(MSTU(16).NE.2) THEN
41777 K(I1,4)=K(I1,4)-NJET+1
41778 K(I1,5)=K(I1,5)-NJET+1
41779 IF(K(I1,5).LT.K(I1,4)) THEN
41786 C...Document independent fragmentation system. Remove copy of jets.
41797 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
41799 DO 540 I=NSAV+NJET,N
41801 K(I-NJET+1,J)=K(I,J)
41802 P(I-NJET+1,J)=P(I,J)
41803 V(I-NJET+1,J)=V(I,J)
41807 DO 550 IZ=MSTU90+1,MSTU(90)
41808 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
41811 C...Boost back particle system. Set production vertices.
41812 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
41813 &DPS(2)/DPS(4),DPS(3)/DPS(4))
41823 C*********************************************************************
41826 C...Handles the decay of unstable particles.
41828 SUBROUTINE PYDECY(IP)
41830 C...Double precision and integer declarations.
41831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41832 IMPLICIT INTEGER(I-N)
41833 INTEGER PYK,PYCHGE,PYCOMP
41835 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41836 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41837 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41838 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
41839 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
41841 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
41842 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
41844 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
41846 C...Functions: momentum in two-particle decays and four-product.
41847 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
41848 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)
41850 C...Initial values.
41854 KFS=ISIGN(1,K(IP,2))
41858 C...Choose lifetime and determine decay vertex.
41859 IF(K(IP,1).EQ.5) THEN
41861 ELSEIF(K(IP,1).NE.4) THEN
41862 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
41865 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
41868 C...Determine whether decay allowed or not.
41870 IF(MSTJ(22).EQ.2) THEN
41871 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
41872 ELSEIF(MSTJ(22).EQ.3) THEN
41873 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
41874 ELSEIF(MSTJ(22).EQ.4) THEN
41875 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
41876 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
41878 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
41883 C...Interface to external tau decay library (for tau polarization).
41884 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
41886 C...Starting values for pointers and momenta.
41890 PCMTAU(J)=P(ITAU,J)
41893 C...Iterate to find position and code of mother of tau.
41895 120 IMTAU=K(IMTAU,3)
41897 IF(IMTAU.EQ.0) THEN
41898 C...If no known origin then impossible to do anything further.
41902 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
41903 C...If tau -> tau + gamma then add gamma energy and loop.
41904 IF(K(K(IMTAU,4),2).EQ.22) THEN
41906 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
41908 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
41910 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
41915 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
41916 C...If coming from weak decay of hadron then W is not stored in record,
41917 C...but can be reconstructed by adding neutrino momentum.
41918 KFORIG=-ISIGN(24,K(ITAU,2))
41920 DO 160 II=K(IMTAU,4),K(IMTAU,5)
41921 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
41923 PCMTAU(J)=PCMTAU(J)+P(II,J)
41929 C...If coming from resonance decay then find latest copy of this
41930 C...resonance (may not completely agree).
41933 DO 170 II=IMTAU+1,IP-1
41934 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
41935 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
41938 PCMTAU(J)=P(IORIG,J)
41942 C...Boost tau to rest frame of production process (where known)
41943 C...and rotate it to sit along +z axis.
41945 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
41947 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
41948 & -DBETAU(2),-DBETAU(3))
41949 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
41950 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
41951 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
41952 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
41954 C...Call tau decay routine (if meaningful) and fill extra info.
41955 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
41956 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
41957 DO 200 II=NSAV+1,NSAV+NDECAY
41966 C...Boost back decay tau and decay products.
41970 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
41971 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
41972 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
41973 & DBETAU(2),DBETAU(3))
41975 C...Skip past ordinary tau decay treatment.
41983 C...B-Bbar mixing: flip sign of meson appropriately.
41985 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
41987 IF(KFA.EQ.531) XBBMIX=PARJ(77)
41988 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
41989 IF(MMIX.EQ.1) KFS=-KFS
41992 C...Check existence of decay channels. Particle/antiparticle rules.
41994 IF(MDCY(KC,2).GT.0) THEN
41995 MDMDCY=MDME(MDCY(KC,2),2)
41996 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
41998 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
41999 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
42002 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
42003 IF(KCHG(KC,3).EQ.0) THEN
42006 IF(PYR(0).GT.0.5D0) KFS=-KFS
42007 ELSEIF(KFS.GT.0) THEN
42015 C...Sum branching ratios of allowed decay channels.
42018 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
42019 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
42020 & KFSN*MDME(IDL,1).NE.3) GOTO 230
42021 IF(MDME(IDL,2).GT.100) GOTO 230
42023 BRSU=BRSU+BRAT(IDL)
42026 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
42030 C...Select decay channel among allowed ones.
42031 240 RBR=BRSU*PYR(0)
42034 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
42035 &KFSN*MDME(IDL,1).NE.3) THEN
42036 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
42037 ELSEIF(MDME(IDL,2).GT.100) THEN
42038 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
42042 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
42045 C...Start readout of decay channel: matrix element, reset counters.
42048 IF(MOD(NTRY,200).EQ.0) THEN
42049 WRITE(CIDC,'(I4)') IDC
42050 C...Do not print warning for some well-known special cases.
42051 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
42052 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
42056 IF(NTRY.GT.1000) THEN
42057 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
42058 IF(MSTU(21).GE.1) RETURN
42064 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
42067 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
42069 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
42075 IF(KFA.GT.80) MHADDY=1
42076 C.. Random flavour and popcorn system memory.
42082 C...Read out decay products. Convert to standard flavour code.
42084 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
42086 IF(JT.LE.5) KP=KFDP(IDC,JT)
42087 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
42088 IF(KP.EQ.0) GOTO 280
42091 IF(KPA.GT.80) MHADDY=1
42092 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
42094 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
42096 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
42097 KFP=-KFS*MOD(KFA/10,10)
42098 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
42099 KFP=KFS*(100*MOD(KFA/10,100)+3)
42100 ELSEIF(KPA.EQ.81) THEN
42101 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
42102 ELSEIF(KP.EQ.82) THEN
42103 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
42104 IF(KFP.EQ.0) GOTO 260
42108 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
42109 ELSEIF(KP.EQ.-82) THEN
42112 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
42114 C...Add decay product to event record or to quark flavour list.
42117 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
42120 C...set rndmflav popcorn system pointer
42121 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
42123 PSQ=PSQ+PYMASS(KFLO(NQ))
42124 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
42125 & MOD(NQ,2).EQ.1) THEN
42130 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
42131 IF(K(I,2).EQ.0) GOTO 260
42133 P(I,5)=PYMASS(K(I,2))
42138 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
42139 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
42141 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
42142 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
42152 C...Check masses for resonance decays.
42153 IF(MHADDY.EQ.0) THEN
42154 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
42157 C...Choose decay multiplicity in phase space model.
42158 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
42160 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
42161 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
42163 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
42164 IF(IRNDMO.EQ.0) THEN
42167 ELSEIF(IRNDMO.EQ.1) THEN
42172 IF(NTRY.GT.1000) THEN
42173 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
42174 IF(MSTU(21).GE.1) RETURN
42176 IF(MMAT.LE.20) THEN
42177 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
42178 & SIN(PARU(2)*PYR(0))
42179 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
42180 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
42181 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
42182 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
42183 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
42187 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
42189 IF(MSTU(121).GT.MSTU(125)) GOTO 300
42191 C...Form hadrons from flavour content.
42195 IF(ND.EQ.NP+NQ/2) GOTO 330
42196 DO 320 I=N+NP+1,N+ND-NQ/2
42197 C.. Stick to started popcorn system, else pick side at random
42199 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
42200 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
42201 IF(K(I,2).EQ.0) GOTO 300
42202 MSTU(125)=MSTU(125)-1
42204 IF(MSTU(121).GT.0) JTMO=JT
42210 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
42211 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
42212 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
42215 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
42216 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
42217 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
42218 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
42220 C...Check that sum of decay product masses not too large.
42222 DO 340 I=N+NP+1,N+ND
42227 P(I,5)=PYMASS(K(I,2))
42230 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
42232 C...Rescale energy to subtract off spectator quark mass.
42233 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
42234 & .AND.NP.GE.3) THEN
42236 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
42238 P(N+NP,J)=PQT*PV(1,J)
42239 PV(1,J)=(1D0-PQT)*PV(1,J)
42241 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
42245 C...Fully specified final state: check mass broadening effects.
42247 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
42251 C...Determine position of grandmother, number of sisters.
42257 IF(IM.LT.0.OR.IM.GE.IP) IM=0
42258 IF(IM.NE.0) KFAM=IABS(K(IM,2))
42260 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
42261 IF(K(IL,3).EQ.IM) NM=NM+1
42262 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
42264 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
42265 & MOD(KFAM/1000,10).NE.0) NM=0
42267 KFAS=IABS(K(ISIS,2))
42268 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
42269 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
42274 C...Kinematics of one-particle decays.
42282 C...Calculate maximum weight ND-particle decay.
42285 WTMAX=1D0/WTCOR(ND-2)
42286 PMAX=PV(1,5)-PS+P(N+ND,5)
42288 DO 380 IL=ND-1,1,-1
42289 PMAX=PMAX+P(N+IL,5)
42290 PMIN=PMIN+P(N+IL+1,5)
42291 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
42295 C...Find virtual gamma mass in Dalitz decay.
42296 390 IF(ND.EQ.2) THEN
42297 ELSEIF(MMAT.EQ.2) THEN
42298 PMES=4D0*PMAS(11,1)**2
42299 PMRHO2=PMAS(131,1)**2
42300 PGRHO2=PMAS(131,2)**2
42301 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
42302 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
42303 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
42304 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
42305 IF(WT.LT.PYR(0)) GOTO 400
42306 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
42308 C...M-generator gives weight. If rejected, try again.
42313 DO 420 IL2=IL1-1,1,-1
42314 IF(RSAV.LE.RORD(IL2)) GOTO 430
42315 RORD(IL2+1)=RORD(IL2)
42317 430 RORD(IL2+1)=RSAV
42321 DO 450 IL=ND-1,1,-1
42322 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
42324 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
42326 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
42329 C...Perform two-particle decays in respective CM frame.
42330 460 DO 480 IL=1,ND-1
42331 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
42332 UE(3)=2D0*PYR(0)-1D0
42334 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
42335 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
42338 PV(IL+1,J)=-PA*UE(J)
42340 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
42341 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
42344 C...Lorentz transform decay products to lab frame.
42348 DO 530 IL=ND-1,1,-1
42350 BE(J)=PV(IL,J)/PV(IL,4)
42352 GA=PV(IL,4)/PV(IL,5)
42354 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
42356 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
42358 P(I,4)=GA*(P(I,4)+BEP)
42362 C...Check that no infinite loop in matrix element weight.
42364 IF(NTRY.GT.800) GOTO 560
42366 C...Matrix elements for omega and phi decays.
42368 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
42369 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
42370 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
42371 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
42373 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
42374 ELSEIF(MMAT.EQ.2) THEN
42375 FOUR12=FOUR(N+1,N+2)
42376 FOUR13=FOUR(N+1,N+3)
42377 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
42378 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
42379 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
42381 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
42382 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
42383 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
42384 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
42386 FOUR12=FOUR(IP,N+1)
42387 FOUR02=FOUR(IM,N+1)
42391 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
42392 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
42393 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
42394 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
42395 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
42396 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
42398 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
42399 ELSEIF(MMAT.EQ.4) THEN
42400 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
42401 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
42402 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
42403 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
42404 & ((1D0-HX3)/(HX1*HX2))**2
42405 IF(WT.LT.2D0*PYR(0)) GOTO 390
42406 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
42409 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
42410 ELSEIF(MMAT.EQ.41) THEN
42411 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
42412 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
42413 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
42415 C...Matrix elements for weak decays (only semileptonic for c and b)
42416 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
42417 & .AND.ND.EQ.3) THEN
42418 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
42419 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
42420 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
42421 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
42425 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
42428 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
42429 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
42430 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
42433 C...Scale back energy and reattach spectator.
42434 560 IF(MREM.EQ.1) THEN
42436 PV(1,J)=PV(1,J)/(1D0-PQT)
42442 C...Low invariant mass for system with spectator quark gives particle,
42443 C...not two jets. Readjust momenta accordingly.
42444 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
42446 PM2=PYMASS(K(N+2,2))
42448 PM3=PYMASS(K(N+3,2))
42449 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
42450 & (PARJ(32)+PM2+PM3)**2) GOTO 630
42453 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
42454 IF(K(N+2,2).EQ.0) GOTO 260
42455 P(N+2,5)=PYMASS(K(N+2,2))
42456 PS=P(N+1,5)+P(N+2,5)
42461 ELSEIF(MMAT.EQ.44) THEN
42463 PM3=PYMASS(K(N+3,2))
42465 PM4=PYMASS(K(N+4,2))
42466 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
42467 & (PARJ(32)+PM3+PM4)**2) GOTO 600
42470 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
42471 IF(K(N+3,2).EQ.0) GOTO 260
42472 P(N+3,5)=PYMASS(K(N+3,2))
42474 P(N+3,J)=P(N+3,J)+P(N+4,J)
42476 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)
42477 HA=P(N+1,4)**2-P(N+2,4)**2
42478 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
42479 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
42480 & (P(N+1,3)-P(N+2,3))**2
42481 HD=(PV(1,4)-P(N+3,4))**2
42482 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
42485 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
42487 PCOR=HH*(P(N+1,J)-P(N+2,J))
42488 P(N+1,J)=P(N+1,J)+PCOR
42489 P(N+2,J)=P(N+2,J)-PCOR
42491 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)
42492 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)
42496 C...Check invariant mass of W jets. May give one particle or start over.
42497 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
42498 &.AND.IABS(K(N+1,2)).LT.10) THEN
42499 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
42501 PM1=PYMASS(K(N+1,2))
42503 PM2=PYMASS(K(N+2,2))
42504 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
42505 KFLDUM=INT(1.5D0+PYR(0))
42506 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
42507 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
42508 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
42509 PSM=PYMASS(KF1)+PYMASS(KF2)
42510 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
42511 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
42512 IF(MMAT.EQ.48) GOTO 390
42513 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
42516 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
42517 IF(K(N+1,2).EQ.0) GOTO 260
42518 P(N+1,5)=PYMASS(K(N+1,2))
42521 PS=P(N+1,5)+P(N+2,5)
42522 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
42529 C...Phase space decay of partons from W decay.
42530 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
42536 PV(1,J)=P(N+1,J)+P(N+2,J)
42545 PSQ=PYMASS(KFLO(1))
42547 PSQ=PSQ+PYMASS(KFLO(2))
42552 C...Boost back for rapidly moving particle.
42556 BE(J)=P(IP,J)/P(IP,4)
42560 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
42562 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
42564 P(I,4)=GA*(P(I,4)+BEP)
42568 C...Fill in position of decay vertex.
42576 C...Set up for parton shower evolution from jets.
42577 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
42581 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
42582 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
42583 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
42584 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
42585 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
42586 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
42588 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
42591 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
42592 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
42593 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
42594 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
42596 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
42597 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
42600 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
42601 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
42602 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
42603 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
42605 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
42606 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
42608 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
42613 KCP=PYCOMP(K(NSAV+1,2))
42614 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
42616 IF(KQP.LT.0) JCON=5
42617 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
42618 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
42619 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
42620 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
42622 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
42625 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
42626 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
42627 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
42628 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
42632 C...Mark decayed particle; special option for B-Bbar mixing.
42633 IF(K(IP,1).EQ.5) K(IP,1)=15
42634 IF(K(IP,1).LE.10) K(IP,1)=11
42635 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
42643 C*********************************************************************
42646 C...Handles flavour production in the decay of unstable particles
42647 C...and small string clusters.
42649 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
42651 C...Double precision and integer declarations.
42652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42653 IMPLICIT INTEGER(I-N)
42654 INTEGER PYK,PYCHGE,PYCOMP
42656 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42657 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42658 SAVE /PYDAT1/,/PYDAT2/
42661 C.. Call PYKFDI directly if no popcorn option is on
42662 IF(MSTJ(12).LT.2) THEN
42663 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
42670 IF(KFL1.EQ.0) RETURN
42675 NMAX=MIN(MSTU(125),10)
42677 C.. Identify rank 0 cluster qq
42679 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
42682 C.. Join jets: Fails if store not empty
42683 IF(MSTU(121).GT.0) THEN
42687 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
42688 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
42689 C.. Pick popcorn meson from store, return same qq, decrease store
42690 KF=MSTU(NSTO+MSTU(121))
42692 MSTU(121)=MSTU(121)-1
42694 C.. Generate new flavour. Then done if no diquark is generated
42695 100 CALL PYKFDI(KFL1,0,KFL3,KF)
42696 IF(MSTU(121).EQ.-1) GOTO 100
42698 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
42700 C.. Simple case if no dynamical popcorn suppressions are considered
42701 IF(MSTJ(12).LT.4) THEN
42702 IF(MSTU(121).EQ.0) RETURN
42705 CALL PYKFDI(KFPREV,0,KFL3,KFM)
42706 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
42707 IF(IABS(KFL3).LE.10)THEN
42714 C test output qq against fake Gamma, then return if no popcorn.
42717 CALL PYZDIS(1,2103,5D0,Z)
42719 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
42724 IF(MSTU(121).EQ.0) RETURN
42726 C..Set store size memory. Pick fake dynamical variables of qq.
42728 CALL PYPTDI(1,PX3,PY3)
42734 C.. Pick next popcorn meson, test with fake dynamical variables
42738 CALL PYKFDI(KFPREV,0,KFL3,KFM)
42739 IF(MSTU(121).EQ.-1) GOTO 100
42740 CALL PYPTDI(KFL3,PX3,PY3)
42741 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
42742 CALL PYZDIS(KFPREV,KFL3,PM,Z)
42749 IF(MSTJ(12).GT.4)THEN
42750 POPMN=SQRT((1D0-X)*(G/X-GB))
42751 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
42752 PTST=EXP((POPM-POPMN)*PARF(193))
42757 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
42760 IF(RTST.GT.PTST*GTST)THEN
42762 IF(RTST.GT.PTST) MSTU(121)=-1
42767 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
42768 IF(MSTU(121).GT.0) GOTO 110
42770 C.. Test accepted system size. If OK set global popcorn size variable.
42771 IF(NMES.GT.NMAX)THEN
42782 C********************************************************************
42785 C...Generates a new flavour pair and combines off a hadron
42787 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
42789 C...Double precision and integer declarations.
42790 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42791 IMPLICIT INTEGER(I-N)
42792 INTEGER PYK,PYCHGE,PYCOMP
42794 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42795 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42796 SAVE /PYDAT1/,/PYDAT2/
42800 IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
42802 C...Default flavour values. Input consistency checks.
42807 IF(KF1A.EQ.0) RETURN
42809 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
42810 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
42811 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
42814 C...Check if tabulated flavour probabilities are to be used.
42815 IF(MSTJ(15).EQ.1) THEN
42816 IF(MSTJ(12).GE.5) CALL PYERRM(29,
42817 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
42818 & ' together with MSTJ(12)>=5 modification')
42820 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
42821 KFL1A=MOD(KF1A/1000,10)
42822 KFL1B=MOD(KF1A/100,10)
42824 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
42825 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
42826 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
42827 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
42831 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
42832 KFL2A=MOD(KF2A/1000,10)
42833 KFL2B=MOD(KF2A/100,10)
42835 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
42836 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
42837 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
42839 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
42842 C.. Recognize rank 0 diquark case
42844 KFDIQ=MAX(KF1A,KF2A)
42845 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
42847 C.. Join two flavours to meson or baryon. Test for popcorn.
42850 IF(KFDIQ.GT.10) THEN
42851 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
42852 & CALL PYNMES(KFDIQ)
42853 IF(MSTU(121).NE.0) THEN
42864 C.. Separate incoming flavours, curtain flavour consistency check
42870 KFL1A=MOD(KF1A/1000,10)
42871 KFL1B=MOD(KF1A/100,10)
42874 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
42875 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
42876 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
42878 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
42882 KFQOLD=KFL1A+KFL1B-KFQPOP
42885 C...Meson/baryon choice. Set number of mesons if starting a popcorn
42888 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
42889 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
42893 ELSEIF(KF1A.GT.10)THEN
42895 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
42896 IF(MSTU(121).GT.0) MBARY=-1
42899 C..x->H+q: Choose single vertex quark. Jump to form hadron.
42900 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
42901 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
42902 KFL3=ISIGN(KFQVER,-KFIN)
42906 C..x->H+qq: (IDW=proper PARF position for diquark weights)
42909 IF(MSTU(121).EQ.0) IDW=150
42911 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
42912 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
42913 C.. Shift to s-curtain parameters if needed
42914 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
42915 PARF(194)=PARF(138)*PARF(139)
42916 PARF(193)=PARJ(8)+PARJ(9)
42920 C.. x->H+qq: Get vertex quark
42921 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
42923 MSTU(121)=MSTU(121)-1
42924 IF(IDW.EQ.170) THEN
42925 IF(MSTU(121).EQ.0)THEN
42926 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
42928 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
42931 IF(MSTU(121).EQ.0)THEN
42932 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
42934 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
42940 RMES=PYR(0)*PARF(194)
42942 RMES=RMES-PARF(IPOS+IMES)
42943 IF(IMES.EQ.30) THEN
42948 IF(RMES.GT.0D0) GOTO 120
42951 IF(KMUL.EQ.2) KFJ=10003
42952 IF(KMUL.EQ.3) KFJ=10001
42953 IF(KMUL.EQ.4) KFJ=20003
42954 IF(KMUL.EQ.5) KFJ=5
42956 KFQVER=MOD(IMES,5)+1
42957 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
42958 IF(KFQVER.GT.3)THEN
42963 IF(MBARY.EQ.-1) IDW=170
42965 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
42966 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
42967 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
42968 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
42970 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
42974 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
42976 IF(KFQPOP.NE.KFQVER)THEN
42978 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
42979 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
42980 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
42982 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
42984 KFL3=ISIGN(KFDIQ,KFIN)
42986 C..x->M+y: flavour for meson.
42987 130 IF(MBARY.LE.0)THEN
42988 KFLA=MAX(KFQOLD,KFQVER)
42989 KFLB=MIN(KFQOLD,KFQVER)
42991 IF(KFLA.NE.KFQOLD) KFS=-KFS
42992 C... Form meson, with spin and flavour mixing for diagonal states.
42993 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
42994 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
42995 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
42998 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
42999 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
43000 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
43001 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
43002 IF(PYR(0).LT.PARJ(14)) KMUL=2
43003 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
43005 IF(RMUL.LT.PARJ(15)) KMUL=3
43006 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
43007 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
43010 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
43011 IF(KMUL.EQ.5) KFLS=5
43012 IF(KFLA.NE.KFLB)THEN
43013 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
43016 IMIX=2*KFLA+10*KMUL
43017 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
43018 & INT(RMIX+PARF(IMIX)))+KFLS
43019 IF(KFLA.GE.4) KF=110*KFLA+KFLS
43021 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
43022 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
43024 C..Optional extra suppression of eta and eta'.
43025 C..Allow shift to qq->B+q in old version (set IRANK to 0)
43026 IF(KF.EQ.221.OR.KF.EQ.331)THEN
43027 IF(PYR(0).GT.PARJ(25+KF/300))THEN
43028 IF(KF2A.GT.0) GOTO 130
43029 IF(MSTJ(12).LT.4) IRANK=0
43035 C.. x->B+y: Flavour for baryon
43038 IF(KF1A.LE.10) KFLA=KFQOLD
43039 KFLB=MOD(KFDIQ/1000,10)
43040 KFLC=MOD(KFDIQ/100,10)
43041 KFLDS=MOD(KFDIQ,10)
43042 KFLD=MAX(KFLA,KFLB,KFLC)
43043 KFLF=MIN(KFLA,KFLB,KFLC)
43044 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
43046 C... SU(6) factors for formation of baryon.
43050 IF(KFLB.NE.KFLC)THEN
43053 IF(KFLB.GT.2) KDMAX=KDMAX+2
43055 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
43060 SU6MAX=PARF(140+KDMAX)
43063 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
43068 SU6OCT=PARF(60+KBARY)
43069 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
43070 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
43071 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
43073 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
43075 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
43077 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
43078 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
43080 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
43084 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
43087 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
43088 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
43090 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
43092 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
43093 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
43097 C...Use tabulated probabilities to select new flavour and hadron.
43098 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
43101 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
43104 ELSEIF(KTAB2.EQ.0) THEN
43113 DO 150 KT3=KT3L,KT3U
43114 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
43120 DO 170 KT3=KT3L,KT3U
43122 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
43123 IF(RFL.LE.0D0) GOTO 190
43128 C...Reconstruct flavour of produced quark/diquark.
43129 IF(KTAB3.LE.6) THEN
43132 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
43135 IF(KTAB3.GE.8) KFL3A=2
43136 IF(KTAB3.GE.11) KFL3A=3
43137 IF(KTAB3.GE.16) KFL3A=4
43138 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
43139 KFL3=1000*KFL3A+100*KFL3B+1
43140 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
43142 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
43145 C...Reconstruct meson code.
43146 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
43148 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
43149 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
43151 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
43152 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
43153 & 25*KTABS)) KF=330+2*KTABS+1
43154 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
43155 KFLA=MAX(KTAB1,KTAB3)
43156 KFLB=MIN(KTAB1,KTAB3)
43158 IF(KFLA.NE.KF1A) KFS=-KFS
43159 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
43160 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
43162 IF(KFL1A.EQ.KFL3A) THEN
43163 KFLA=MAX(KFL1B,KFL3B)
43164 KFLB=MIN(KFL1B,KFL3B)
43165 IF(KFLA.NE.KFL1B) KFS=-KFS
43166 ELSEIF(KFL1A.EQ.KFL3B) THEN
43170 ELSEIF(KFL1B.EQ.KFL3A) THEN
43173 ELSEIF(KFL1B.EQ.KFL3B) THEN
43174 KFLA=MAX(KFL1A,KFL3A)
43175 KFLB=MIN(KFL1A,KFL3A)
43176 IF(KFLA.NE.KFL1A) KFS=-KFS
43178 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
43181 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
43183 C...Reconstruct baryon code.
43185 IF(KTAB1.GE.7) THEN
43194 KFLD=MAX(KFLA,KFLB,KFLC)
43195 KFLF=MIN(KFLA,KFLB,KFLC)
43196 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
43197 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
43198 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
43201 C...Check that constructed flavour code is an allowed one.
43202 IF(KFL2.NE.0) KFL3=0
43205 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
43213 C*********************************************************************
43216 C...Generates number of popcorn mesons and stores some relevant
43219 SUBROUTINE PYNMES(KFDIQ)
43221 C...Double precision and integer declarations.
43222 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43223 IMPLICIT INTEGER(I-N)
43224 INTEGER PYK,PYCHGE,PYCOMP
43226 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43227 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43228 SAVE /PYDAT1/,/PYDAT2/
43231 IF(MSTJ(12).LT.2) RETURN
43233 C..Old version: Get 1 or 0 popcorn mesons
43234 IF(MSTJ(12).LT.5)THEN
43236 IF(KFDIQ.NE.0) THEN
43238 KFA=MOD(KFDIQA/1000,10)
43239 KFB=MOD(KFDIQA/100,10)
43242 IF(KFA.EQ.3) POPWT=PARF(133)
43243 IF(KFB.EQ.3) POPWT=PARF(134)
43244 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
43246 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
43250 C..New version: Store popcorn- or rank 0 diquark parameters
43253 PARF(194)=PARF(139)
43254 IF(KFDIQ.NE.0) THEN
43257 PARF(194)=PARF(140)
43259 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
43260 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
43261 & '(PYNMES:) Neglecting too large popcorn possibility')
43265 C..New version: Get number of popcorn mesons
43268 110 MSTU(121)=MSTU(121)+1
43269 RTST=RTST/PARF(194)
43270 IF(RTST.LT.1D0) GOTO 110
43271 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
43272 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
43276 C***************************************************************
43279 C...Precalculates a set of diquark and popcorn weights.
43283 C...Double precision and integer declarations.
43284 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43285 IMPLICIT INTEGER(I-N)
43286 INTEGER PYK,PYCHGE,PYCOMP
43288 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43289 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43290 SAVE /PYDAT1/,/PYDAT2/
43292 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
43296 C..Diquark indices for dimensional variables
43305 C.. *** SU(6) factors **
43306 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
43308 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
43309 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
43310 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
43313 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
43315 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
43316 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
43318 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
43319 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
43322 C..SU(6)max q q' s,c,b
43323 SU6MUD =MAX(SU6(1) , SU6(8) )
43324 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
43325 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
43326 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
43327 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
43328 SU6M(IUS0)=SU6M(ISU0)
43329 SU6M(ISS1)=SU6M(IUU1)
43330 SU6M(IUS1)=SU6M(ISU1)
43332 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
43334 PARF(142)=SU6M(IUD1)
43335 PARF(143)=SU6M(ISU0)
43336 PARF(144)=SU6M(ISU1)
43337 PARF(145)=SU6M(ISS1)
43339 C..diquark SU(6) survival =
43340 C..sum over quark (quark tunnel weight)*(SU(6)).
43341 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
43342 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
43343 DMB(IUS0)=DMB(ISU0)
43344 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
43345 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
43346 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
43347 DMB(IUS1)=DMB(ISU1)
43348 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
43350 C.. *** Tunneling factors for Diquark production***
43351 C.. T: half a curtain pair = sqrt(curtain pair factor)
43352 IF(MSTJ(12).GE.5) THEN
43354 PMUD1=PYMASS(2103)-PMUD0
43355 PMUS0=PYMASS(3201)-PMUD0
43356 PMUS1=PYMASS(3203)-PMUS0-PMUD0
43357 PMSS1=PYMASS(3303)-PMUS0-PMUD0
43358 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
43359 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
43360 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
43361 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
43362 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
43363 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
43364 QBB(IUD1)=QBB(IUU1)
43366 PAR2M=SQRT(PARJ(2))
43367 PAR3M=SQRT(PARJ(3))
43368 PAR4M=SQRT(PARJ(4))
43369 QBB(ISU0)=PAR2M*PAR3M
43371 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
43373 QBB(ISU1)=PAR4M*QBB(ISU0)
43374 QBB(IUS1)=PAR4M*QBB(IUS0)
43378 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
43379 QBM(ISU0)=QBB(ISU0)
43380 QBM(IUS0)=PARJ(2)*QBB(IUS0)
43381 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
43382 QBM(IUU1)=6D0*QBB(IUU1)
43383 QBM(ISU1)=3D0*QBB(ISU1)
43384 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
43385 QBM(IUD1)=3D0*QBB(IUD1)
43387 C.. Combine T and tau to diquark weight for q-> B+B+..
43389 QBB(I)=QBB(I)*QBM(I)
43392 IF(MSTJ(12).GE.5)THEN
43393 C..New version: tau for rank 0 diquark.
43394 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
43395 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
43396 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
43397 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
43398 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
43399 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
43400 DMB(7+IUD1)=DMB(7+IUU1)/2D0
43402 C..New version: curtain flavour ratios.
43403 C.. s/u for q->B+M+...
43404 C.. s/u for rank 0 diquark: su -> ...M+B+...
43405 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
43406 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
43407 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
43408 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
43409 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
43410 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
43411 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
43413 C..Old version: reset unused rank 0 diquark weights and
43414 C.. unused diquark SU(6) survival weights
43416 IF(MSTJ(12).LT.3) DMB(I)=1D0
43420 C..Old version: Shuffle PARJ(7) into tau
43421 QBM(IUS0)=QBM(IUS0)*PARJ(7)
43422 QBM(ISS1)=QBM(ISS1)*PARJ(7)
43423 QBM(IUS1)=QBM(IUS1)*PARJ(7)
43425 C..Old version: curtain flavour ratios.
43426 C.. s/u for q->B+M+...
43427 C.. s/u for rank 0 diquark: su -> ...M+B+...
43428 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
43429 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
43430 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
43431 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
43432 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
43435 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
43436 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
43438 DMB(7+I)=DMB(7+I)*DMB(I)
43439 DMB(I)=DMB(I)*QBM(I)
43440 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
43441 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
43444 C.. *** Popcorn factors ***
43446 IF(MSTJ(12).LT.5)THEN
43447 C.. Old version: Resulting popcorn weights.
43449 WS=PARF(135)*PARF(138)
43451 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
43453 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
43454 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
43455 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
43456 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
43457 & (1D0+QBB(IUD1)+QBB(IUU1)+
43458 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
43460 C..New version: Store weights for popcorn mesons,
43461 C..get prel. popcorn weights.
43462 DO 150 IPOS=201,1400
43471 IF(MR.EQ.7) PARF(193)=PARJ(10)
43472 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
43473 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
43474 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
43476 IF(NMES.EQ.1) SQWT=PARJ(2)
43478 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
43479 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
43480 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
43482 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
43483 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
43486 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
43488 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
43489 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
43495 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
43496 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
43497 IF(PJWT.LE.0D0) GOTO 190
43498 IF(PJWT.GT.1D0) PJWT=1D0
43500 IMIX=2*KFQOLD+10*KMUL
43502 IF(KMUL.EQ.2) KFJ=10003
43503 IF(KMUL.EQ.3) KFJ=10001
43504 IF(KMUL.EQ.4) KFJ=20003
43505 IF(KMUL.EQ.5) KFJ=5
43507 KFLA=MAX(KFQOLD,KFQVER)
43508 KFLB=MIN(KFQOLD,KFQVER)
43509 SWT=PARJ(11+KFLA/3+KFLA/4)
43510 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
43512 QWT=SQWT/(2D0+SQWT)
43513 IF(KFQVER.LT.3)THEN
43514 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
43515 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
43517 IF(KFQVER.NE.KFQOLD)THEN
43519 KFM=100*KFLA+10*KFLB+KFJ
43520 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
43521 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
43522 WTTOT=WTTOT+PARF(IPOS+IMES)
43525 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
43526 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
43527 IF(ID.EQ.5) DWT=PARF(IMIX)
43529 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
43530 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
43531 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
43532 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
43533 PARF(IPOS+5*KMUL+ID)=
43534 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
43536 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
43542 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
43544 IF(MR.EQ.7) PARF(140)=
43545 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
43546 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
43547 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
43553 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
43558 C..Recombine diquark weights to flavour and spin ratios
43559 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
43560 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
43561 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
43562 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
43563 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
43564 PARF(155)=QBB(ISU1)/QBB(ISU0)
43565 PARF(156)=QBB(IUS1)/QBB(IUS0)
43566 PARF(157)=QBB(IUD1)
43568 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
43569 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
43570 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
43571 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
43572 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
43573 PARF(165)=QBM(ISU1)/QBM(ISU0)
43574 PARF(166)=QBM(IUS1)/QBM(IUS0)
43575 PARF(167)=QBM(IUD1)
43577 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
43578 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
43579 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
43580 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
43581 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
43582 PARF(175)=DMB(ISU1)/DMB(ISU0)
43583 PARF(176)=DMB(IUS1)/DMB(IUS0)
43584 PARF(177)=DMB(IUD1)
43586 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
43587 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
43588 PARF(187)=DMB(7+IUD1)
43594 C*********************************************************************
43597 C...Generates transverse momentum according to a Gaussian.
43599 SUBROUTINE PYPTDI(KFL,PX,PY)
43601 C...Double precision and integer declarations.
43602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43603 IMPLICIT INTEGER(I-N)
43604 INTEGER PYK,PYCHGE,PYCOMP
43606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43609 C...Generate p_T and azimuthal angle, gives p_x and p_y.
43611 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
43612 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
43613 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
43614 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
43622 C*********************************************************************
43625 C...Generates the longitudinal splitting variable z.
43627 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
43629 C...Double precision and integer declarations.
43630 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43631 IMPLICIT INTEGER(I-N)
43632 INTEGER PYK,PYCHGE,PYCOMP
43634 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43635 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43636 SAVE /PYDAT1/,/PYDAT2/
43638 C...Check if heavy flavour fragmentation.
43642 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
43644 C...Lund symmetric scaling function: determine parameters of shape.
43645 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
43646 &MSTJ(11).GE.4) THEN
43648 IF(MSTJ(91).EQ.1) FA=PARJ(43)
43649 IF(KFLB.GE.10) FA=FA+PARJ(45)
43651 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
43654 IF(KFLA.GE.10) FC=FC-PARJ(45)
43655 IF(KFLB.GE.10) FC=FC+PARJ(45)
43656 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
43658 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
43659 FC=FC+FRED*FBB*PARF(100+KFLH)**2
43660 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
43662 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
43663 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
43666 IF(ABS(FC-1D0).GT.0.01D0) MC=2
43668 C...Determine position of maximum. Special cases for a = 0 or a = c.
43669 IF(FA.LT.0.02D0) THEN
43672 IF(FC.GT.FB) ZMAX=FB/FC
43673 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
43678 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
43679 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
43682 C...Subdivide z range if distribution very peaked near endpoint.
43684 IF(ZMAX.LT.0.1D0) THEN
43690 ZDIVC=ZDIV**(1D0-FC)
43691 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
43693 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
43695 FSCB=SQRT(4D0+(FC/FB)**2)
43696 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
43697 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
43698 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
43699 FINT=1D0+FB*(1D0-ZDIV)
43702 C...Choice of z, preweighted for peaks at low or high z.
43706 IF(FINT*PYR(0).LE.1D0) THEN
43708 ELSEIF(MC.EQ.1) THEN
43712 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
43715 ELSEIF(MMAX.EQ.3) THEN
43716 IF(FINT*PYR(0).LE.1D0) THEN
43718 FPRE=EXP(FB*(Z-ZDIV))
43720 Z=ZDIV+Z*(1D0-ZDIV)
43724 C...Weighting according to correct formula.
43725 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
43726 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
43727 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
43728 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
43729 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
43731 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
43733 FC=PARJ(50+MAX(1,KFLH))
43734 IF(MSTJ(91).EQ.1) FC=PARJ(59)
43736 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
43737 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
43738 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
43739 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
43742 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
43743 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
43750 C*********************************************************************
43753 C...Generates timelike parton showers from given partons.
43755 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
43757 C...Double precision and integer declarations.
43758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43759 IMPLICIT INTEGER(I-N)
43760 INTEGER PYK,PYCHGE,PYCOMP
43762 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43763 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43764 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43765 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43767 DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
43768 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
43769 &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
43772 C...Check that QMAX not too low.
43773 IF(MSTJ(41).LE.0) THEN
43775 ELSEIF(MSTJ(41).EQ.1) THEN
43776 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-5) RETURN
43778 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-5)
43782 C...Initialization of cutoff masses etc.
43787 PMTH(1,21)=PYMASS(21)
43788 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
43789 PMTH(3,21)=2D0*PMTH(2,21)
43790 PMTH(4,21)=PMTH(3,21)
43791 PMTH(5,21)=PMTH(3,21)
43792 PMTH(1,22)=PYMASS(22)
43793 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
43794 PMTH(3,22)=2D0*PMTH(2,22)
43795 PMTH(4,22)=PMTH(3,22)
43796 PMTH(5,22)=PMTH(3,22)
43798 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
43799 PMQT1E=MIN(PMQTH1,PARJ(90))
43801 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
43802 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
43805 PMTH(1,IFL)=PYMASS(IFL)
43806 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
43807 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
43808 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
43809 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
43812 IF(MSTJ(41).GE.2) KSH(IFL)=1
43813 PMTH(1,IFL)=PYMASS(IFL)
43814 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
43815 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
43816 PMTH(4,IFL)=PMTH(3,IFL)
43817 PMTH(5,IFL)=PMTH(3,IFL)
43819 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
43821 ALFM=LOG(PT2MIN/ALAMS)
43823 C...Store positions of shower initiating partons.
43825 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
43828 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
43833 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
43834 & .AND.IP2.GE.-3) THEN
43839 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
43847 & '(PYSHOW:) failed to reconstruct showering system')
43848 IF(MSTU(21).GE.1) RETURN
43851 C...Check on phase space available for emission.
43858 KFLA(I)=IABS(K(IPA(I),2))
43860 C...Special cutoff masses for t, l, h with variable masses.
43862 IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
43863 IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
43864 PMTH(1,IFLA)=PMA(I)
43865 PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PMQTH1**2)
43866 PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
43867 PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(82)**2)+
43869 PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(83)**2)+
43872 IF(KFLA(I).LE.40) THEN
43873 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
43876 IF(KFLA(I).GT.40) THEN
43879 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
43882 PS(J)=PS(J)+P(IPA(I),J)
43885 IF(IREJ.EQ.NPA.AND.IP2.GT.-5) RETURN
43886 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
43887 IF(NPA.EQ.1) PS(5)=PS(4)
43888 IF(PS(5).LE.PM+PMQT1E) RETURN
43890 C...Check if 3-jet matrix elements to be used.
43892 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
43893 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
43894 & KFLA(2).LE.8) M3JC=1
43895 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
43896 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
43897 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
43898 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
43899 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
43900 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
43901 IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
43903 IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
43905 PQMES=PMTH(1,KFLA(1))**2
43906 QME=4D0*PQMES/PS(5)**2
43907 RESCZ=MIN(1D0,LOG(PMTH(2,KFLA(1))/PS(5))/
43908 & LOG(PMTH(2,21)/PS(5)))
43912 C...Find if interference with initial state partons.
43914 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
43919 KCA=PYCOMP(KFLA(I))
43920 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
43922 IF(KCII(I).NE.0) THEN
43924 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
43925 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
43926 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
43928 IIIS(I,NIIS(I))=ICSI
43933 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
43936 C...Boost interfering initial partons to rest frame
43937 C...and reconstruct their polar and azimuthal angles.
43941 K(N+I,J)=K(IPA(I),J)
43942 P(N+I,J)=P(IPA(I),J)
43946 DO 220 I=3,2+NIIS(1)
43948 K(N+I,J)=K(IIIS(1,I-2),J)
43949 P(N+I,J)=P(IIIS(1,I-2),J)
43953 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
43955 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
43956 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
43960 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
43961 & -PS(2)/PS(4),-PS(3)/PS(4))
43962 PHI=PYANGL(P(N+1,1),P(N+1,2))
43963 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
43964 THE=PYANGL(P(N+1,3),P(N+1,1))
43965 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
43966 DO 250 I=3,2+NIIS(1)
43967 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
43968 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
43970 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
43971 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
43972 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
43973 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
43977 C...Define imagined single initiator of shower for parton system.
43979 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
43980 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
43981 IF(MSTU(21).GE.1) RETURN
43999 C...Loop over partons that may branch.
44002 IF(NPA.EQ.1) IM=NS-1
44005 IF(IM.GT.N) GOTO 510
44007 IF(KFLM.GT.40) GOTO 270
44008 IF(KSH(KFLM).EQ.0) GOTO 270
44010 IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
44011 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
44016 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
44017 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
44018 IF(MSTU(21).GE.1) RETURN
44021 C...Position of aunt (sister to branching parton).
44022 C...Origin and flavour of daughters.
44025 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
44026 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
44038 K(N+I,2)=K(IPA(I),2)
44040 ELSEIF(KFLM.NE.21) THEN
44043 ELSEIF(K(IM,5).EQ.21) THEN
44051 C...Reset flags on daughters and tries made.
44056 KFLD(IP)=IABS(K(N+IP,2))
44057 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
44061 IF(KFLD(IP).LE.40) THEN
44062 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
44067 C...Maximum virtuality of daughters.
44070 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
44071 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
44072 P(N+I,5)=MIN(QMAX,PS(5))
44073 IF(IP2.LE.-5) P(N+I,5)=MAX(P(N+I,5),
44074 & 2D0*PMTH(3,IABS(K(N+I,2))))
44075 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
44076 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
44079 IF(MSTJ(43).LE.2) PEM=V(IM,2)
44080 IF(MSTJ(43).GE.3) PEM=P(IM,4)
44081 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
44082 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
44083 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
44087 IF(ISI(I).EQ.1) THEN
44089 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
44090 & ISIGN(2,K(N+I,2))
44091 IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
44093 V(N+I,5)=P(N+I,5)**2
44096 C...Choose one of the daughters for evolution.
44098 IF(NEP.EQ.1) INUM=1
44100 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
44103 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
44105 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
44106 & ISIGN(2,K(N+I,2))
44107 IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
44113 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
44114 RPM=P(N+I,5)/PMSD(I)
44116 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
44117 & ISIGN(2,K(N+I,2))
44118 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
44126 C...Cancel choice of predetermined daughter already treated.
44129 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
44130 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
44131 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
44132 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
44133 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
44136 C...Store information on choice of evolving daughter.
44140 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
44143 KFL(I)=IABS(K(IEP(I),2))
44145 ITRY(INUM)=ITRY(INUM)+1
44146 IF(ITRY(INUM).GT.200) THEN
44147 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
44148 IF(MSTU(21).GE.1) RETURN
44151 IF(KFL(1).GT.40) GOTO 430
44152 IF(KSH(KFL(1)).EQ.0) GOTO 430
44154 IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
44155 &ISIGN(2,K(IEP(1),2))
44156 IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
44158 C...Check if evolution already predetermined for daughter.
44160 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
44161 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
44162 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
44163 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
44164 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
44167 IF(IPSPD.NE.0) ISSET(INUM)=1
44169 C...Select side for interference with initial state partons.
44170 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
44173 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
44175 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
44176 IF(PYR(0).GT.0.5D0) ISII(III)=1
44177 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
44179 IF(PYR(0).GT.0.5D0) ISII(III)=2
44183 C...Calculate allowed z range.
44186 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
44189 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
44190 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
44192 IF(MOD(MSTJ(43),2).EQ.1) THEN
44194 ZCE=PMTH(2,22)/PMED
44195 IF(KFL(1).GE.11.AND.KFL(1).LE.18) ZCE=0.5D0*PARJ(90)/PMED
44197 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
44198 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
44200 IF(KFL(1).GE.11.AND.KFL(1).LE.18) PMTMPE=0.5D0*PARJ(90)
44201 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
44202 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
44205 ZCE=MIN(ZCE,0.49991D0)
44206 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
44207 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
44208 P(IEP(1),5)=PMTH(1,IFL)
44209 V(IEP(1),5)=P(IEP(1),5)**2
44213 C...Integral of Altarelli-Parisi z kernel for QCD.
44214 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
44215 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
44216 ELSEIF(MSTJ(49).EQ.0) THEN
44217 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
44219 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
44220 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
44221 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
44222 ELSEIF(MSTJ(49).EQ.1) THEN
44223 FBR=(1D0-2D0*ZC)/3D0
44224 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4D0*FBR
44226 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
44227 ELSEIF(KFL(1).EQ.21) THEN
44228 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
44230 FBR=2D0*LOG((1D0-ZC)/ZC)
44233 C...Reset QCD probability for lepton.
44234 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0D0
44236 C...Integral of Altarelli-Parisi kernel for photon emission.
44237 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
44238 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
44239 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
44242 C...Inner veto algorithm starts. Find maximum mass for evolution.
44243 390 PMS=V(IEP(1),5)
44248 IF(KFL(I).LE.40) THEN
44250 IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
44251 & ISIGN(2,K(IEP(I),2))
44252 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
44256 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
44259 C...Select mass for daughter in QCD evolution.
44261 DO 410 IFF=4,MSTJ(45)
44262 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
44264 C...Already predetermined choice.
44265 IF(IPSPD.NE.0) THEN
44266 PMSQCD=P(IPSPD,5)**2
44267 ELSEIF(FBR.LT.1D-3) THEN
44269 ELSEIF(MSTJ(44).LE.0) THEN
44270 PMSQCD=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
44271 ELSEIF(MSTJ(44).EQ.1) THEN
44272 PMSQCD=4D0*ALAMS*(0.25D0*PMS/ALAMS)**(PYR(0)**(B0/FBR))
44274 PMSQCD=PMS*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
44276 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=
44281 C...Select mass for daughter in QED evolution.
44282 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18.AND.
44284 PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
44285 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
44287 IF(PMSQED.GT.PMSQCD) THEN
44293 C...Check whether daughter mass below cutoff.
44294 P(IEP(1),5)=SQRT(V(IEP(1),5))
44295 IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
44296 P(IEP(1),5)=PMTH(1,IFL)
44297 V(IEP(1),5)=P(IEP(1),5)**2
44301 C...Already predetermined choice of z, and flavour in g -> qqbar.
44302 IF(IPSPD.NE.0) THEN
44305 PMSGD1=P(IPSGD1,5)**2
44306 PMSGD2=P(IPSGD2,5)**2
44307 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
44308 & 4D0*PMSGD1*PMSGD2))
44309 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
44310 & PMSGD1+PMSGD2)/ALAMPS
44311 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
44312 IF(KFL(1).NE.21) THEN
44315 K(IEP(1),5)=IABS(K(IPSGD1,2))
44318 C...Select z value of branching: q -> qgamma.
44319 ELSEIF(MCE.EQ.2) THEN
44320 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
44321 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
44324 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
44325 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
44326 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
44327 IF(IGM.EQ.0.AND.M3JCM.EQ.1) Z=1D0-(1D0-Z)**RESCZ
44328 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
44330 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
44331 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
44332 IF(PYR(0).GT.0.5D0) Z=1D0-Z
44333 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390
44335 ELSEIF(MSTJ(49).NE.1) THEN
44337 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390
44338 KFLB=1+INT(MSTJ(45)*PYR(0))
44339 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
44340 IF(PMQ.GE.1D0) GOTO 390
44341 IF(MSTJ(44).LE.2) THEN
44342 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 390
44343 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
44344 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
44345 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390
44347 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 390
44351 C...Ditto for scalar gluon model.
44352 ELSEIF(KFL(1).NE.21) THEN
44353 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
44355 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
44356 Z=ZC+(1D0-2D0*ZC)*PYR(0)
44359 Z=ZC+(1D0-2D0*ZC)*PYR(0)
44360 KFLB=1+INT(MSTJ(45)*PYR(0))
44361 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
44362 IF(PMQ.GE.1D0) GOTO 390
44366 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
44367 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
44368 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.MSTJ(44).EQ.3) THEN
44369 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 390
44371 IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
44372 IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390
44376 C...Check if z consistent with chosen m.
44377 IF(KFL(1).EQ.21) THEN
44378 KFLGD1=IABS(K(IEP(1),5))
44382 KFLGD2=IABS(K(IEP(1),5))
44386 ELSEIF(NEP.GE.3) THEN
44388 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
44389 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
44391 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
44392 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
44394 IF(MOD(MSTJ(43),2).EQ.1) THEN
44396 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
44397 PMQTH3=0.5D0*PARJ(82)
44398 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
44399 IF(KFL(1).GE.11.AND.KFL(1).LE.18) PMQTH3=0.5D0*PARJ(90)
44400 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
44401 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
44402 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
44406 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
44409 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.MSTJ(44).EQ.3) THEN
44410 ELSEIF(IPSPD.NE.0) THEN
44414 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
44416 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
44418 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
44420 C...Width suppression for q -> q + g.
44421 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
44423 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
44427 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
44428 IF(MSTJ(40).EQ.1) THEN
44429 IF(CHI.LT.PYR(0)) GOTO 390
44430 ELSEIF(MSTJ(40).EQ.2) THEN
44431 IF(1D0-CHI.LT.PYR(0)) GOTO 390
44435 C...Three-jet matrix element correction (on both sides).
44436 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
44437 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
44438 X2=1D0-V(IEP(1),5)/V(NS+1,5)
44439 X3=(1D0-X1)+(1D0-X2)
44442 KI2=K(IPA(3-INUM),2)
44443 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0
44444 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0
44445 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
44446 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
44447 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
44448 ELSEIF(MSTJ(49).NE.1.AND.M3JCM.NE.1) THEN
44449 WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
44450 & (1D0-X2)/X3*(X2/(2D0-X1))**2
44452 ELSEIF(MSTJ(49).NE.1) THEN
44453 X1=(1D0+(V(IEP(1),5)-PQMES)/V(NS+1,5))*
44454 & (Z+(1D0-Z)*PQMES/V(IEP(1),5))
44455 X2=1D0-(V(IEP(1),5)-PQMES)/V(NS+1,5)
44456 X3=(1D0-X1)+(1D0-X2)
44457 Z1SH=(X1-(PQMES/V(NS+1,5))*(X3/MAX(1D-10,1D0-X2)))/(2D0-X2)
44458 Z2SH=(X2-(PQMES/V(NS+1,5))*(X3/MAX(1D-10,1D0-X1)))/(2D0-X1)
44459 WSHOW=(((1D0-X1)/(2D0-X2))*(1D0+Z1SH**2)/MAX(1D-10,1D0-Z1SH)+
44460 & ((1D0-X2)/(2D0-X1))*(1D0+Z2SH**2)/MAX(1D-10,1D0-Z2SH))/RESCZ
44461 WME=X1**2+X2**2-QME*X3-0.5D0*QME**2-
44462 & (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-10,1D0-X1)+
44463 & (1D0-X1)/MAX(1D-10,1D0-X2))
44465 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
44467 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
44470 IF(WME.LT.PYR(0)*WSHOW) GOTO 390
44472 C...Impose angular ordering by rejection of nonordered emission.
44473 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0)
44475 PEMAO=V(IM,1)*P(IM,4)
44476 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
44477 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.MSTJ(42).EQ.4) THEN
44479 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.MSTJ(42).EQ.3)
44482 PMDAO=PMTH(2,K(IEP(1),5))
44483 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
44486 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
44490 420 IF(K(IAOM,5).EQ.22) THEN
44492 IF(K(IAOM,3).LE.NS) MAOM=0
44493 IF(MAOM.EQ.1) GOTO 420
44495 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
44496 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
44497 IF(THE2ID.LT.THE2IM) GOTO 390
44501 C...Impose user-defined maximum angle at first branching.
44502 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
44503 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
44504 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
44505 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 390
44506 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
44507 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
44508 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 390
44509 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
44510 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
44511 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 390
44515 C...Impose angular constraint in first branching from interference
44516 C...with initial state partons.
44517 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
44518 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
44519 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
44520 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
44521 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
44522 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
44526 C...End of inner veto algorithm. Check if only one leg evolved so far.
44530 IF(NEP.EQ.1) GOTO 460
44531 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
44533 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
44534 IF(KSH(KFLD(I)).EQ.1) THEN
44536 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
44537 & ISIGN(2,K(N+I,2))
44538 IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
44543 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
44545 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
44546 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
44547 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
44548 PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S-
44549 & PA1S**2-PA2S**2-PA3S**2)/PA1S
44550 IF(PTS.LE.0D0) GOTO 330
44551 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
44553 KFLDA=IABS(K(I1,2))
44554 IF(KFLDA.GT.40) GOTO 450
44555 IF(KSH(KFLDA).EQ.0) GOTO 450
44557 IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
44559 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
44560 IF(KFLDA.EQ.21) THEN
44561 KFLGD1=IABS(K(I1,5))
44565 KFLGD2=IABS(K(I1,5))
44568 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
44569 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
44571 IF(I1.EQ.N+1) ZM=V(IM,1)
44572 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
44573 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
44574 & 4D0*V(N+1,5)*V(N+2,5))
44575 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
44578 IF(MOD(MSTJ(43),2).EQ.1) THEN
44579 PMQTH3=0.5D0*PARJ(82)
44580 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
44581 IF(KFLDA.GE.11.AND.KFLDA.LE.18) PMQTH3=0.5D0*PARJ(90)
44583 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
44584 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
44585 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
44586 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
44590 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
44593 IF(KFLDA.EQ.21.AND.KFLGD1.LT.10.AND.MSTJ(44).EQ.3) THEN
44597 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
44598 & ISSET(1).EQ.0) THEN
44600 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
44601 & ISSET(2).EQ.0) THEN
44605 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
44607 IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
44609 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
44612 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
44613 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
44614 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
44615 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
44616 IF(ISL(1).EQ.1) ISL(2)=0
44617 IF(ISL(1).EQ.0) ISLM=1
44618 IF(ISL(2).EQ.0) ISLM=2
44620 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
44623 IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
44626 IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
44629 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
44630 & PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
44631 PMQ1=V(N+1,5)/V(IM,5)
44632 PMQ2=V(N+2,5)/V(IM,5)
44633 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
44638 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
44642 C...Accepted branch. Construct four-momentum for initial partons.
44648 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
44650 P(N+1,4)=P(IPA(1),4)
44652 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
44653 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
44656 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
44661 P(N+2,4)=P(IM,5)-PED1
44664 ELSEIF(NEP.EQ.3) THEN
44667 P(N+1,3)=SQRT(MAX(0D0,PA1S))
44670 P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3)
44673 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
44678 C...Construct transverse momentum for ordinary branching in shower.
44682 465 LOOPPT=LOOPPT+1
44683 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
44684 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
44685 IF(PZM.LE.0D0) THEN
44687 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
44688 & MSTJ(44).EQ.3) THEN
44689 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
44690 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
44691 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
44692 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
44694 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
44696 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
44699 ELSEIF(PTS.LT.0D0) THEN
44702 PT=SQRT(MAX(0D0,PTS))
44704 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
44706 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
44707 & .AND.IAU.NE.0) THEN
44708 IF(K(IGM,3).NE.0) MAZIP=1
44710 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
44711 IF(MAZIP.EQ.0) ZAU=0D0
44712 IF(K(IGM,2).NE.21) THEN
44713 HAZIP=2D0*ZAU/(1D0+ZAU**2)
44715 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
44717 IF(K(N+1,2).NE.21) THEN
44718 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
44720 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
44724 C...Find coefficient of azimuthal asymmetry due to soft gluon
44727 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
44728 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
44729 IF(K(IGM,3).NE.0) MAZIC=N+1
44730 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
44731 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
44732 & ZM.GT.0.5D0) MAZIC=N+2
44733 IF(K(IAU,2).EQ.22) MAZIC=0
44735 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
44737 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
44738 IF(MAZIC.EQ.0) ZGM=1D0
44739 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
44740 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
44741 HAZIC=MIN(0.95D0,HAZIC)
44745 C...Construct energies for ordinary branching in shower.
44746 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
44747 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
44748 & MSTJ(44).EQ.3) THEN
44749 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
44750 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
44751 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
44752 P(N+1,4)=PEM*V(IM,1)
44754 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
44755 & SQRT(PMLS)*ZM)/V(IM,5)
44758 C...Already predetermined choice of phi angle or not
44760 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
44762 IF(K(IPSPD,4).GT.0) THEN
44764 IF(IM.EQ.NS+2) THEN
44765 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
44767 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
44770 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
44772 IF(K(IPSPD,4).GT.0) THEN
44774 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
44775 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
44776 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
44777 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
44778 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
44779 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
44783 C...Construct momenta for ordinary branching in shower.
44784 P(N+1,1)=PT*COS(PHI)
44785 P(N+1,2)=PT*SIN(PHI)
44786 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
44787 & MSTJ(44).EQ.3) THEN
44788 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
44789 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
44790 ELSEIF(PZM.GT.0D0) THEN
44791 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
44792 & 2D0*PEM*P(N+1,4))/PZM
44798 P(N+2,3)=PZM-P(N+1,3)
44799 P(N+2,4)=PEM-P(N+1,4)
44800 IF(MSTJ(43).LE.2) THEN
44801 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
44802 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
44806 C...Rotate and boost daughters.
44808 IF(MSTJ(43).LE.2) THEN
44809 BEX=P(IGM,1)/P(IGM,4)
44810 BEY=P(IGM,2)/P(IGM,4)
44811 BEZ=P(IGM,3)/P(IGM,4)
44812 GA=P(IGM,4)/P(IGM,5)
44813 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
44822 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
44823 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
44824 IF(PTIMB.GT.1D-4) THEN
44825 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
44830 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
44831 & SIN(THE)*COS(PHI)*P(I,3)
44832 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
44833 & SIN(THE)*SIN(PHI)*P(I,3)
44834 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
44836 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
44837 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
44838 P(I,1)=DP(1)+DGABP*BEX
44839 P(I,2)=DP(2)+DGABP*BEY
44840 P(I,3)=DP(3)+DGABP*BEZ
44841 P(I,4)=GA*(DP(4)+DBP)
44845 C...Weight with azimuthal distribution, if required.
44846 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
44852 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
44853 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
44854 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
44856 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
44857 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
44859 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
44860 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
44861 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
44862 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
44863 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
44864 IF(MAZIP.NE.0) THEN
44865 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
44868 IF(MAZIC.NE.0) THEN
44869 IF(MAZIC.EQ.N+2) CAD=-CAD
44870 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
44871 & .LT.PYR(0)) GOTO 470
44876 C...Azimuthal anisotropy due to interference with initial state partons.
44877 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
44878 &K(N+2,2).EQ.21)) THEN
44880 IF(ISII(III).GE.1) THEN
44882 IF(K(N+1,2).NE.21) IAZIID=N+2
44883 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
44884 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
44885 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
44886 IF(III.EQ.2) THEIID=PARU(1)-THEIID
44887 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
44888 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
44889 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
44890 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
44891 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
44892 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
44893 & .LT.PYR(0)) GOTO 470
44897 C...Continue loop over partons that may branch, until none left.
44898 IF(IGM.GE.0) K(IM,1)=14
44901 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
44902 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
44903 IF(MSTU(21).GE.1) N=NS
44904 IF(MSTU(21).GE.1) RETURN
44908 C...Set information on imagined shower initiator.
44909 510 IF(NPA.GE.2) THEN
44913 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
44921 C...Reconstruct string drawing information.
44922 DO 520 I=NS+1+IIM,N
44923 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
44925 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
44926 & IABS(K(I,2)).LE.18) THEN
44928 ELSEIF(K(I,1).LE.10) THEN
44929 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
44930 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
44931 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
44932 ID1=MOD(K(I,4),MSTU(5))
44933 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
44934 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
44935 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
44936 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
44937 K(ID1,4)=K(ID1,4)+MSTU(5)*I
44938 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
44939 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
44940 K(ID2,5)=K(ID2,5)+MSTU(5)*I
44942 ID1=MOD(K(I,4),MSTU(5))
44944 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
44945 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
44946 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
44947 K(ID1,4)=K(ID1,4)+MSTU(5)*I
44948 K(ID1,5)=K(ID1,5)+MSTU(5)*I
44958 C...Transformation from CM frame.
44964 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
44965 & /(1D0+GA)-P(IPA(1),4))
44972 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
44973 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
44974 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
44976 CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
44977 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
44978 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
44981 CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0)
44984 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
44986 C...Decay vertex of shower.
44993 C...Delete trivial shower, else connect initiators.
44994 IF(N.LE.NS+NPA+IIM) THEN
44999 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
45000 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
45001 K(NS+IIM+IP,3)=IPA(IP)
45002 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
45003 IF(K(NS+IIM+IP,1).NE.1) THEN
45004 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
45005 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
45013 C*********************************************************************
45016 C...Modifies an event so as to approximately take into account
45017 C...Bose-Einstein effects according to a simple phenomenological
45018 C...parametrization.
45020 SUBROUTINE PYBOEI(NSAV)
45022 C...Double precision and integer declarations.
45023 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45024 IMPLICIT INTEGER(I-N)
45025 INTEGER PYK,PYCHGE,PYCOMP
45026 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
45028 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45029 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45030 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45031 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
45032 C...Local arrays and data.
45033 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
45034 &BEIW(100),BEI3W(100)
45035 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
45036 C...Statement function: squared invariant mass.
45037 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
45038 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
45040 C...Boost event to overall CM frame. Calculate CM energy.
45041 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
45047 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
45048 & .AND.K(I,3).GT.0) THEN
45049 KFMA=IABS(K(K(I,3),2))
45050 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
45052 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
45054 DPS(J)=DPS(J)+P(I,J)
45057 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
45061 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
45064 C...Reserve copy of particles by species at end of record.
45070 DO 180 IBE=1,MIN(10,MSTJ(52)+1)
45071 NBE(IBE)=NBE(IBE-1)
45073 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
45074 DO 140 IIBE=1,IBE-1
45075 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 170
45078 IF(K(I,2).NE.KFBE(IBE)) GOTO 170
45080 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
45081 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
45082 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
45085 NBE(IBE)=NBE(IBE)+1
45089 SMMIN=MIN(SMMIN,P(I,5))
45090 IF(MSTJ(53).NE.0.OR.MSTJ(56).GT.0) THEN
45092 150 IF(K(IM,3).GT.0) THEN
45094 IF(ABS(K(IM,2)).NE.24) GOTO 150
45095 K(NBE(IBE),5)=K(IM,2)
45096 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
45097 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
45104 P(NBE(IBE),5)=-1.0D0
45107 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 500
45109 C...Calculate separation between W+ and W-
45111 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0) THEN
45116 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
45117 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
45118 TAUP=-TAUPD*LOG(PYR(IDUM))
45119 TAUN=-TAUND*LOG(PYR(IDUM))
45120 DXP=TAUP*PYP(IWP,8)/DMP
45121 DXN=TAUN*PYP(IWN,8)/DMN
45123 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
45128 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
45129 DO 210 IBE=1,MIN(9,MSTJ(52))
45130 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
45133 DO 190 I2M=NBE(IBE-1)+1,NBE(IBE)-1
45134 IF(I2M.EQ.I1M) GOTO 190
45136 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
45137 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
45138 & (P(I1,5)+P(I2,5))**2
45139 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
45148 C...Tabulate integral for subsequent momentum shift.
45149 DO 390 IBE=1,MIN(9,MSTJ(52))
45150 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 260
45151 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
45153 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
45154 & NBE(7)-NBE(6)).LE.1) GOTO 260
45155 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 260
45156 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
45157 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
45158 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
45159 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
45160 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
45161 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
45162 QDELW=0.1D0*MIN(PMHQ,SIGW)
45163 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
45164 IF(MSTJ(51).EQ.1) THEN
45165 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
45166 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
45167 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
45168 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
45169 BEEX=EXP(0.5D0*QDEL/PARJ(93))
45170 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
45171 BEEXW=EXP(0.5D0*QDELW/SIGW)
45172 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
45173 BERT=EXP(-QDEL/PARJ(93))
45174 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
45175 BERTW=EXP(-QDELW/SIGW)
45176 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
45178 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
45179 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
45180 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
45181 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
45184 QBIN=QDEL*(IBIN-0.5D0)
45185 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
45186 IF(MSTJ(51).EQ.1) THEN
45188 BEI(IBIN)=BEI(IBIN)*BEEX
45190 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
45192 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
45194 DO 230 IBIN=1,NBIN3
45195 QBIN=QDEL3*(IBIN-0.5D0)
45196 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
45197 IF(MSTJ(51).EQ.1) THEN
45199 BEI3(IBIN)=BEI3(IBIN)*BEEX3
45201 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
45203 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
45205 DO 240 IBIN=1,NBINW
45206 QBIN=QDELW*(IBIN-0.5D0)
45207 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
45208 IF(MSTJ(51).EQ.1) THEN
45210 BEIW(IBIN)=BEIW(IBIN)*BEEXW
45212 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
45214 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
45216 DO 250 IBIN=1,NBIN3W
45217 QBIN=QDEL3W*(IBIN-0.5D0)
45218 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
45219 & SQRT(QBIN**2+PMHQ**2)
45220 IF(MSTJ(51).EQ.1) THEN
45221 BEEX3W=BEEX3W*BERT3W
45222 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
45224 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
45226 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
45229 C...Loop through particle pairs and find old relative momentum.
45230 260 DO 380 I1M=NBE(IBE-1)+1,NBE(IBE)-1
45232 DO 370 I2M=I1M+1,NBE(IBE)
45233 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 370
45234 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 370
45236 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
45237 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
45238 IF(Q2OLD.LE.0.0D0) GOTO 370
45241 C...Calculate new relative momentum.
45246 IF(QOLD.LT.1D-3*QDEL) THEN
45248 ELSEIF(QOLD.LE.QDEL) THEN
45250 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
45253 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
45254 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
45255 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
45257 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45259 270 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
45260 IF(QOLD.LT.1D-3*QDEL3) THEN
45262 ELSEIF(QOLD.LE.QDEL3) THEN
45264 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
45267 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
45268 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
45269 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
45271 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45273 280 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
45276 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
45277 IF(MSTJ(56).LE.0.OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
45278 & K(I1M,5).EQ.K(I2M,5)) GOTO 310
45280 IF(QOLD.LT.1D-3*QDELW) THEN
45282 ELSEIF(QOLD.LE.QDELW) THEN
45284 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
45287 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
45288 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
45289 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
45291 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45293 290 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
45294 IF(QOLD.LT.1D-3*QDEL3W) THEN
45296 ELSEIF(QOLD.LE.QDEL3W) THEN
45298 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
45301 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
45302 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
45303 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45305 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45307 300 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
45309 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
45311 310 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
45313 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
45314 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
45316 IF(MSTJ(54).GE.1) THEN
45317 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
45319 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
45320 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
45322 ELSEIF(MSTJ(54).LE.-1) THEN
45323 EDEL=P(I1,4)+P(I2,4)-
45324 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
45325 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
45326 & (P(I1,3)-P(I2,3))**2
45331 SM1=(P(I1,5)+SMMIN)**2
45332 DO 350 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
45333 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 350
45334 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 350
45335 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
45336 & K(I3M,5).NE.K(I1M,5)) GOTO 350
45338 IF(K(I3,2).EQ.K(I1,2)) GOTO 350
45341 SM3=(P(I3,5)+SMMIN)**2
45342 IF(MSTJ(54).EQ.-2) THEN
45343 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
45344 & S23*MIN(SM1,SM3))*SM1)
45346 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
45347 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
45348 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
45349 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
45351 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
45352 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
45355 IF(WMAX*WI.GE.1.0) GOTO 350
45357 DO 340 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
45358 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 340
45359 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 340
45360 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
45361 & K(I4M,5).NE.K(I1M,5)) GOTO 340
45363 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
45365 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
45366 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
45367 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
45369 IF(MSTJ(54).EQ.-2) THEN
45373 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
45374 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
45375 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
45376 W=MIN(W,MIN(S23,S24)*S13*S14)
45379 C...weight=1-cos(theta)/mtot2
45380 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
45381 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
45382 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
45383 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
45385 IF(W.LE.WMAX) GOTO 340
45387 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
45388 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
45389 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
45390 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
45391 IF(W.LE.WMAX) GOTO 340
45397 IF(MI4.EQ.0) GOTO 370
45400 EOLD=P(I3,4)+P(I4,4)
45402 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
45403 & (P(I3,3)+P(I4,3))**2
45404 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
45405 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
45406 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
45408 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
45409 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
45416 C...Shift momenta and recalculate energies.
45420 DO 420 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
45424 P(I,J)=P(I,J)+P(IM,J)
45426 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
45429 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
45434 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
45435 430 ALPHA=(ESUMP-ESUM)/PROD
45436 PARJ(96)=PARJ(96)+ALPHA
45439 DO 460 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
45442 P(I,J)=P(I,J)+ALPHA*V(IM,J)
45444 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
45447 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
45450 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
45454 C...Rescale all momenta for energy conservation.
45458 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 470
45460 PQS=PQS+P(I,5)**2/P(I,4)
45463 FAC=(PECM-PQS)/(PES-PQS)
45465 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 490
45469 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
45472 C...Boost back to correct reference frame.
45473 500 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
45475 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
45481 C*********************************************************************
45484 C...Calculates the momentum shift in a system of two particles assuming
45485 C...the relative momentum squared should be shifted to Q2NEW. NI is the
45486 C...last position occupied in /PYJETS/.
45488 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
45490 C...Double precision and integer declarations.
45491 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45492 IMPLICIT INTEGER(I-N)
45493 INTEGER PYK,PYCHGE,PYCOMP
45494 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
45496 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45497 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45498 SAVE /PYJETS/,/PYDAT1/
45499 C...Local arrays and data.
45503 IF(MSTJ(55).EQ.0) THEN
45505 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
45506 & (P(I1,3)-P(I2,3))**2
45507 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
45508 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
45512 DA=SE*DE*DP12-DP2*DQ2SE
45513 DB=DP2*DQ2SE-DP12**2
45514 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
45516 PD=HA*(P(I1,J)-P(I2,J))
45528 DP(J)=P(I1,J)+P(I2,J)
45531 C...Boost to cms and rotate first particle to z-axis
45532 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
45533 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
45534 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
45535 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
45536 S=Q2NEW+(P(I1,5)+P(I2,5))**2
45537 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
45541 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
45545 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
45546 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
45547 CALL PYROBO(NI+1,NI+2,THE,PHI,
45548 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
45551 P(NI+1,J)=P(NI+1,J)-P(I1,J)
45552 P(NI+2,J)=P(NI+2,J)-P(I2,J)
45558 C*********************************************************************
45561 C...Gives the mass of a particle/parton.
45563 FUNCTION PYMASS(KF)
45565 C...Double precision and integer declarations.
45566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45567 IMPLICIT INTEGER(I-N)
45568 INTEGER PYK,PYCHGE,PYCOMP
45570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45571 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45572 SAVE /PYDAT1/,/PYDAT2/
45574 C...Reset variables. Compressed code. Special case for popcorn diquarks.
45583 C...Guarantee use of constituent masses for internal checks.
45584 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
45585 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
45586 PARF(106)=PMAS(6,1)
45587 PARF(107)=PMAS(7,1)
45588 PARF(108)=PMAS(8,1)
45590 PYMASS=PARF(100+KFA)
45591 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
45592 ELSEIF(MSTJ(93).EQ.1) THEN
45593 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
45595 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
45598 C...Other masses can be read directly off table.
45603 C...Optional mass broadening according to truncated Breit-Wigner
45604 C...(either in m or in m^2).
45605 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
45606 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
45607 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
45608 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
45611 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
45612 & (PM0*PMAS(KC,2)))
45613 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
45614 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
45615 & (PMUPP-PMLOW)*PYR(0))))
45623 C*********************************************************************
45626 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
45627 C...for Higgs couplings. Everything else sent on to PYMASS.
45629 FUNCTION PYMRUN(KF,Q2)
45631 C...Double precision and integer declarations.
45632 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45633 IMPLICIT INTEGER(I-N)
45634 INTEGER PYK,PYCHGE,PYCOMP
45636 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45637 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45638 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45639 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
45641 C...Most masses not handled here.
45643 IF(KFA.EQ.0.OR.KFA.GT.5) THEN
45646 C...Current-algebra masses, but no Q2 dependence.
45647 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
45648 PYMRUN=PARF(90+KFA)
45650 C...Running current-algebra masses.
45653 PYMRUN=PARF(90+KFA)*
45654 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
45655 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
45661 C*********************************************************************
45664 C...Gives the particle/parton name as a character string.
45666 SUBROUTINE PYNAME(KF,CHAU)
45668 C...Double precision and integer declarations.
45669 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45670 IMPLICIT INTEGER(I-N)
45671 INTEGER PYK,PYCHGE,PYCOMP
45673 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45674 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45675 COMMON/PYDAT4/CHAF(500,2)
45677 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
45678 C...Local character variable.
45681 C...Read out code with distinction particle/antiparticle.
45684 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
45690 C*********************************************************************
45693 C...Gives three times the charge for a particle/parton.
45695 FUNCTION PYCHGE(KF)
45697 C...Double precision and integer declarations.
45698 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45699 IMPLICIT INTEGER(I-N)
45700 INTEGER PYK,PYCHGE,PYCOMP
45702 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45705 C...Read out charge and change sign for antiparticle.
45708 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
45713 C*********************************************************************
45716 C...Compress the standard KF codes for use in mass and decay arrays;
45717 C...also checks whether a given code actually is defined.
45719 FUNCTION PYCOMP(KF)
45721 C...Double precision and integer declarations.
45722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45723 IMPLICIT INTEGER(I-N)
45724 INTEGER PYK,PYCHGE,PYCOMP
45726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45728 SAVE /PYDAT1/,/PYDAT2/
45729 C...Local arrays and saved data.
45730 DIMENSION KFORD(100:500),KCORD(101:500)
45731 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
45733 C...Whenever necessary reorder codes for faster search.
45734 IF(MSTU(20).EQ.0) THEN
45739 IF(KFA.LE.100) GOTO 120
45741 DO 100 I1=NFORD-1,0,-1
45742 IF(KFA.GE.KFORD(I1)) GOTO 110
45743 KFORD(I1+1)=KFORD(I1)
45744 KCORD(I1+1)=KCORD(I1)
45746 110 KFORD(I1+1)=KFA
45754 C...Fast action if same code as in latest call.
45755 IF(KF.EQ.KFLAST) THEN
45760 C...Starting values. Remove internal diquark flags.
45763 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
45764 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
45766 C...Simple cases: direct translation.
45767 IF(KFA.GT.KFORD(NFORD)) THEN
45768 ELSEIF(KFA.LE.100) THEN
45771 C...Else binary search.
45775 130 IAVG=(IMIN+IMAX)/2
45776 IF(KFORD(IAVG).GT.KFA) THEN
45778 IF(IMAX.GT.IMIN+1) GOTO 130
45779 ELSEIF(KFORD(IAVG).LT.KFA) THEN
45781 IF(IMAX.GT.IMIN+1) GOTO 130
45787 C...Check if antiparticle allowed.
45788 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
45789 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
45792 C...Save codes for possible future fast action.
45799 C*********************************************************************
45802 C...Informs user of errors in program execution.
45804 SUBROUTINE PYERRM(MERR,CHMESS)
45806 C...Double precision and integer declarations.
45807 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45808 IMPLICIT INTEGER(I-N)
45809 INTEGER PYK,PYCHGE,PYCOMP
45811 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45812 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45813 SAVE /PYJETS/,/PYDAT1/
45814 C...Local character variable.
45815 CHARACTER CHMESS*(*)
45817 C...Write first few warnings, then be silent.
45818 IF(MERR.LE.10) THEN
45819 MSTU(27)=MSTU(27)+1
45821 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
45822 & MERR,MSTU(31),CHMESS
45824 C...Write first few errors, then be silent or stop program.
45825 ELSEIF(MERR.LE.20) THEN
45826 MSTU(23)=MSTU(23)+1
45828 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
45829 & MERR-10,MSTU(31),CHMESS
45830 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
45831 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
45832 WRITE(MSTU(11),5200)
45833 IF(MERR.NE.17) CALL PYLIST(2)
45837 C...Stop program in case of irreparable error.
45839 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
45843 C...Formats for output.
45844 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
45845 &' PYEXEC calls:'/5X,A)
45846 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
45847 &' PYEXEC calls:'/5X,A)
45848 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
45850 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
45851 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
45856 C*********************************************************************
45859 C...Calculates the running alpha_electromagnetic.
45861 FUNCTION PYALEM(Q2)
45863 C...Double precision and integer declarations.
45864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45865 IMPLICIT INTEGER(I-N)
45866 INTEGER PYK,PYCHGE,PYCOMP
45868 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45871 C...Calculate real part of photon vacuum polarization.
45872 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
45873 C...For hadrons use parametrization of H. Burkhardt et al.
45874 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
45875 AEMPI=PARU(101)/(3D0*PARU(1))
45876 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
45878 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
45880 ELSEIF(MSTU(101).EQ.2) THEN
45881 RPIGG=1D0-PARU(101)/PARU(103)
45882 ELSEIF(Q2.LT.0.09D0) THEN
45883 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
45884 ELSEIF(Q2.LT.9D0) THEN
45885 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
45886 & 0.00238D0*LOG(1D0+3.927D0*Q2)
45887 ELSEIF(Q2.LT.1D4) THEN
45888 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
45889 & 0.00299D0*LOG(1D0+Q2)
45891 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
45892 & 0.00293D0*LOG(1D0+Q2)
45895 C...Calculate running alpha_em.
45896 PYALEM=PARU(101)/(1D0-RPIGG)
45902 C*********************************************************************
45905 C...Gives the value of alpha_strong.
45907 FUNCTION PYALPS(Q2)
45909 C...Double precision and integer declarations.
45910 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45911 IMPLICIT INTEGER(I-N)
45912 INTEGER PYK,PYCHGE,PYCOMP
45914 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45915 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45916 SAVE /PYDAT1/,/PYDAT2/
45918 C...Constant alpha_strong trivial. Pick artificial Lambda.
45919 IF(MSTU(111).LE.0) THEN
45921 MSTU(118)=MSTU(112)
45923 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
45924 & ((33D0-2D0*MSTU(112))*PARU(111)))
45925 PARU(118)=PARU(111)
45929 C...Find effective Q2, number of flavours and Lambda.
45931 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
45934 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
45935 Q2THR=PARU(113)*PMAS(NF,1)**2
45936 IF(Q2EFF.LT.Q2THR) THEN
45938 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
45942 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
45943 Q2THR=PARU(113)*PMAS(NF+1,1)**2
45944 IF(Q2EFF.GT.Q2THR) THEN
45946 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
45950 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
45951 PARU(117)=SQRT(ALAM2)
45953 C...Evaluate first or second order alpha_strong.
45954 B0=(33D0-2D0*NF)/6D0
45955 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
45956 IF(MSTU(111).EQ.1) THEN
45957 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
45959 B1=(153D0-19D0*NF)/6D0
45960 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
45969 C*********************************************************************
45972 C...Reconstructs an angle from given x and y coordinates.
45974 FUNCTION PYANGL(X,Y)
45976 C...Double precision and integer declarations.
45977 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45978 IMPLICIT INTEGER(I-N)
45979 INTEGER PYK,PYCHGE,PYCOMP
45981 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45986 IF(R.LT.1D-20) RETURN
45987 IF(ABS(X)/R.LT.0.8D0) THEN
45988 PYANGL=SIGN(ACOS(X/R),Y)
45991 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
45992 PYANGL=PARU(1)-PYANGL
45993 ELSEIF(X.LT.0D0) THEN
45994 PYANGL=-PARU(1)-PYANGL
46001 *C*********************************************************************
46004 *C...Generates random numbers uniformly distributed between
46005 *C...0 and 1, excluding the endpoints.
46007 * FUNCTION PYR(IDUMMY)
46009 *C...Double precision and integer declarations.
46010 * IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46011 * IMPLICIT INTEGER(I-N)
46012 * INTEGER PYK,PYCHGE,PYCOMP
46014 * COMMON/PYDATR/MRPY(6),RRPY(100)
46016 *C...Equivalence between commonblock and local variables.
46017 * EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
46018 * &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
46019 * &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
46021 *C...Initialize generation from given seed.
46022 * IF(MRPY2.EQ.0) THEN
46023 * IJ=MOD(MRPY1/30082,31329)
46024 * KL=MOD(MRPY1,30082)
46025 * I=MOD(IJ/177,177)+2
46027 * K=MOD(KL/169,178)+1
46033 * M=MOD(MOD(I*J,179)*K,179)
46037 * L=MOD(53*L+1,169)
46038 * IF(MOD(L*M,64).GE.32) S=S+T
46045 * TWOM24=0.5D0*TWOM24
46047 * RRPY98=362436D0*TWOM24
46048 * RRPY99=7654321D0*TWOM24
46049 * RRPY00=16777213D0*TWOM24
46056 *C...Generate next random number.
46057 * 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
46058 * IF(RUNI.LT.0D0) RUNI=RUNI+1D0
46061 * IF(MRPY4.EQ.0) MRPY4=97
46063 * IF(MRPY5.EQ.0) MRPY5=97
46064 * RRPY98=RRPY98-RRPY99
46065 * IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
46067 * IF(RUNI.LT.0D0) RUNI=RUNI+1D0
46068 * IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
46070 *C...Update counters. Random number to output.
46072 * IF(MRPY3.EQ.1000000000) THEN
46081 *C*********************************************************************
46084 *C...Dumps the state of the random number generator on a file
46085 *C...for subsequent startup from this state onwards.
46087 * SUBROUTINE PYRGET(LFN,MOVE)
46089 *C...Double precision and integer declarations.
46090 * IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46091 * IMPLICIT INTEGER(I-N)
46092 * INTEGER PYK,PYCHGE,PYCOMP
46094 * COMMON/PYDATR/MRPY(6),RRPY(100)
46096 *C...Local character variable.
46097 * CHARACTER CHERR*8
46099 *C...Backspace required number of records (or as many as there are).
46100 * IF(MOVE.LT.0) THEN
46101 * NBCK=MIN(MRPY(6),-MOVE)
46102 * DO 100 IBCK=1,NBCK
46103 * BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
46105 * MRPY(6)=MRPY(6)-NBCK
46108 *C...Unformatted write on unit LFN.
46109 * WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
46110 * &(RRPY(I2),I2=1,100)
46111 * MRPY(6)=MRPY(6)+1
46115 * 110 WRITE(CHERR,'(I8)') IERR
46116 * CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
46122 *C*********************************************************************
46125 *C...Reads a state of the random number generator from a file
46126 *C...for subsequent generation from this state onwards.
46128 * SUBROUTINE PYRSET(LFN,MOVE)
46130 *C...Double precision and integer declarations.
46131 * IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46132 * IMPLICIT INTEGER(I-N)
46133 * INTEGER PYK,PYCHGE,PYCOMP
46135 * COMMON/PYDATR/MRPY(6),RRPY(100)
46137 *C...Local character variable.
46138 * CHARACTER CHERR*8
46140 *C...Backspace required number of records (or as many as there are).
46141 * IF(MOVE.LT.0) THEN
46142 * NBCK=MIN(MRPY(6),-MOVE)
46143 * DO 100 IBCK=1,NBCK
46144 * BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
46146 * MRPY(6)=MRPY(6)-NBCK
46149 *C...Unformatted read from unit LFN.
46150 * NFOR=1+MAX(0,MOVE)
46151 * DO 110 IFOR=1,NFOR
46152 * READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
46153 * & (RRPY(I2),I2=1,100)
46155 * MRPY(6)=MRPY(6)+NFOR
46159 * 120 WRITE(CHERR,'(I8)') IERR
46160 * CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
46166 C*********************************************************************
46169 C...Performs rotations and boosts.
46171 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
46173 C...Double precision and integer declarations.
46174 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46175 IMPLICIT INTEGER(I-N)
46176 INTEGER PYK,PYCHGE,PYCOMP
46178 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46179 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46180 SAVE /PYJETS/,/PYDAT1/
46182 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
46184 C...Find and check range of rotation/boost.
46186 IF(IMIN.LE.0) IMIN=1
46187 IF(MSTU(1).GT.0) IMIN=MSTU(1)
46189 IF(IMAX.LE.0) IMAX=N
46190 IF(MSTU(2).GT.0) IMAX=MSTU(2)
46191 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
46192 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
46196 C...Optional resetting of V (when not set before.)
46197 IF(MSTU(33).NE.0) THEN
46198 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
46206 C...Rotate, typically from z axis to direction (theta,phi).
46207 IF(THE**2+PHI**2.GT.1D-20) THEN
46208 ROT(1,1)=COS(THE)*COS(PHI)
46210 ROT(1,3)=SIN(THE)*COS(PHI)
46211 ROT(2,1)=COS(THE)*SIN(PHI)
46213 ROT(2,3)=SIN(THE)*SIN(PHI)
46218 IF(K(I,1).LE.0) GOTO 140
46224 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
46225 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
46230 C...Boost, typically from rest to momentum/energy=beta.
46231 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
46235 DB=SQRT(DBX**2+DBY**2+DBZ**2)
46237 IF(DB.GT.EPS1) THEN
46238 C...Rescale boost vector if too close to unity.
46239 CALL PYERRM(3,'(PYROBO:) boost vector too large')
46245 DGA=1D0/SQRT(1D0-DB**2)
46247 IF(K(I,1).LE.0) GOTO 160
46252 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
46253 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
46254 P(I,1)=DP(1)+DGABP*DBX
46255 P(I,2)=DP(2)+DGABP*DBY
46256 P(I,3)=DP(3)+DGABP*DBZ
46257 P(I,4)=DGA*(DP(4)+DBP)
46258 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
46259 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
46260 V(I,1)=DV(1)+DGABV*DBX
46261 V(I,2)=DV(2)+DGABV*DBY
46262 V(I,3)=DV(3)+DGABV*DBZ
46263 V(I,4)=DGA*(DV(4)+DBV)
46270 C*********************************************************************
46273 C...Performs global manipulations on the event record, in particular
46274 C...to exclude unstable or undetectable partons/particles.
46276 SUBROUTINE PYEDIT(MEDIT)
46278 C...Double precision and integer declarations.
46279 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46280 IMPLICIT INTEGER(I-N)
46281 INTEGER PYK,PYCHGE,PYCOMP
46283 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46284 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46285 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46286 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
46288 DIMENSION NS(2),PTS(2),PLS(2)
46290 C...Remove unwanted partons/particles.
46291 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
46293 IF(MSTU(2).GT.0) IMAX=MSTU(2)
46294 I1=MAX(1,MSTU(1))-1
46295 DO 110 I=MAX(1,MSTU(1)),IMAX
46296 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
46297 IF(MEDIT.EQ.1) THEN
46298 IF(K(I,1).GT.10) GOTO 110
46299 ELSEIF(MEDIT.EQ.2) THEN
46300 IF(K(I,1).GT.10) GOTO 110
46302 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
46304 ELSEIF(MEDIT.EQ.3) THEN
46305 IF(K(I,1).GT.10) GOTO 110
46307 IF(KC.EQ.0) GOTO 110
46308 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
46309 ELSEIF(MEDIT.EQ.5) THEN
46310 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
46312 IF(KC.EQ.0) GOTO 110
46313 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
46316 C...Pack remaining partons/particles. Origin no longer known.
46325 IF(I1.LT.N) MSTU(3)=0
46326 IF(I1.LT.N) MSTU(70)=0
46329 C...Selective removal of class of entries. New position of retained.
46330 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
46333 K(I,3)=MOD(K(I,3),MSTU(5))
46334 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
46335 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
46336 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
46337 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
46338 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
46339 & K(I,2).EQ.94)) GOTO 120
46340 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
46342 K(I,3)=K(I,3)+MSTU(5)*I1
46345 C...Find new event history information and replace old.
46347 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
46350 130 IM=MOD(K(ID,3),MSTU(5))
46351 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
46352 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
46353 & K(IM,2).NE.94) THEN
46357 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
46358 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
46363 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
46364 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
46365 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
46366 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
46367 & K(K(I,4),3)/MSTU(5)
46368 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
46369 & K(K(I,5),3)/MSTU(5)
46371 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
46372 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
46373 KCD=MOD(K(I,4),MSTU(5))
46374 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
46375 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
46376 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
46377 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
46378 KCD=MOD(K(I,5),MSTU(5))
46379 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
46380 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
46384 C...Pack remaining entries.
46389 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
46396 K(I1,3)=MOD(K(I1,3),MSTU(5))
46398 IF(I.EQ.MSTU(90+IZ)) THEN
46399 MSTU(90)=MSTU(90)+1
46400 MSTU(90+MSTU(90))=I1
46401 PARU(90+MSTU(90))=PARU(90+IZ)
46405 IF(I1.LT.N) MSTU(3)=0
46406 IF(I1.LT.N) MSTU(70)=0
46409 C...Fill in some missing daughter pointers (lost in colour flow).
46410 ELSEIF(MEDIT.EQ.16) THEN
46412 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
46413 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
46414 C...Find daughters who point to mother.
46416 IF(K(I1,3).NE.I) THEN
46417 ELSEIF(K(I,4).EQ.0) THEN
46423 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
46424 IF(K(I,4).NE.0) GOTO 220
46425 C...Find daughters who point to documentation version of mother.
46427 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
46428 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
46429 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
46431 IF(K(I1,3).NE.IM) THEN
46432 ELSEIF(K(I,4).EQ.0) THEN
46438 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
46439 IF(K(I,4).NE.0) GOTO 220
46440 C...Find daughters who point to documentation daughters who,
46441 C...in their turn, point to documentation mother.
46445 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
46447 IF(ID1.EQ.IM) ID1=I1
46451 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
46452 ELSEIF(K(I,4).EQ.0) THEN
46458 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
46461 C...Save top entries at bottom of PYJETS commonblock.
46462 ELSEIF(MEDIT.EQ.21) THEN
46463 IF(2*N.GE.MSTU(4)) THEN
46464 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
46469 K(MSTU(4)-I,J)=K(I,J)
46470 P(MSTU(4)-I,J)=P(I,J)
46471 V(MSTU(4)-I,J)=V(I,J)
46476 C...Restore bottom entries of commonblock PYJETS to top.
46477 ELSEIF(MEDIT.EQ.22) THEN
46478 DO 260 I=1,MSTU(32)
46480 K(I,J)=K(MSTU(4)-I,J)
46481 P(I,J)=P(MSTU(4)-I,J)
46482 V(I,J)=V(MSTU(4)-I,J)
46487 C...Mark primary entries at top of commonblock PYJETS as untreated.
46488 ELSEIF(MEDIT.EQ.23) THEN
46493 IF(K(KH,1).GT.20) KH=0
46495 IF(KH.NE.0) GOTO 280
46497 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
46501 C...Place largest axis along z axis and second largest in xy plane.
46502 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
46503 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
46504 & P(MSTU(61),2)),0D0,0D0,0D0)
46505 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
46506 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
46507 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
46508 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
46509 IF(MEDIT.EQ.31) RETURN
46511 C...Rotate to put slim jet along +z axis.
46518 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
46519 IF(MSTU(41).GE.2) THEN
46521 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
46522 & KC.EQ.18) GOTO 300
46523 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
46526 IS=2D0-SIGN(0.5D0,P(I,3))
46528 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
46530 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
46531 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
46533 C...Rotate to put second largest jet into -z,+x quadrant.
46535 IF(P(I,3).GE.0D0) GOTO 310
46536 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
46537 IF(MSTU(41).GE.2) THEN
46539 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
46540 & KC.EQ.18) GOTO 310
46541 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
46544 IS=2D0-SIGN(0.5D0,P(I,1))
46545 PLS(IS)=PLS(IS)-P(I,3)
46547 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
46554 C*********************************************************************
46557 C...Gives program heading, or lists an event, or particle
46558 C...data, or current parameter values.
46560 SUBROUTINE PYLIST(MLIST)
46562 C...Double precision and integer declarations.
46563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46564 IMPLICIT INTEGER(I-N)
46565 INTEGER PYK,PYCHGE,PYCOMP
46566 C...Parameter statement to help give large particle numbers.
46567 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
46569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46571 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46572 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
46573 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
46574 C...Local arrays, character variables and data.
46575 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
46577 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
46579 C...Initialization printout: version number and date of last change.
46580 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
46583 IF(MLIST.EQ.0) RETURN
46586 C...List event data, including additional lines after N.
46587 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
46588 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
46589 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
46590 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
46592 IF(MLIST.GE.2) LMX=16
46595 IF(MSTU(2).GT.0) IMAX=MSTU(2)
46596 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
46597 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
46599 C...Get particle name, pad it and check it is not too long.
46600 CALL PYNAME(K(I,2),CHAP)
46603 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
46607 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
46609 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
46612 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
46614 CHAC=CHDL(MDL)(1:2*LDL)//' '
46616 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
46617 & CHDL(MDL)(LDL+1:2*LDL)//' '
46618 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
46622 C...Add information on string connection.
46623 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
46627 IF(KC.NE.0) KCC=KCHG(KC,2)
46628 IF(IABS(K(I,2)).EQ.39) THEN
46629 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
46630 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
46632 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
46633 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
46634 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
46635 ELSEIF(KCC.NE.0) THEN
46637 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
46641 C...Write data for particle/jet.
46642 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
46643 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
46645 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
46646 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
46648 ELSEIF(MLIST.EQ.1) THEN
46649 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
46651 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
46652 & K(I,1).EQ.14)) THEN
46653 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
46654 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
46655 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
46658 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
46661 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
46663 C...Insert extra separator lines specified by user.
46664 IF(MSTU(70).GE.1) THEN
46666 DO 110 J=1,MIN(10,MSTU(70))
46667 IF(I.EQ.MSTU(70+J)) ISEP=1
46669 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
46670 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
46674 C...Sum of charges and momenta.
46678 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
46679 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
46680 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
46681 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
46682 ELSEIF(MLIST.EQ.1) THEN
46683 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
46685 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
46688 C...Give simple list of KF codes defined in program.
46689 ELSEIF(MLIST.EQ.11) THEN
46690 WRITE(MSTU(11),6600)
46692 CALL PYNAME(KF,CHAP)
46693 CALL PYNAME(-KF,CHAN)
46694 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
46695 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46699 DO 150 KFLB=1,KFLA-(3-KFLS)/2
46700 KF=1000*KFLA+100*KFLB+KFLS
46701 CALL PYNAME(KF,CHAP)
46702 CALL PYNAME(-KF,CHAN)
46703 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46708 CALL PYNAME(KF,CHAP)
46709 WRITE(MSTU(11),6700) KF,CHAP
46711 CALL PYNAME(KF,CHAP)
46712 WRITE(MSTU(11),6700) KF,CHAP
46715 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
46716 IF(KMUL.EQ.5) KFLS=5
46718 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
46719 IF(KMUL.EQ.4) KFLR=2
46721 DO 180 KFLC=1,KFLB-1
46722 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
46723 CALL PYNAME(KF,CHAP)
46724 CALL PYNAME(-KF,CHAN)
46725 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46727 KF=10000*KFLR+110*KFLB+KFLS
46728 CALL PYNAME(KF,CHAP)
46729 WRITE(MSTU(11),6700) KF,CHAP
46733 CALL PYNAME(KF,CHAP)
46734 WRITE(MSTU(11),6700) KF,CHAP
46736 CALL PYNAME(KF,CHAP)
46737 WRITE(MSTU(11),6700) KF,CHAP
46743 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
46745 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
46746 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
46747 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
46748 CALL PYNAME(KF,CHAP)
46749 CALL PYNAME(-KF,CHAN)
46750 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46755 DO 250 KF=KSUSY1+1,KSUSY1+40
46756 CALL PYNAME(KF,CHAP)
46757 CALL PYNAME(-KF,CHAN)
46758 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
46759 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46761 DO 260 KF=KSUSY2+1,KSUSY2+40
46762 CALL PYNAME(KF,CHAP)
46763 CALL PYNAME(-KF,CHAN)
46764 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
46765 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46767 DO 270 KF=KEXCIT+1,KEXCIT+40
46768 CALL PYNAME(KF,CHAP)
46769 CALL PYNAME(-KF,CHAN)
46770 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
46771 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46774 C...List parton/particle data table. Check whether to be listed.
46775 ELSEIF(MLIST.EQ.12) THEN
46776 WRITE(MSTU(11),6800)
46777 DO 300 KC=1,MSTU(6)
46779 IF(KF.EQ.0) GOTO 300
46780 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
46783 C...Find particle name and mass. Print information.
46784 CALL PYNAME(KF,CHAP)
46785 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
46786 CALL PYNAME(-KF,CHAN)
46787 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
46788 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
46790 C...Particle decay: channel number, branching ratios, matrix element,
46791 C...decay products.
46792 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46794 CALL PYNAME(KFDP(IDC,J),CHAD(J))
46796 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
46801 C...List parameter value table.
46802 ELSEIF(MLIST.EQ.13) THEN
46803 WRITE(MSTU(11),7100)
46805 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
46809 C...Format statements for output on unit MSTU(11) (by default 6).
46810 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
46811 &5X,'KF orig p_x p_y p_z E m'/)
46812 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
46813 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
46814 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
46815 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
46816 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
46817 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
46818 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
46819 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
46820 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
46821 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
46822 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
46823 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
46824 5900 FORMAT(66X,5(1X,F12.3))
46825 6000 FORMAT(1X,78('='))
46826 6100 FORMAT(1X,130('='))
46827 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
46828 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
46829 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
46830 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
46832 6600 FORMAT(///20X,'List of KF codes in program'/)
46833 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
46834 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
46835 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
46836 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
46837 &1X,'ME',3X,'Br.rat.',4X,'decay products')
46838 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
46839 &1X,1P,E13.5,3X,I2)
46840 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
46841 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
46842 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
46843 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
46848 C*********************************************************************
46851 C...Writes a logo for the program.
46855 C...Double precision and integer declarations.
46856 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46857 IMPLICIT INTEGER(I-N)
46858 INTEGER PYK,PYCHGE,PYCOMP
46859 C...Parameter for length of information block.
46860 PARAMETER (IREFER=17)
46862 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46863 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46864 SAVE /PYDAT1/,/PYPARS/
46865 C...Local arrays and character variables.
46867 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
46868 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
46870 C...Data on months, logo, titles, and references.
46871 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
46872 &'Oct','Nov','Dec'/
46873 DATA (LOGO(J),J=1,19)/
46875 &' *:::!!:::::::::::* ',
46876 &' *::::::!!::::::::::::::* ',
46877 &' *::::::::!!::::::::::::::::* ',
46878 &' *:::::::::!!:::::::::::::::::* ',
46879 &' *:::::::::!!:::::::::::::::::* ',
46880 &' *::::::::!!::::::::::::::::*! ',
46881 &' *::::::!!::::::::::::::* !! ',
46882 &' !! *:::!!:::::::::::* !! ',
46883 &' !! !* -><- * !! ',
46893 DATA (LOGO(J),J=20,38)/
46894 &'Welcome to the Lund Monte Carlo!',
46896 &'PPP Y Y TTTTT H H III A ',
46897 &'P P Y Y T H H I A A ',
46898 &'PPP Y T HHHHH I AAAAA',
46899 &'P Y T H H I A A',
46900 &'P Y T H H III A A',
46902 &'This is PYTHIA version x.xxx ',
46903 &'Last date of change: xx xxx 199x',
46905 &'Now is xx xxx 199x at xx:xx:xx ',
46907 &'Disclaimer: this program comes ',
46908 &'without any guarantees. Beware ',
46909 &'of errors and use common sense ',
46910 &'when interpreting results. ',
46912 &'Copyright T. Sjostrand (2000) '/
46913 DATA (REFER(J),J=1,18)/
46914 &'An archive of program versions and d',
46915 &'ocumentation is found on the web: ',
46916 &'http://www.thep.lu.se/~torbjorn/Pyth',
46920 &'When you cite this program, currentl',
46921 &'y the official reference is ',
46922 &'T. Sjostrand, Computer Physics Commu',
46923 &'n. 82 (1994) 74. ',
46924 &'The supersymmetry extensions are des',
46926 &'S. Mrenna, Computer Physics Commun. ',
46927 &'101 (1997) 232 ',
46928 &'Also remember that the program, to a',
46929 &' large extent, represents original ',
46930 &'physics research. Other publications',
46931 &' of special relevance to your '/
46932 DATA (REFER(J),J=19,2*IREFER)/
46933 &'studies may therefore deserve separa',
46937 &'Main author: Torbjorn Sjostrand; Dep',
46938 &'artment of Theoretical Physics 2, ',
46939 &' Lund University, Solvegatan 14A, S',
46940 &'-223 62 Lund, Sweden; ',
46941 &' phone: + 46 - 46 - 222 48 16; e-ma',
46942 &'il: torbjorn@thep.lu.se ',
46943 &'SUSY author: Stephen Mrenna, Physics',
46944 &' Department, UC Davis, ',
46945 &' One Shields Avenue, Davis, CA 9561',
46947 &' phone: + 1 - 530 - 752 - 2661; e-m',
46948 &'ail: mrenna@physics.ucdavis.edu '/
46950 C...Check that PYDATA linked.
46951 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
46953 & 'Error: PYDATA has not been linked.'
46954 WRITE(*,'(1X,A)') 'Execution stopped!'
46957 C...Write current version number and current date+time.
46959 WRITE(VERS,'(I1)') MSTP(181)
46960 LOGO(28)(24:24)=VERS
46961 WRITE(SUBV,'(I3)') MSTP(182)
46962 LOGO(28)(26:28)=SUBV
46963 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
46964 WRITE(DATE,'(I2)') MSTP(185)
46965 LOGO(29)(22:23)=DATE
46966 LOGO(29)(25:27)=MONTH(MSTP(184))
46967 WRITE(YEAR,'(I4)') MSTP(183)
46968 LOGO(29)(29:32)=YEAR
46970 IF(IDATI(1).LE.0) THEN
46973 WRITE(DATE,'(I2)') IDATI(3)
46975 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
46976 WRITE(YEAR,'(I4)') IDATI(1)
46977 LOGO(31)(15:18)=YEAR
46978 WRITE(HOUR,'(I2)') IDATI(4)
46979 LOGO(31)(23:24)=HOUR
46980 WRITE(MINU,'(I2)') IDATI(5)
46981 LOGO(31)(26:27)=MINU
46982 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
46983 WRITE(SECO,'(I2)') IDATI(6)
46984 LOGO(31)(29:30)=SECO
46985 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
46989 C...Loop over lines in header. Define page feed and side borders.
46990 DO 100 ILIN=1,29+IREFER
46999 C...Separator lines and logos.
47000 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
47001 LINE(4:77)='***********************************************'//
47002 & '***************************'
47003 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
47004 LINE(6:37)=LOGO(ILIN-5)
47005 LINE(44:75)=LOGO(ILIN+14)
47006 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
47007 LINE(5:40)=REFER(2*ILIN-51)
47008 LINE(41:76)=REFER(2*ILIN-50)
47011 C...Write lines to appropriate unit.
47012 WRITE(MSTU(11),'(A79)') LINE
47018 C*********************************************************************
47021 C...Facilitates the updating of particle and decay data
47022 C...by allowing it to be done in an external file.
47024 SUBROUTINE PYUPDA(MUPDA,LFN)
47026 C...Double precision and integer declarations.
47027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47028 IMPLICIT INTEGER(I-N)
47029 INTEGER PYK,PYCHGE,PYCOMP
47031 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47032 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47033 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
47034 COMMON/PYDAT4/CHAF(500,2)
47036 COMMON/PYINT4/MWID(500),WIDS(500,5)
47037 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
47038 C...Local arrays, character variables and data.
47039 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
47040 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
47041 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
47042 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
47043 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
47044 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
47045 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
47047 C...Write header if not yet done.
47048 IF(MSTU(12).GE.1) CALL PYLIST(0)
47050 C...Write information on file for editing.
47051 IF(MUPDA.EQ.1) THEN
47053 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
47054 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
47055 & MWID(KC),MDCY(KC,1)
47056 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47057 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
47058 & (KFDP(IDC,J),J=1,5)
47062 C...Read complete set of information from edited file or
47063 C...read partial set of new or updated information from edited file.
47064 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
47066 C...Reset counters.
47070 IF(MUPDA.EQ.2) THEN
47075 DO 130 KC=1,MSTU(6)
47076 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
47077 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
47081 C...Begin of loop: read new line; unknown whether particle or
47083 140 READ(LFN,5200,END=190) CHINL
47085 C...Identify particle code and whether already defined (for MUPDA=3).
47086 IF(CHINL(2:10).NE.' ') THEN
47089 IF(MUPDA.EQ.2) THEN
47102 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
47105 C...Remove duplicate old decay data.
47106 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
47107 IDCREP=MDCY(KCREP,2)
47108 NDCREP=MDCY(KCREP,3)
47110 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
47112 DO 180 I=IDCREP,NDC-NDCREP
47113 MDME(I,1)=MDME(I+NDCREP,1)
47114 MDME(I,2)=MDME(I+NDCREP,2)
47115 BRAT(I)=BRAT(I+NDCREP)
47117 KFDP(I,J)=KFDP(I+NDCREP,J)
47122 ELSEIF(KCREP.NE.0) THEN
47130 C...Study line with particle data.
47131 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
47132 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
47133 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
47134 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
47135 & MWID(KC),MDCY(KC,1)
47139 C...Study line with decay data.
47142 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
47143 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
47144 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
47145 MDCY(KC,3)=MDCY(KC,3)+1
47146 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
47147 & (KFDP(NDC,J),J=1,5)
47150 C...End of loop; ensure that PYCOMP tables are updated.
47155 C...Perform possible tests that new information is consistent.
47156 DO 220 KC=1,MSTU(6)
47158 IF(KF.EQ.0) GOTO 220
47159 WRITE(CHKF,5300) KF
47160 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
47161 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
47162 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
47164 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47165 IF(MDME(IDC,2).GT.80) GOTO 210
47167 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
47171 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
47173 ELSEIF(PYCOMP(KP).EQ.0) THEN
47178 PMS=PMS-PMAS(KPC,1)
47179 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
47183 IF(KQ.NE.0) MERR=MAX(2,MERR)
47184 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
47186 IF(MERR.EQ.3) CALL PYERRM(17,
47187 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
47188 IF(MERR.EQ.2) CALL PYERRM(17,
47189 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
47190 IF(MERR.EQ.1) CALL PYERRM(7,
47191 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
47192 BRSUM=BRSUM+BRAT(IDC)
47194 WRITE(CHTMP,5500) BRSUM
47195 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
47196 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
47197 & CHTMP(9:16)//' for KF ='//CHKF)
47200 C...Write DATA statements for inclusion in program.
47201 ELSEIF(MUPDA.EQ.4) THEN
47203 C...Find out how many codes and decay channels are actually used.
47207 IF(KCHG(I,4).NE.0) THEN
47209 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
47213 C...Initialize writing of DATA statements for inclusion in program.
47216 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
47219 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
47223 C...Loop through variables for conversion to characters.
47225 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
47226 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
47227 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
47228 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
47229 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
47230 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
47231 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
47232 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
47233 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
47234 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
47235 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
47236 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
47237 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
47238 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
47239 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
47240 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
47241 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
47242 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
47243 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
47244 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
47245 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
47246 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
47248 C...Replace variables beyond what is properly defined.
47250 IF(IDIM.GT.KCC) CHTMP=' 0'
47251 ELSEIF(IVAR.LE.8) THEN
47252 IF(IDIM.GT.KCC) CHTMP=' 0.0'
47253 ELSEIF(IVAR.LE.11) THEN
47254 IF(IDIM.GT.KCC) CHTMP=' 0'
47255 ELSEIF(IVAR.LE.13) THEN
47256 IF(IDIM.GT.NDC) CHTMP=' 0'
47257 ELSEIF(IVAR.LE.14) THEN
47258 IF(IDIM.GT.NDC) CHTMP=' 0.0'
47259 ELSEIF(IVAR.LE.19) THEN
47260 IF(IDIM.GT.NDC) CHTMP=' 0'
47261 ELSEIF(IVAR.LE.21) THEN
47262 IF(IDIM.GT.KCC) CHTMP=' '
47264 IF(IDIM.GT.KCC) CHTMP=' 0'
47267 C...Length of variable, trailing decimal zeros, quotation marks.
47271 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
47272 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
47274 CHNEW=CHTMP(LLOW:LHIG)//' '
47276 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
47279 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
47280 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
47285 CHNEW(LNEW+1:LNEW+2)='D0'
47288 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
47289 DO 260 LL=LNEW,1,-1
47290 IF(CHNEW(LL:LL).EQ.'''') THEN
47292 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
47298 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
47302 C...Form composite character string, often including repetition counter.
47303 IF(CHNEW.NE.CHOLD) THEN
47310 IF(NRPT.GE.2) LRPT=LNEW+3
47311 IF(NRPT.GE.10) LRPT=LNEW+4
47312 IF(NRPT.GE.100) LRPT=LNEW+5
47313 IF(NRPT.GE.1000) LRPT=LNEW+6
47316 WRITE(CHTMP,5400) NRPT
47318 IF(NRPT.GE.10) LRPT=2
47319 IF(NRPT.GE.100) LRPT=3
47320 IF(NRPT.GE.1000) LRPT=4
47321 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
47325 C...Add characters to end of line, to new line (after storing old line),
47326 C...or to new block of lines (after writing old block).
47327 IF(LLIN+LCOM.LE.70) THEN
47328 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
47330 ELSEIF(NLIN.LE.19) THEN
47331 CHLIN(LLIN+1:72)=' '
47334 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
47337 CHLIN(LLIN:72)='/'//' '
47339 WRITE(CHTMP,5400) IDIM-NRPT
47340 CHBLK(1)(30:33)=CHTMP(13:16)
47342 WRITE(LFN,5700) CHBLK(ILIN)
47346 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
47347 & ',I= , )/'//CHCOM(1:LCOM)//','
47348 WRITE(CHTMP,5400) IDIM-NRPT+1
47349 CHLIN(25:28)=CHTMP(13:16)
47354 C...Write final block of lines.
47355 CHLIN(LLIN:72)='/'//' '
47357 WRITE(CHTMP,5400) NDIM
47358 CHBLK(1)(30:33)=CHTMP(13:16)
47360 WRITE(LFN,5700) CHBLK(ILIN)
47365 C...Formats for reading and writing particle data.
47366 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
47367 5100 FORMAT(10X,2I5,F12.6,5I10)
47378 C*********************************************************************
47381 C...Provides various integer-valued event related data.
47385 C...Double precision and integer declarations.
47386 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47387 IMPLICIT INTEGER(I-N)
47388 INTEGER PYK,PYCHGE,PYCOMP
47390 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47391 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47392 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47393 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47395 C...Default value. For I=0 number of entries, number of stable entries
47396 C...or 3 times total charge.
47398 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
47399 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
47401 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
47403 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
47404 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
47407 ELSEIF(I.EQ.0) THEN
47409 C...For I > 0 direct readout of K matrix or charge.
47410 ELSEIF(J.LE.5) THEN
47412 ELSEIF(J.EQ.6) THEN
47415 C...Status (existing/fragmented/decayed), parton/hadron separation.
47416 ELSEIF(J.LE.8) THEN
47417 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
47418 IF(J.EQ.8) PYK=PYK*K(I,2)
47419 ELSEIF(J.LE.12) THEN
47423 IF(KC.NE.0) KQ=KCHG(KC,2)
47424 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
47425 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
47427 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
47429 C...Heaviest flavour in hadron/diquark.
47430 ELSEIF(J.EQ.13) THEN
47432 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
47433 IF(KFA.LT.10) PYK=KFA
47434 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
47435 PYK=PYK*ISIGN(1,K(I,2))
47437 C...Particle history: generation, ancestor, rank.
47438 ELSEIF(J.LE.15) THEN
47445 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
47448 ELSEIF(J.EQ.16) THEN
47450 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
47451 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
47458 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
47459 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
47461 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
47462 IF(ILP.EQ.1) GOTO 120
47464 IF(K(I1,1).EQ.12) THEN
47466 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
47467 & .AND.K(I3,2).NE.93) PYK=PYK+1
47473 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
47477 C...Particle coming from collapsing jet system or not.
47478 ELSEIF(J.EQ.17) THEN
47485 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
47486 IF(PYK.EQ.1) PYK=-1
47490 IF(KCHG(KC,2).EQ.0) GOTO 150
47491 IF(K(I1,1).NE.12) PYK=0
47492 IF(K(I1,1).NE.12) RETURN
47495 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
47497 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
47499 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
47501 C...Number of decay products. Colour flow.
47502 ELSEIF(J.EQ.18) THEN
47503 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
47504 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
47505 ELSEIF(J.LE.22) THEN
47506 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
47507 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
47508 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
47509 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
47510 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
47517 C*********************************************************************
47520 C...Provides various real-valued event related data.
47524 C...Double precision and integer declarations.
47525 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47526 IMPLICIT INTEGER(I-N)
47527 INTEGER PYK,PYCHGE,PYCOMP
47529 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47530 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47531 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47532 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47536 C...Set default value. For I = 0 sum of momenta or charges,
47537 C...or invariant mass of system.
47539 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
47540 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
47542 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
47544 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
47548 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
47552 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
47553 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
47555 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
47557 ELSEIF(I.EQ.0) THEN
47559 C...Direct readout of P matrix.
47560 ELSEIF(J.LE.5) THEN
47563 C...Charge, total momentum, transverse momentum, transverse mass.
47564 ELSEIF(J.LE.12) THEN
47565 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
47566 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
47567 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
47568 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
47569 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
47571 C...Theta and phi angle in radians or degrees.
47572 ELSEIF(J.LE.16) THEN
47573 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
47574 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
47575 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
47577 C...True rapidity, rapidity with pion mass, pseudorapidity.
47578 ELSEIF(J.LE.19) THEN
47580 IF(J.EQ.17) PMR=P(I,5)
47581 IF(J.EQ.18) PMR=PYMASS(211)
47582 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
47583 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
47586 C...Energy and momentum fractions (only to be used in CM frame).
47587 ELSEIF(J.LE.25) THEN
47588 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
47589 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
47590 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
47591 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
47592 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
47593 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
47599 C*********************************************************************
47602 C...Performs sphericity tensor analysis to give sphericity,
47603 C...aplanarity and the related event axes.
47605 SUBROUTINE PYSPHE(SPH,APL)
47607 C...Double precision and integer declarations.
47608 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47609 IMPLICIT INTEGER(I-N)
47610 INTEGER PYK,PYCHGE,PYCOMP
47612 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47613 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47614 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47615 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47617 DIMENSION SM(3,3),SV(3,3)
47619 C...Calculate matrix to be diagonalized.
47628 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
47629 IF(MSTU(41).GE.2) THEN
47631 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
47632 & KC.EQ.18) GOTO 140
47633 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
47637 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
47639 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
47640 & MAX(1D-10,PA)**(PARU(41)-2D0)
47643 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
47649 C...Very low multiplicities (0 or 1) not considered.
47651 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
47658 SM(J1,J2)=SM(J1,J2)/PS
47662 C...Find eigenvalues to matrix (third degree equation).
47663 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
47664 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
47665 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
47666 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
47667 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
47668 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
47669 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
47670 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
47671 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
47672 IF(P(N+2,4).LT.1D-5) THEN
47673 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
47679 C...Find first and last eigenvector by solving equation system.
47682 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
47684 SV(J1,J2)=SM(J1,J2)
47685 SV(J2,J1)=SM(J1,J2)
47691 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
47694 SMAX=ABS(SV(J1,J2))
47698 DO 220 J3=JA+1,JA+2
47700 RL=SV(J1,JB)/SV(JA,JB)
47702 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
47703 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
47705 SMAX=ABS(SV(J1,J2))
47709 JB2=JB+2-3*((JB+1)/3)
47710 P(N+I,JB1)=-SV(JC,JB2)
47711 P(N+I,JB2)=SV(JC,JB1)
47712 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
47714 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
47715 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47717 P(N+I,J)=SGN*P(N+I,J)/PA
47721 C...Middle axis orthogonal to other two. Fill other codes.
47722 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47723 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
47724 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
47725 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
47738 C...Calculate sphericity and aplanarity. Select storing option.
47739 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
47743 IF(MSTU(43).LE.1) MSTU(3)=3
47744 IF(MSTU(43).GE.2) N=N+3
47749 C*********************************************************************
47752 C...Performs thrust analysis to give thrust, oblateness
47753 C...and the related event axes.
47755 SUBROUTINE PYTHRU(THR,OBL)
47757 C...Double precision and integer declarations.
47758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47759 IMPLICIT INTEGER(I-N)
47760 INTEGER PYK,PYCHGE,PYCOMP
47762 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47763 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47764 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47765 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47767 DIMENSION TDI(3),TPR(3)
47769 C...Take copy of particles that are to be considered in thrust analysis.
47773 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
47774 IF(MSTU(41).GE.2) THEN
47776 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
47777 & KC.EQ.18) GOTO 100
47778 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
47781 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
47782 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
47792 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
47794 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
47795 & P(N+NP,4)**(PARU(42)-1D0)
47796 PS=PS+P(N+NP,4)*P(N+NP,5)
47799 C...Very low multiplicities (0 or 1) not considered.
47801 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
47807 C...Loop over thrust and major. T axis along z direction in latter case.
47811 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
47813 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
47814 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
47815 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
47818 C...Find and order particles with highest p (pT for major).
47819 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
47823 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
47824 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
47825 IF(P(I,4).LE.P(ILF,4)) GOTO 140
47827 P(ILF+1,J)=P(ILF,J)
47836 C...Find and order initial axes with highest thrust (major).
47837 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
47840 NC=2**(MIN(MSTU(44),NP)-1)
47845 DO 200 ILF=1,MIN(MSTU(44),NP)
47846 SGN=P(N+NP+ILF+3,5)
47847 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
47849 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
47852 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
47853 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
47854 IF(TDS.LE.P(ILG,4)) GOTO 230
47856 P(ILG+1,J)=P(ILG,J)
47859 ILG=N+NP+MSTU(44)+4
47866 C...Iterate direction of axis until stable maximum.
47873 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
47874 IF(THP.GT.1D-10) TDI(J)=TPR(J)
47878 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
47880 TPR(J)=TPR(J)+SGN*P(I,J)
47883 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
47884 IF(THP.GE.THPS+PARU(48)) GOTO 270
47886 C...Save good axis. Try new initial axis until a number of tries agree.
47887 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
47888 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
47890 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47892 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
47898 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
47901 C...Find minor axis and value by orthogonality.
47902 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47903 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
47904 P(N+NP+3,2)=SGN*P(N+NP+2,1)
47908 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
47913 C...Fill axis information. Rotate back to original coordinate system.
47921 P(N+ILD,J)=P(N+NP+ILD,J)
47925 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
47927 C...Calculate thrust and oblateness. Select storing option.
47929 OBL=P(N+2,4)-P(N+3,4)
47932 IF(MSTU(43).LE.1) MSTU(3)=3
47933 IF(MSTU(43).GE.2) N=N+3
47938 C*********************************************************************
47941 C...Subdivides the particle content of an event into jets/clusters.
47943 SUBROUTINE PYCLUS(NJET)
47945 C...Double precision and integer declarations.
47946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47947 IMPLICIT INTEGER(I-N)
47948 INTEGER PYK,PYCHGE,PYCOMP
47950 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47951 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47952 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47953 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47954 C...Local arrays and saved variables.
47956 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
47958 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
47959 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
47960 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
47961 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
47962 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
47963 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
47964 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
47966 C...If first time, reset. If reentering, skip preliminaries.
47967 IF(MSTU(48).LE.0) THEN
47973 PIMASS=PMAS(PYCOMP(211),1)
47976 IF(MSTU(43).GE.2) N=N-NJET
47977 DO 110 I=N+1,N+NJET
47978 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
47980 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
47983 R2ACC=PARU(45)*PS(5)**2
47989 C...Find which particles are to be considered in cluster search.
47991 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
47992 IF(MSTU(41).GE.2) THEN
47994 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
47995 & KC.EQ.18) GOTO 140
47996 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
47999 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
48000 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
48005 C...Take copy of these particles, with space left for jets later on.
48011 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
48012 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
48013 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
48014 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
48016 PS(J)=PS(J)+P(N+NP,J)
48026 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
48028 C...Very low multiplicities not considered.
48029 IF(NP.LT.MSTU(47)) THEN
48030 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
48035 C...Find precluster configuration. If too few jets, make harder cuts.
48037 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
48040 R2ACC=PARU(45)*PS(5)**2
48042 RINIT=1.25D0*PARU(43)
48043 IF(NP.LE.MSTU(47)+2) RINIT=0D0
48044 170 RINIT=0.8D0*RINIT
48047 DO 180 I=N+NP+1,N+2*NP
48051 C...Sum up small momentum region. Jet if enough absolute momentum.
48052 IF(MSTU(46).LE.2) THEN
48056 DO 210 I=N+NP+1,N+2*NP
48057 IF(P(I,5).GT.2D0*RINIT) GOTO 210
48061 P(N+1,J)=P(N+1,J)+P(I,J)
48064 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
48065 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
48066 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
48067 IF(NREM.EQ.0) GOTO 170
48070 C...Find fastest remaining particle.
48073 DO 230 I=N+NP+1,N+2*NP
48074 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
48079 P(N+NPRE,J)=P(IMAX,J)
48084 C...Sum up precluster around it according to pT separation.
48085 IF(MSTU(46).LE.2) THEN
48086 DO 260 I=N+NP+1,N+2*NP
48087 IF(K(I,4).NE.0) GOTO 260
48089 IF(R2.GT.RINIT**2) GOTO 260
48093 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
48096 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
48098 C...Sum up precluster around it according to mass or
48099 C...Durham pT separation.
48103 DO 280 I=N+NP+1,N+2*NP
48104 IF(K(I,4).NE.0) GOTO 280
48105 IF(MSTU(46).LE.4) THEN
48110 IF(R2.GE.R2MIN) GOTO 280
48116 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
48118 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
48125 C...Check if more preclusters to be found. Start over if too few.
48126 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
48127 IF(NREM.GT.0) GOTO 220
48130 C...Reassign all particles to nearest jet. Sum up new jet momenta.
48133 310 IF(MSTU(46).LE.1) THEN
48134 DO 330 I=N+1,N+NJET
48139 DO 360 I=N+NP+1,N+2*NP
48141 DO 340 IJET=N+1,N+NJET
48142 IF(P(IJET,5).LT.RINIT) GOTO 340
48144 IF(R2.GE.R2MIN) GOTO 340
48150 V(IMIN,J)=V(IMIN,J)+P(I,J)
48154 DO 380 I=N+1,N+NJET
48158 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
48163 C...Find two closest jets.
48164 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
48165 DO 400 ITRY1=N+1,N+NJET-1
48166 DO 390 ITRY2=ITRY1+1,N+NJET
48167 IF(MSTU(46).LE.2) THEN
48168 R2=R2T(ITRY1,ITRY2)
48169 ELSEIF(MSTU(46).LE.4) THEN
48170 R2=R2M(ITRY1,ITRY2)
48172 R2=R2D(ITRY1,ITRY2)
48174 IF(R2.GE.R2MIN) GOTO 390
48181 C...If allowed, join two closest jets and start over.
48182 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
48183 IREC=MIN(IMIN1,IMIN2)
48184 IDEL=MAX(IMIN1,IMIN2)
48186 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
48188 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
48189 DO 430 I=IDEL+1,N+NJET
48194 IF(MSTU(46).GE.2) THEN
48195 DO 440 I=N+NP+1,N+2*NP
48197 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
48198 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
48204 C...Divide up broad jet if empty cluster in list of final ones.
48205 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
48206 DO 450 I=N+1,N+NJET
48209 DO 460 I=N+NP+1,N+2*NP
48210 K(N+K(I,4),5)=K(N+K(I,4),5)+1
48213 DO 470 I=N+1,N+NJET
48214 IF(K(I,5).EQ.0) IEMP=I
48220 DO 480 I=N+NP+1,N+2*NP
48221 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
48224 IF(R2.LE.R2MAX) GOTO 480
48231 P(IEMP,J)=P(ISPL,J)
48232 P(IJET,J)=P(IJET,J)-P(ISPL,J)
48234 P(IEMP,5)=P(ISPL,5)
48235 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
48236 IF(NLOOP.LE.2) GOTO 300
48241 C...If generalized thrust has not yet converged, continue iteration.
48242 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
48248 C...Reorder jets according to energy.
48249 DO 510 I=N+1,N+NJET
48254 DO 540 INEW=N+1,N+NJET
48256 DO 520 ITRY=N+1,N+NJET
48257 IF(V(ITRY,4).LE.PEMAX) GOTO 520
48266 P(INEW,J)=V(IMAX,J)
48272 C...Clean up particle-jet assignments and jet information.
48273 DO 550 I=N+NP+1,N+2*NP
48276 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
48277 K(IORI,4)=K(IORI,4)+1
48281 DO 570 I=N+1,N+NJET
48284 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
48288 IF(K(I,4).EQ.0) IEMP=I
48291 C...Select storing option. Output variables. Check for failure.
48297 PARU(63)=SQRT(R2MIN)
48298 IF(NJET.LE.1) PARU(63)=0D0
48300 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
48304 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
48305 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
48311 C*********************************************************************
48314 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
48315 C...as used for calorimeters at hadron colliders.
48317 SUBROUTINE PYCELL(NJET)
48319 C...Double precision and integer declarations.
48320 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48321 IMPLICIT INTEGER(I-N)
48322 INTEGER PYK,PYCHGE,PYCOMP
48324 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48325 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48326 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48327 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48329 C...Loop over all particles. Find cell that was hit by given particle.
48330 PTLRAT=1D0/SINH(PARU(51))**2
48334 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
48335 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
48336 IF(MSTU(41).GE.2) THEN
48338 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
48339 & KC.EQ.18) GOTO 110
48340 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
48344 PT=SQRT(P(I,1)**2+P(I,2)**2)
48345 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
48346 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
48347 & (ETA/PARU(51)+1D0))))
48348 PHI=PYANGL(P(I,1),P(I,2))
48349 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
48350 & (PHI/PARU(1)+1D0))))
48351 IETPH=MSTU(52)*IETA+IPHI
48353 C...Add to cell already hit, or book new cell.
48355 IF(IETPH.EQ.K(IC,3)) THEN
48361 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
48362 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
48370 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
48371 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
48375 C...Smear true bin content by calorimeter resolution.
48376 IF(MSTU(53).GE.1) THEN
48379 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
48380 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
48381 & COS(PARU(2)*PYR(0))
48382 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
48384 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
48388 C...Remove cells below threshold.
48389 IF(PARU(58).GT.0D0) THEN
48393 IF(P(IC,5).GT.PARU(58)) THEN
48405 C...Find initiator cell: the one with highest pT of not yet used ones.
48409 IF(K(IC,5).NE.2) GOTO 160
48410 IF(P(IC,5).LE.ETMAX) GOTO 160
48416 IF(ETMAX.LT.PARU(52)) GOTO 220
48417 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
48418 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
48432 C...Sum up unused cells within required distance of initiator.
48434 IF(K(IC,5).EQ.0) GOTO 170
48435 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
48436 DPHIA=ABS(P(IC,2)-PHI)
48437 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
48439 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
48440 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
48442 K(NJ,4)=K(NJ,4)+K(IC,4)
48443 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
48444 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
48445 P(NJ,5)=P(NJ,5)+P(IC,5)
48448 C...Reject cluster below minimum ET, else accept.
48449 IF(P(NJ,5).LT.PARU(53)) THEN
48452 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
48454 ELSEIF(MSTU(54).LE.2) THEN
48455 P(NJ,3)=P(NJ,3)/P(NJ,5)
48456 P(NJ,4)=P(NJ,4)/P(NJ,5)
48457 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
48460 IF(K(IC,5).LT.0) K(IC,5)=0
48467 IF(K(IC,5).GE.0) GOTO 210
48468 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
48469 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
48470 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
48471 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
48477 C...Arrange clusters in falling ET sequence.
48478 220 DO 250 I=1,NJ-NC
48481 IF(K(IJ,5).EQ.0) GOTO 230
48482 IF(P(IJ,5).LT.ETMAX) GOTO 230
48490 K(N+I,4)=K(IJMAX,4)
48493 P(N+I,J)=P(IJMAX,J)
48499 C...Convert to massless or massive four-vectors.
48500 IF(MSTU(54).EQ.2) THEN
48501 DO 260 I=N+1,N+NJET
48503 P(I,1)=P(I,5)*COS(P(I,4))
48504 P(I,2)=P(I,5)*SIN(P(I,4))
48505 P(I,3)=P(I,5)*SINH(ETA)
48506 P(I,4)=P(I,5)*COSH(ETA)
48509 ELSEIF(MSTU(54).GE.3) THEN
48510 DO 270 I=N+1,N+NJET
48511 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
48515 C...Information about storage.
48519 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
48520 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
48525 C*********************************************************************
48528 C...Determines, approximately, the two jet masses that minimize
48529 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
48531 SUBROUTINE PYJMAS(PMH,PML)
48533 C...Double precision and integer declarations.
48534 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48535 IMPLICIT INTEGER(I-N)
48536 INTEGER PYK,PYCHGE,PYCOMP
48538 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48539 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48540 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48541 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48543 DIMENSION SM(3,3),SAX(3),PS(3,5)
48556 PIMASS=PMAS(PYCOMP(211),1)
48558 C...Take copy of particles that are to be considered in mass analysis.
48560 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
48561 IF(MSTU(41).GE.2) THEN
48563 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
48564 & KC.EQ.18) GOTO 170
48565 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
48568 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
48569 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
48578 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
48579 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
48580 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
48582 C...Fill information in sphericity tensor and total momentum vector.
48585 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
48588 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
48590 PS(3,J)=PS(3,J)+P(N+NP,J)
48594 C...Very low multiplicities (0 or 1) not considered.
48596 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
48601 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
48604 C...Find largest eigenvalue to matrix (third degree equation).
48607 SM(J1,J2)=SM(J1,J2)/PSS
48610 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
48611 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
48612 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
48613 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
48614 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
48615 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
48616 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
48618 C...Find largest eigenvector by solving equation system.
48620 SM(J1,J1)=SM(J1,J1)-SMA
48622 SM(J2,J1)=SM(J1,J2)
48628 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
48631 SMAX=ABS(SM(J1,J2))
48635 DO 250 J3=JA+1,JA+2
48637 RL=SM(J1,JB)/SM(JA,JB)
48639 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
48640 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
48642 SMAX=ABS(SM(J1,J2))
48646 JB2=JB+2-3*((JB+1)/3)
48647 SAX(JB1)=-SM(JC,JB2)
48648 SAX(JB2)=SM(JC,JB1)
48649 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
48651 C...Divide particles into two initial clusters by hemisphere.
48653 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
48655 IF(PSAX.LT.0D0) IS=2
48658 PS(IS,J)=PS(IS,J)+P(I,J)
48661 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
48662 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
48664 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
48668 PS(3,J)=PS(1,J)-PS(2,J)
48671 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)
48672 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
48673 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
48674 IF(PMDI.LT.PMD) THEN
48680 C...Loop back if significant reduction in sum of m^2.
48681 IF(PMD.LT.-PARU(48)*PMS) THEN
48685 PS(IS,J)=PS(IS,J)-P(IM,J)
48686 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
48692 C...Final masses and output.
48695 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
48696 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
48697 PMH=MAX(PS(1,5),PS(2,5))
48698 PML=MIN(PS(1,5),PS(2,5))
48703 C*********************************************************************
48706 C...Calculates the first few Fox-Wolfram moments.
48708 SUBROUTINE PYFOWO(H10,H20,H30,H40)
48710 C...Double precision and integer declarations.
48711 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48712 IMPLICIT INTEGER(I-N)
48713 INTEGER PYK,PYCHGE,PYCOMP
48715 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48716 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48717 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48718 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48720 C...Copy momenta for particles and calculate H0.
48725 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
48726 IF(MSTU(41).GE.2) THEN
48728 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
48729 & KC.EQ.18) GOTO 110
48730 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
48733 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
48734 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
48745 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
48751 C...Very low multiplicities (0 or 1) not considered.
48753 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
48761 C...Calculate H1 - H4.
48767 DO 120 I2=I1+1,N+NP
48768 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
48769 & (P(I1,4)*P(I2,4))
48770 H10=H10+P(I1,4)*P(I2,4)*CTHE
48771 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
48772 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
48773 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
48778 C...Calculate H1/H0 - H4/H0. Output.
48781 H10=(HD+2D0*H10)/H0
48782 H20=(HD+2D0*H20)/H0
48783 H30=(HD+2D0*H30)/H0
48784 H40=(HD+2D0*H40)/H0
48789 C*********************************************************************
48792 C...Evaluates various properties of an event, with statistics
48793 C...accumulated during the course of the run and
48794 C...printed at the end.
48796 SUBROUTINE PYTABU(MTABU)
48798 C...Double precision and integer declarations.
48799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48800 IMPLICIT INTEGER(I-N)
48801 INTEGER PYK,PYCHGE,PYCOMP
48803 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48806 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
48807 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
48808 C...Local arrays, character variables, saved variables and data.
48809 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
48810 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
48811 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
48812 &KFDM(8),KFDC(200,0:8),NPDC(200)
48813 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
48814 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
48815 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
48816 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
48817 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
48818 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
48819 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
48820 &NEVDC/0/,NKFDC/0/,NREDC/0/
48822 C...Reset statistics on initial parton state.
48823 IF(MTABU.EQ.10) THEN
48827 C...Identify and order flavour content of initial state.
48828 ELSEIF(MTABU.EQ.11) THEN
48830 KFM1=2*IABS(MSTU(161))
48831 IF(MSTU(161).GT.0) KFM1=KFM1-1
48832 KFM2=2*IABS(MSTU(162))
48833 IF(MSTU(162).GT.0) KFM2=KFM2-1
48834 KFMN=MIN(KFM1,KFM2)
48835 KFMX=MAX(KFM1,KFM2)
48837 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
48840 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
48841 & KFMX.LT.KFIS(I,2))) THEN
48847 110 IF(IKFIS.LT.0) THEN
48850 IF(NKFIS.GE.100) RETURN
48851 DO 130 I=NKFIS,IKFIS,-1
48852 KFIS(I+1,1)=KFIS(I,1)
48853 KFIS(I+1,2)=KFIS(I,2)
48855 NPIS(I+1,J)=NPIS(I,J)
48865 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
48867 C...Count number of partons in initial state.
48870 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
48871 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
48872 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
48877 IF(IM.LE.0.OR.IM.GT.N) THEN
48879 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
48881 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
48882 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
48892 IF(NP.GE.11) NPCO=8
48893 IF(NP.GE.16) NPCO=9
48894 IF(NP.GE.26) NPCO=10
48895 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
48898 C...Write statistics on initial parton state.
48899 ELSEIF(MTABU.EQ.12) THEN
48900 FAC=1D0/MAX(1,NEVIS)
48901 WRITE(MSTU(11),5000) NEVIS
48904 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
48906 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
48907 CALL PYNAME(KFM1,CHAU)
48909 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
48911 IF(KFIS(I,1).EQ.0) KFMX=0
48913 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
48914 CALL PYNAME(KFM2,CHAU)
48916 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
48917 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
48918 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
48921 C...Copy statistics on initial parton state into /PYJETS/.
48922 ELSEIF(MTABU.EQ.13) THEN
48923 FAC=1D0/MAX(1,NEVIS)
48926 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
48928 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
48930 IF(KFIS(I,1).EQ.0) KFMX=0
48932 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
48939 P(I,J)=FAC*NPIS(I,J)
48940 V(I,J)=FAC*NPIS(I,J+5)
48954 C...Reset statistics on number of particles/partons.
48955 ELSEIF(MTABU.EQ.20) THEN
48962 C...Identify whether particle/parton is primary or not.
48963 ELSEIF(MTABU.EQ.21) THEN
48967 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
48968 MSTU(62)=MSTU(62)+1
48971 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
48973 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
48975 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
48977 ELSEIF(KC.EQ.0) THEN
48978 ELSEIF(K(K(I,3),1).EQ.13) THEN
48980 IF(IM.LE.0.OR.IM.GT.N) THEN
48982 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
48985 ELSEIF(KCHG(KC,2).EQ.0) THEN
48986 KCM=PYCOMP(K(K(I,3),2))
48988 IF(KCHG(KCM,2).NE.0) MPRI=1
48991 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
48992 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
48994 IF(K(I,1).LE.10) THEN
48996 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
48999 C...Fill statistics on number of particles/partons in event.
49001 KFS=3-ISIGN(1,K(I,2))-MPRI
49003 IF(KFA.EQ.KFFS(IP)) THEN
49006 ELSEIF(KFA.LT.KFFS(IP)) THEN
49012 220 IF(IKFFS.LT.0) THEN
49015 IF(NKFFS.GE.400) RETURN
49016 DO 240 IP=NKFFS,IKFFS,-1
49017 KFFS(IP+1)=KFFS(IP)
49019 NPFS(IP+1,J)=NPFS(IP,J)
49028 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
49031 C...Write statistics on particle/parton composition of events.
49032 ELSEIF(MTABU.EQ.22) THEN
49033 FAC=1D0/MAX(1,NEVFS)
49034 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
49036 CALL PYNAME(KFFS(I),CHAU)
49039 IF(KC.NE.0) MDCYF=MDCY(KC,1)
49040 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
49041 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
49044 C...Copy particle/parton composition information into /PYJETS/.
49045 ELSEIF(MTABU.EQ.23) THEN
49046 FAC=1D0/MAX(1,NEVFS)
49052 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
49054 P(I,J)=FAC*NPFS(I,J)
49074 C...Reset factorial moments statistics.
49075 ELSEIF(MTABU.EQ.30) THEN
49081 FM1FM(IM,IB,IP)=0D0
49082 FM2FM(IM,IB,IP)=0D0
49087 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
49088 ELSEIF(MTABU.EQ.31) THEN
49093 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
49094 IF(MSTU(41).GE.2) THEN
49096 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
49097 & KC.EQ.18) GOTO 410
49098 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
49099 & PYCHGE(K(I,2)).EQ.0) GOTO 410
49102 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
49103 IF(MSTU(42).GE.2) PMR=P(I,5)
49104 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
49105 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
49107 IF(ABS(YETA).GT.PARU(57)) GOTO 410
49108 PHI=PYANGL(P(I,1),P(I,2))
49109 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
49110 IYETA=MAX(0,MIN(511,IYETA))
49111 IPHI=512D0*(PHI+PARU(1))/PARU(2)
49112 IPHI=MAX(0,MIN(511,IPHI))
49115 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
49118 C...Order particles in (pseudo)rapidity and/or azimuth.
49119 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
49120 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
49124 IF(NUPP.EQ.NLOW+1) THEN
49129 DO 350 I1=NUPP-1,NLOW+1,-1
49130 IF(IYETA.GE.K(I1,1)) GOTO 360
49133 360 K(I1+1,1)=IYETA
49134 DO 370 I1=NUPP-1,NLOW+1,-1
49135 IF(IPHI.GE.K(I1,2)) GOTO 380
49139 DO 390 I1=NUPP-1,NLOW+1,-1
49140 IF(IYEP.GE.K(I1,3)) GOTO 400
49150 C...Calculate sum of factorial moments in event.
49158 IF(IM.LE.2) IBIN=2**(10-IB)
49159 IF(IM.EQ.3) IBIN=4**(10-IB)
49160 IAGR=K(NLOW+1,IM)/IBIN
49162 DO 440 I=NLOW+2,NUPP+1
49164 IF(ICUT.EQ.IAGR) THEN
49168 ELSEIF(NAGR.EQ.2) THEN
49169 FEVFM(IB,1)=FEVFM(IB,1)+2D0
49170 ELSEIF(NAGR.EQ.3) THEN
49171 FEVFM(IB,1)=FEVFM(IB,1)+6D0
49172 FEVFM(IB,2)=FEVFM(IB,2)+6D0
49173 ELSEIF(NAGR.EQ.4) THEN
49174 FEVFM(IB,1)=FEVFM(IB,1)+12D0
49175 FEVFM(IB,2)=FEVFM(IB,2)+24D0
49176 FEVFM(IB,3)=FEVFM(IB,3)+24D0
49178 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
49179 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
49180 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
49182 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
49183 & (NAGR-3D0)*(NAGR-4D0)
49191 C...Add results to total statistics.
49194 IF(FEVFM(1,IP).LT.0.5D0) THEN
49196 ELSEIF(IM.LE.2) THEN
49197 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
49199 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
49201 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
49202 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
49206 NMUFM=NMUFM+(NUPP-NLOW)
49209 C...Write accumulated statistics on factorial moments.
49210 ELSEIF(MTABU.EQ.32) THEN
49211 FAC=1D0/MAX(1,NEVFM)
49212 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
49213 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
49214 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
49216 WRITE(MSTU(11),5500)
49219 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
49221 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
49222 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
49223 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
49225 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
49226 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
49229 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
49234 C...Copy statistics on factorial moments into /PYJETS/.
49235 ELSEIF(MTABU.EQ.33) THEN
49236 FAC=1D0/MAX(1,NEVFM)
49243 IF(IM.NE.2) K(I,3)=2**(IB-1)
49245 IF(IM.NE.1) K(I,4)=2**(IB-1)
49247 P(I,1)=2D0*PARU(57)/K(I,3)
49248 V(I,1)=PARU(2)/K(I,4)
49250 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
49251 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
49267 C...Reset statistics on Energy-Energy Correlation.
49268 ELSEIF(MTABU.EQ.40) THEN
49279 C...Find particles to include, with proper assumed mass.
49280 ELSEIF(MTABU.EQ.41) THEN
49286 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
49287 IF(MSTU(41).GE.2) THEN
49289 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
49290 & KC.EQ.18) GOTO 570
49291 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
49292 & PYCHGE(K(I,2)).EQ.0) GOTO 570
49295 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
49296 IF(MSTU(42).GE.2) PMR=P(I,5)
49297 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
49298 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
49305 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
49306 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
49309 IF(NUPP.EQ.NLOW) RETURN
49311 C...Analyze Energy-Energy Correlation in event.
49312 FAC=(2D0/ECM**2)*50D0/PARU(1)
49316 DO 600 I1=NLOW+2,NUPP
49317 DO 590 I2=NLOW+1,I1-1
49318 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
49319 & (P(I1,5)*P(I2,5))
49320 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
49321 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
49322 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
49326 FE1EC(J)=FE1EC(J)+FEVEE(J)
49327 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
49328 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
49329 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
49330 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
49331 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
49335 C...Write statistics on Energy-Energy Correlation.
49336 ELSEIF(MTABU.EQ.42) THEN
49337 FAC=1D0/MAX(1,NEVEE)
49338 WRITE(MSTU(11),5700) NEVEE
49341 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
49342 FEEC2=FAC*FE1EC(51-J)
49343 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
49345 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
49346 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
49347 & FEEC2,FEES2,FEECA,FEESA
49350 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
49351 ELSEIF(MTABU.EQ.43) THEN
49352 FAC=1D0/MAX(1,NEVEE)
49359 P(I,1)=FAC*FE1EC(I)
49360 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
49361 P(I,2)=FAC*FE1EC(51-I)
49362 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
49363 P(I,3)=FAC*FE1EA(I)
49364 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
49365 P(I,4)=PARU(1)*(I-1)/50D0
49366 P(I,5)=PARU(1)*I/50D0
49381 C...Reset statistics on decay channels.
49382 ELSEIF(MTABU.EQ.50) THEN
49387 C...Identify and order flavour content of final state.
49388 ELSEIF(MTABU.EQ.51) THEN
49392 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
49399 IF(K(I,2).LT.0) KFM=KFM-1
49400 DO 650 IDS=NDS-1,1,-1
49402 IF(KFM.LT.KFDM(IDS)) GOTO 660
49403 KFDM(IDS+1)=KFDM(IDS)
49409 C...Find whether old or new final state.
49411 IF(NDS.LT.KFDC(IDC,0)) THEN
49414 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
49416 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
49419 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
49428 700 IF(IKFDC.LT.0) THEN
49430 ELSEIF(NKFDC.GE.200) THEN
49434 DO 720 IDC=NKFDC,IKFDC,-1
49435 NPDC(IDC+1)=NPDC(IDC)
49437 KFDC(IDC+1,I)=KFDC(IDC,I)
49443 KFDC(IKFDC,I)=KFDM(I)
49447 NPDC(IKFDC)=NPDC(IKFDC)+1
49449 C...Write statistics on decay channels.
49450 ELSEIF(MTABU.EQ.52) THEN
49451 FAC=1D0/MAX(1,NEVDC)
49452 WRITE(MSTU(11),5900) NEVDC
49454 DO 740 I=1,KFDC(IDC,0)
49457 IF(2*KF.NE.KFM) KF=-KF
49458 CALL PYNAME(KF,CHAU)
49460 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
49462 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
49464 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
49466 C...Copy statistics on decay channels into /PYJETS/.
49467 ELSEIF(MTABU.EQ.53) THEN
49468 FAC=1D0/MAX(1,NEVDC)
49474 K(IDC,5)=KFDC(IDC,0)
49479 DO 770 I=1,KFDC(IDC,0)
49482 IF(2*KF.NE.KFM) KF=-KF
49483 IF(I.LE.5) P(IDC,I)=KF
49484 IF(I.GE.6) V(IDC,I-5)=KF
49486 V(IDC,5)=FAC*NPDC(IDC)
49501 C...Format statements for output on unit MSTU(11) (default 6).
49502 5000 FORMAT(///20X,'Event statistics - initial state'/
49503 &20X,'based on an analysis of ',I6,' events'//
49504 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
49505 &'according to fragmenting system multiplicity'/
49506 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
49507 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
49508 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
49509 5200 FORMAT(///20X,'Event statistics - final state'/
49510 &20X,'based on an analysis of ',I7,' events'//
49511 &5X,'Mean primary multiplicity =',F10.4/
49512 &5X,'Mean final multiplicity =',F10.4/
49513 &5X,'Mean charged multiplicity =',F10.4//
49514 &5X,'Number of particles produced per event (directly and via ',
49515 &'decays/branchings)'/
49516 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
49517 &8X,'Total'/35X,'prim seco prim seco'/)
49518 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
49519 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
49520 &20X,'based on an analysis of ',I6,' events'//
49521 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
49522 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
49524 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
49525 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
49526 &20X,'based on an analysis of ',I6,' events'//
49527 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
49528 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
49529 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
49530 5900 FORMAT(///20X,'Decay channel analysis - final state'/
49531 &20X,'based on an analysis of ',I6,' events'//
49532 &2X,'Probability',10X,'Complete final state'/)
49533 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
49534 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
49535 &'or table overflow)')
49540 C*********************************************************************
49543 C...Handles the generation of an e+e- annihilation jet event.
49545 SUBROUTINE PYEEVT(KFL,ECM)
49547 C...Double precision and integer declarations.
49548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49549 IMPLICIT INTEGER(I-N)
49550 INTEGER PYK,PYCHGE,PYCOMP
49552 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
49553 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49554 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49555 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
49557 C...Check input parameters.
49558 IF(MSTU(12).GE.1) CALL PYLIST(0)
49559 IF(KFL.LT.0.OR.KFL.GT.8) THEN
49560 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
49561 IF(MSTU(21).GE.1) RETURN
49563 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
49564 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
49565 IF(ECM.LT.ECMMIN) THEN
49566 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
49567 IF(MSTU(21).GE.1) RETURN
49570 C...Check consistency of MSTJ options set.
49571 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
49573 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
49576 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
49578 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
49582 C...Initialize alpha_strong and total cross-section.
49583 MSTU(111)=MSTJ(108)
49584 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
49586 PARU(112)=PARJ(121)
49587 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
49588 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
49589 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
49591 IF(MSTJ(116).GE.3) MSTJ(116)=1
49594 C...Add initial e+e- to event record (documentation only).
49597 IF(NTRY.GT.100) THEN
49598 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
49603 IF(MSTJ(115).GE.2) THEN
49605 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
49607 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
49611 C...Radiative photon (in initial state).
49614 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
49616 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
49617 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
49619 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
49620 K(NC,3)=MIN(MSTJ(115)/2,1)
49623 C...Virtual exchange boson (gamma or Z0).
49624 IF(MSTJ(115).GE.3) THEN
49627 IF(MSTJ(102).EQ.2) KF=23
49631 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
49637 C...Choice of flavour and jet configuration.
49638 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
49639 IF(KFLC.EQ.0) GOTO 100
49640 CALL PYXJET(ECMC,NJET,CUT)
49642 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
49644 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
49645 IF(NJET.EQ.2) MSTJ(120)=1
49647 C...Fill jet configuration and origin.
49648 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
49649 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
49651 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
49652 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
49653 &-KFLC,ECMC,X1,X2,X4,X12,X14)
49654 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
49655 &-KFLC,ECMC,X1,X2,X4,X12,X14)
49656 IF(MSTU(24).NE.0) GOTO 100
49658 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
49661 C...Angular orientation according to matrix element.
49662 IF(MSTJ(106).EQ.1) THEN
49663 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
49664 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
49665 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
49668 C...Rotation and boost from radiative photon.
49670 DBEK=-PAK/(ECM-PAK)
49671 NMIN=NC+1-MSTJ(115)/3
49672 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
49673 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
49674 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
49677 C...Generate parton shower. Rearrange along strings and check.
49678 IF(MSTJ(101).EQ.5) THEN
49679 CALL PYSHOW(N-1,N,ECMC)
49681 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
49682 IF(MSTJ(105).GE.0) MSTU(28)=0
49685 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
49688 C...Fragmentation/decay generation. Information for PYTABU.
49689 IF(MSTJ(105).EQ.1) CALL PYEXEC
49696 C*********************************************************************
49699 C...Calculates total cross-section, including initial state
49700 C...radiation effects.
49702 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
49704 C...Double precision and integer declarations.
49705 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49706 IMPLICIT INTEGER(I-N)
49707 INTEGER PYK,PYCHGE,PYCOMP
49709 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49710 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49711 SAVE /PYDAT1/,/PYDAT2/
49713 C...Status, (optimized) Q^2 scale, alpha_strong.
49715 MSTJ(119)=10*MSTJ(102)+KFL
49716 IF(MSTJ(111).EQ.0) THEN
49718 ELSEIF(MSTU(111).EQ.0) THEN
49719 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
49720 & ((33D0-2D0*MSTU(112))*PARU(111)))))
49721 Q2R=PARJ(168)*ECM**2
49723 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
49724 & (2D0*PARU(112)/ECM)**2))
49725 Q2R=PARJ(168)*ECM**2
49727 ALSPI=PYALPS(Q2R)/PARU(1)
49729 C...QCD corrections factor in R.
49730 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
49732 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
49734 ELSEIF(MSTJ(109).EQ.0) THEN
49735 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
49736 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
49737 & LOG(PARJ(168))*ALSPI**2)
49738 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
49739 RQCD=1D0+(3D0/4D0)*ALSPI
49741 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
49744 C...Calculate Z0 width if default value not acceptable.
49745 IF(MSTJ(102).GE.3) THEN
49746 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
49747 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
49750 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
49751 & (2D0*PYMASS(KFLC)/ ECM)**2))
49752 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
49753 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
49754 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
49756 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
49760 C...Calculate propagator and related constants for QFD case.
49761 POLL=1D0-PARJ(131)*PARJ(132)
49762 IF(MSTJ(102).GE.2) THEN
49763 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
49764 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
49765 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
49766 VE=4D0*PARU(102)-1D0
49767 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
49768 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
49773 C...Loop over different flavours: charge, velocity.
49778 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
49779 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
49782 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
49783 QF=KCHG(KFLC,1)/3D0
49785 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
49787 C...Calculate R and sum of charges for QED or QFD case.
49788 RQQ=RQQ+3D0*QF**2*POLL
49789 IF(MSTJ(102).LE.1) THEN
49790 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
49792 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
49793 RQV=RQV-6D0*QF*VF*SF1I
49794 RVA=RVA+3D0*(VF**2+1D0)*SF1W
49795 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
49796 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
49800 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
49802 C...Calculate cross-section, including QCD corrections.
49805 PARJ(143)=RTOT*RQCD
49806 PARJ(144)=PARJ(143)
49807 PARJ(145)=PARJ(141)*86.8D0/ECM**2
49808 PARJ(146)=PARJ(142)*86.8D0/ECM**2
49809 PARJ(147)=PARJ(143)*86.8D0/ECM**2
49810 PARJ(148)=PARJ(147)
49811 PARJ(157)=RSUM*RQCD
49815 IF(MSTJ(107).LE.0) RETURN
49817 C...Virtual cross-section.
49819 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
49820 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
49821 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
49822 &1.526D0*LOG(ECM**2/0.932D0)
49824 C...Soft and hard radiative cross-section in QED case.
49825 IF(MSTJ(102).LE.1) THEN
49826 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
49827 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
49828 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
49830 C...Soft and hard radiative cross-section in QFD case.
49832 SZM=1D0-(PARJ(123)/ECM)**2
49833 SZW=PARJ(123)*PARJ(124)/ECM**2
49834 PARJ(161)=-RQQ/RSUM
49835 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
49836 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
49837 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
49838 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
49839 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
49840 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
49841 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
49842 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
49843 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
49844 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
49845 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
49846 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
49847 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
49850 C...Total cross-section and fraction of hard photon events.
49851 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
49852 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
49853 PARJ(144)=PARJ(157)
49854 PARJ(148)=PARJ(144)*86.8D0/ECM**2
49860 C*********************************************************************
49863 C...Generates initial state photon radiation.
49865 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
49867 C...Double precision and integer declarations.
49868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49869 IMPLICIT INTEGER(I-N)
49870 INTEGER PYK,PYCHGE,PYCOMP
49872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49875 C...Function: cumulative hard photon spectrum in QFD case.
49876 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
49877 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
49879 C...Determine whether radiative photon or not.
49882 IF(PARJ(160).LT.PYR(0)) RETURN
49885 C...Photon energy range. Find photon momentum in QED case.
49887 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
49888 IF(MSTJ(102).LE.1) THEN
49889 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
49890 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
49892 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
49894 SZM=1D0-(PARJ(123)/ECM)**2
49895 SZW=PARJ(123)*PARJ(124)/ECM**2
49898 FXKD=1D-4*(FXKU-FXKL)
49899 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
49904 IF(FXKV.GT.FXKR) THEN
49911 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
49912 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
49916 C...Photon polar and azimuthal angle.
49917 PME=2D0*(PYMASS(11)/ECM)**2
49918 120 CTHM=PME*(2D0/PME)**PYR(0)
49919 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
49920 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
49922 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
49923 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
49924 THEK=PYANGL(CTHE,STHE)
49925 PHIK=PARU(2)*PYR(0)
49927 C...Rotation angle for hadronic system.
49929 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
49931 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
49932 &(2D0-XK*(1D0-SGN*CTHE)))
49937 C*********************************************************************
49940 C...Selects flavour for produced qqbar pair.
49942 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
49944 C...Double precision and integer declarations.
49945 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49946 IMPLICIT INTEGER(I-N)
49947 INTEGER PYK,PYCHGE,PYCOMP
49949 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49950 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49951 SAVE /PYDAT1/,/PYDAT2/
49953 C...Calculate maximum weight in QED or QFD case.
49954 IF(MSTJ(102).LE.1) THEN
49957 POLL=1D0-PARJ(131)*PARJ(132)
49958 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
49959 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
49960 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
49961 VE=4D0*PARU(102)-1D0
49962 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
49963 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
49964 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
49965 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
49966 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
49970 C...Choose flavour. Gives charge and velocity.
49973 IF(NTRY.GT.100) THEN
49974 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
49979 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
49982 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
49983 QF=KCHG(KFLC,1)/3D0
49985 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
49987 C...Calculate weight in QED or QFD case.
49988 IF(MSTJ(102).LE.1) THEN
49990 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
49992 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
49993 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
49994 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
49996 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
49999 C...Weighting or new event (radiative photon). Cross-section update.
50000 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
50001 PARJ(158)=PARJ(158)+1D0
50002 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
50003 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
50004 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
50005 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
50006 PARJ(148)=PARJ(144)*86.8D0/ECM**2
50011 C*********************************************************************
50014 C...Selects number of jets in matrix element approach.
50016 SUBROUTINE PYXJET(ECM,NJET,CUT)
50018 C...Double precision and integer declarations.
50019 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50020 IMPLICIT INTEGER(I-N)
50021 INTEGER PYK,PYCHGE,PYCOMP
50023 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50025 C...Local array and data.
50027 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
50029 C...Trivial result for two-jets only, including parton shower.
50030 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
50033 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
50034 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
50036 IF(MSTJ(109).EQ.2) CF=1D0
50037 IF(MSTJ(111).EQ.0) THEN
50040 ELSEIF(MSTU(111).EQ.0) THEN
50041 PARJ(169)=MIN(1D0,PARJ(129))
50042 Q2=PARJ(169)*ECM**2
50043 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
50044 & ((33D0-2D0*MSTU(112))*PARU(111)))))
50045 Q2R=PARJ(168)*ECM**2
50047 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
50048 Q2=PARJ(169)*ECM**2
50049 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
50050 & (2D0*PARU(112)/ECM)**2))
50051 Q2R=PARJ(168)*ECM**2
50054 C...alpha_strong for R and R itself.
50055 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
50056 IF(IABS(MSTJ(101)).EQ.1) THEN
50058 ELSEIF(MSTJ(109).EQ.0) THEN
50059 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
50060 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
50061 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
50063 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
50066 C...alpha_strong for jet rate. Initial value for y cut.
50067 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
50068 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
50069 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
50070 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
50071 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
50073 C...Parametrization of first order three-jet cross-section.
50074 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
50077 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
50078 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
50079 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
50080 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
50081 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
50085 C...Parametrization of second order three-jet cross-section.
50086 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
50087 & CUT.GE.0.25D0) THEN
50089 ELSEIF(MSTJ(110).LE.1) THEN
50090 CT=LOG(1D0/CUT-2D0)
50091 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
50092 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
50094 C...Interpolation in second/first order ratio for Zhu parametrization.
50095 ELSEIF(MSTJ(110).EQ.2) THEN
50098 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
50104 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
50106 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
50109 C...Shift in second order three-jet cross-section with optimized Q^2.
50110 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
50111 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
50112 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
50114 C...Parametrization of second order four-jet cross-section.
50115 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
50118 CT=LOG(1D0/CUT-5D0)
50119 IF(CUT.LE.0.018D0) THEN
50120 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
50121 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
50123 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
50124 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
50126 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
50127 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
50128 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
50129 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
50130 & 0.002093D0*CT**3)
50131 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
50133 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
50134 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
50137 C...If negative three-jet rate, change y' optimization parameter.
50138 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
50139 & PARJ(169).LT.0.99D0) THEN
50140 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
50141 Q2=PARJ(169)*ECM**2
50142 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
50146 C...If too high cross-section, use harder cuts, or fail.
50147 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
50148 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
50149 & PARJ(169).LT.0.99D0) THEN
50150 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
50151 Q2=PARJ(169)*ECM**2
50152 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
50154 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
50156 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
50158 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
50159 & PARJ(154))**(-1D0/3D0)
50160 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
50164 C...Scalar gluon (first order only).
50166 ALSPI=PYALPS(ECM**2)/PARU(1)
50167 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
50169 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
50170 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
50175 C...Select number of jets.
50177 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
50179 ELSEIF(MSTJ(101).LE.0) THEN
50180 NJET=MIN(4,2-MSTJ(101))
50184 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
50185 IF(PARJ(154).GT.RNJ) NJET=4
50191 C*********************************************************************
50194 C...Selects the kinematical variables of three-jet events.
50196 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
50198 C...Double precision and integer declarations.
50199 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50200 IMPLICIT INTEGER(I-N)
50201 INTEGER PYK,PYCHGE,PYCOMP
50203 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50206 DIMENSION ZHUP(5,12)
50208 C...Coefficients of Zhu second order parametrization.
50209 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
50210 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
50211 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
50212 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
50213 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
50214 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
50215 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
50216 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
50217 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
50218 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
50219 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
50221 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
50222 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
50225 C...Event type. Mass effect factors and other common constants.
50229 QME=(2D0*PMQ/ECM)**2
50230 IF(MSTJ(109).NE.1) THEN
50232 CUTD=LOG(1D0/CUT-2D0)
50233 IF(MSTJ(109).EQ.0) THEN
50237 WTMX=MIN(20D0,37D0-6D0*CUTD)
50238 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
50246 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
50247 ALS2PI=PARU(118)/PARU(2)
50249 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
50250 & LOG(PARJ(169))*ALS2PI
50251 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
50253 C...Choose three-jet events in allowed region.
50255 110 Y13L=CUTL+CUTD*PYR(0)
50256 Y23L=CUTL+CUTD*PYR(0)
50260 IF(Y12.LE.CUT) GOTO 110
50261 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
50263 C...Second order corrections.
50264 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
50269 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
50270 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
50271 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
50272 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
50273 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
50274 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
50275 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
50276 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
50277 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
50278 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
50279 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
50280 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
50281 & TR*(2D0*CUTL/3D0-10D0/9D0)+
50282 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
50283 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
50284 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
50285 & Y13*Y23)/(Y12+Y13)**2)/WT1+
50286 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
50287 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
50288 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
50289 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
50290 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
50291 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
50292 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
50293 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
50294 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
50295 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
50297 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
50298 C...Second order corrections; Zhu parametrization of ERT.
50303 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
50307 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
50308 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
50309 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
50310 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
50313 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
50314 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
50315 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
50316 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
50318 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
50319 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
50320 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
50321 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
50322 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
50324 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
50325 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
50326 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
50329 C...Impose mass cuts (gives two jets). For fixed jet number new try.
50333 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
50334 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
50335 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
50336 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
50337 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
50339 C...Scalar gluon model (first order only, no mass effects).
50342 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
50343 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
50344 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
50345 X1=1D0-0.5D0*(X3+YD)
50346 X2=1D0-0.5D0*(X3-YD)
50347 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
50348 IF(MSTJ(102).GE.2) THEN
50349 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
50350 & X3**2*PYR(0)) NJET=2
50352 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
50358 C*********************************************************************
50361 C...Selects the kinematical variables of four-jet events.
50363 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
50365 C...Double precision and integer declarations.
50366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50367 IMPLICIT INTEGER(I-N)
50368 INTEGER PYK,PYCHGE,PYCOMP
50370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50373 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
50375 C...Common constants. Colour factors for QCD and Abelian gluon theory.
50377 QME=(2D0*PMQ/ECM)**2
50378 CT=LOG(1D0/CUT-5D0)
50379 IF(MSTJ(109).EQ.0) THEN
50389 C...Choice of process (qqbargg or qqbarqqbar).
50392 IF(PARJ(155).GT.PYR(0)) IT=2
50393 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
50394 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
50395 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
50396 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
50399 C...Sample the five kinematical variables (for qqgg preweighted in y34).
50400 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
50401 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
50402 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
50403 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
50404 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
50406 CP=COS(PARU(1)*PYR(0))
50409 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
50410 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
50411 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
50413 Y12=1D0-Y134-Y23-Y24
50414 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
50418 C...Calculate matrix elements for qqgg or qqqq process.
50423 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
50424 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
50425 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
50426 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
50427 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
50428 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
50429 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
50430 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
50431 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
50432 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
50433 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
50434 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
50435 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
50436 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
50437 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
50438 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
50439 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
50440 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
50441 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
50442 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
50443 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
50444 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
50445 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
50446 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
50447 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
50448 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
50449 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
50450 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
50451 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
50452 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
50453 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
50454 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
50455 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
50456 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
50457 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
50458 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
50459 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
50460 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
50461 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
50462 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
50463 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
50466 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
50467 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
50468 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
50469 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
50470 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
50471 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
50472 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
50473 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
50474 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
50475 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
50476 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
50477 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
50478 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
50479 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
50480 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
50481 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
50482 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
50483 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
50486 C...Permutations of momenta in matrix element. Weighting.
50487 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
50498 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
50509 IF(IC.LE.3) GOTO 120
50510 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
50513 C...qqgg events: string configuration and event type.
50515 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
50516 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
50517 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
50518 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
50519 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
50520 IF(ID.EQ.2) GOTO 130
50521 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
50522 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
50523 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
50524 IF(ID.EQ.2) GOTO 130
50527 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
50528 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
50531 C...Mass cuts. Kinematical variables out.
50532 IF(Y12.LE.CUT+QME) NJET=2
50533 IF(NJET.EQ.2) GOTO 150
50534 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
50535 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
50536 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
50538 X12=(1D0-Q12)*Y13+Q12*Y23
50540 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
50542 C...qqbarqqbar events: string configuration, choose new flavour.
50545 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
50546 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
50547 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
50548 IF(WTR.LT.WTD(4)) ID=4
50549 IF(ID.GE.2) GOTO 130
50552 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
50553 140 KFLN=1+INT(5D0*PYR(0))
50554 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
50555 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
50556 IF(KFLN.GT.MSTJ(104)) NJET=2
50558 QMEN=(2D0*PMQN/ECM)**2
50560 C...Mass cuts. Kinematical variables out.
50561 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
50562 IF(NJET.EQ.2) GOTO 150
50563 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
50564 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
50565 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
50566 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
50567 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
50568 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
50571 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
50573 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
50574 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
50575 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
50577 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
50582 C*********************************************************************
50585 C...Gives the angular orientation of events.
50587 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
50589 C...Double precision and integer declarations.
50590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50591 IMPLICIT INTEGER(I-N)
50592 INTEGER PYK,PYCHGE,PYCOMP
50594 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50596 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50597 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50599 C...Charge. Factors depending on polarization for QED case.
50601 POLL=1D0-PARJ(131)*PARJ(132)
50602 POLD=PARJ(132)-PARJ(131)
50603 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
50609 C...Factors depending on flavour, energy and polarization for QFD case.
50611 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
50612 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
50613 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
50615 VE=4D0*PARU(102)-1D0
50617 VF=AF-4D0*QF*PARU(102)
50618 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
50619 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
50620 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
50621 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
50622 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
50623 & SFW*SFF**2*(VE**2-AE**2))
50624 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
50628 C...Mass factor. Differential cross-sections for two-jet events.
50631 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
50632 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
50634 SIGU=4D0*SQRT(1D0-QME)
50635 SIGL=2D0*QME*SQRT(1D0-QME)
50641 C...Kinematical variables. Reduce four-jet event to three-jet one.
50644 X1=2D0*P(NC+1,4)/ECM
50645 X2=2D0*P(NC+3,4)/ECM
50647 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
50648 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
50649 X1=2D0*P(NC+1,4)/ECMR
50650 X2=2D0*P(NC+4,4)/ECMR
50653 C...Differential cross-sections for three-jet (or reduced four-jet).
50654 XQ=(1D0-X1)/(1D0-X2)
50655 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
50656 ST12=SQRT(1D0-CT12**2)
50657 IF(MSTJ(109).NE.1) THEN
50658 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
50659 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
50660 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
50661 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
50663 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
50664 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
50665 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
50666 SIGA=X2**2*ST12/SQ2
50667 SIGP=2D0*(X1**2-X2**2*CT12)
50669 C...Differential cross-sect for scalar gluons (no mass effects).
50673 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
50674 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
50675 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
50676 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
50677 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
50678 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
50679 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
50680 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
50681 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
50682 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
50683 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
50687 C...Upper bounds for differential cross-section.
50692 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
50693 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
50694 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
50695 &2D0*HF2A*ABS(SIGP)
50697 C...Generate angular orientation according to differential cross-sect.
50698 100 CHI=PARU(2)*PYR(0)
50699 CTHE=2D0*PYR(0)-1D0
50707 C2PHI=COS(2D0*(PHI-PARJ(134)))
50708 S2PHI=SIN(2D0*(PHI-PARJ(134)))
50709 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
50710 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
50711 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
50712 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
50713 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
50714 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
50715 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
50716 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
50721 C*********************************************************************
50724 C...Generates Upsilon and toponium decays into three gluons
50725 C...or two gluons and a photon.
50727 SUBROUTINE PYONIA(KFL,ECM)
50729 C...Double precision and integer declarations.
50730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50731 IMPLICIT INTEGER(I-N)
50732 INTEGER PYK,PYCHGE,PYCOMP
50734 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50735 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50736 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50737 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50739 C...Printout. Check input parameters.
50740 IF(MSTU(12).GE.1) CALL PYLIST(0)
50741 IF(KFL.LT.0.OR.KFL.GT.8) THEN
50742 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
50743 IF(MSTU(21).GE.1) RETURN
50745 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
50746 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
50747 IF(MSTU(21).GE.1) RETURN
50750 C...Initial e+e- and onium state (optional).
50752 IF(MSTJ(115).GE.2) THEN
50754 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
50756 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
50760 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
50766 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
50772 C...Choose x1 and x2 according to matrix element.
50777 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
50778 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
50781 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
50782 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
50784 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
50785 MSTU(111)=MSTJ(108)
50786 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
50788 PARU(112)=PARJ(121)
50789 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
50791 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
50792 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
50795 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
50796 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
50798 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
50799 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
50802 ECMC=SQRT(1D0-X1)*ECM
50803 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
50808 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
50809 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
50810 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
50811 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
50813 IF(ECMC.LT.4D0*PARJ(127)) THEN
50817 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
50823 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
50826 C...Differential cross-sections. Upper limit for cross-section.
50827 IF(MSTJ(106).EQ.1) THEN
50829 HF1=1D0-PARJ(131)*PARJ(132)
50831 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
50832 ST13=SQRT(1D0-CT13**2)
50833 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
50834 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
50836 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
50837 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
50838 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
50840 C...Angular orientation of event.
50841 120 CHI=PARU(2)*PYR(0)
50842 CTHE=2D0*PYR(0)-1D0
50850 C2PHI=COS(2D0*(PHI-PARJ(134)))
50851 S2PHI=SIN(2D0*(PHI-PARJ(134)))
50852 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
50853 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
50854 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
50855 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
50856 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
50857 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
50858 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
50859 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
50862 C...Generate parton shower. Rearrange along strings and check.
50863 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
50864 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
50866 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
50867 IF(MSTJ(105).GE.0) MSTU(28)=0
50870 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
50873 C...Generate fragmentation. Information for PYTABU:
50874 IF(MSTJ(105).EQ.1) CALL PYEXEC
50875 MSTU(161)=110*KFLC+3
50881 C*********************************************************************
50884 C...Books a histogram.
50886 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
50888 C...Double precision declaration.
50889 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50890 IMPLICIT INTEGER(I-N)
50892 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
50894 C...Local character variables.
50895 CHARACTER TITLE*(*), TITFX*60
50897 C...Check that input is sensible. Find initial address in memory.
50898 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
50899 &'(PYBOOK:) not allowed histogram number')
50900 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
50901 &'(PYBOOK:) not allowed number of bins')
50902 IF(XL.GE.XU) CALL PYERRM(28,
50903 &'(PYBOOK:) x limits in wrong order')
50905 IHIST(4)=IHIST(4)+28+NX
50906 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
50907 &'(PYBOOK:) out of histogram space')
50910 C...Store histogram size and reset contents.
50914 BIN(IS+4)=(XU-XL)/NX
50917 C...Store title by conversion to integer to double precision.
50920 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
50921 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
50927 C*********************************************************************
50930 C...Fills entry in histogram.
50932 SUBROUTINE PYFILL(ID,X,W)
50934 C...Double precision declaration.
50935 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50936 IMPLICIT INTEGER(I-N)
50938 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
50941 C...Find initial address in memory. Increase number of entries.
50942 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
50943 &'(PYFILL:) not allowed histogram number')
50945 IF(IS.EQ.0) CALL PYERRM(28,
50946 &'(PYFILL:) filling unbooked histogram')
50947 BIN(IS+5)=BIN(IS+5)+1D0
50949 C...Find bin in x, including under/overflow, and fill.
50950 IF(X.LT.BIN(IS+2)) THEN
50951 BIN(IS+6)=BIN(IS+6)+W
50952 ELSEIF(X.GE.BIN(IS+3)) THEN
50953 BIN(IS+8)=BIN(IS+8)+W
50955 BIN(IS+7)=BIN(IS+7)+W
50956 IX=(X-BIN(IS+2))/BIN(IS+4)
50957 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
50958 BIN(IS+9+IX)=BIN(IS+9+IX)+W
50964 C*********************************************************************
50967 C...Multiplies histogram contents by factor.
50969 SUBROUTINE PYFACT(ID,F)
50971 C...Double precision declaration.
50972 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50973 IMPLICIT INTEGER(I-N)
50975 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
50978 C...Find initial address in memory. Multiply all contents bins.
50979 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
50980 &'(PYFACT:) not allowed histogram number')
50982 IF(IS.EQ.0) CALL PYERRM(28,
50983 &'(PYFACT:) scaling unbooked histogram')
50984 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
50991 C*********************************************************************
50994 C...Performs operations between histograms.
50996 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
50998 C...Double precision declaration.
50999 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51000 IMPLICIT INTEGER(I-N)
51002 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51004 C...Character variable.
51007 C...Find initial addresses in memory, and histogram size.
51008 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
51009 &'(PYFACT:) not allowed histogram number')
51011 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
51012 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
51013 NX=NINT(BIN(IS3+1))
51014 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
51016 C...Update info on number of histogram entries.
51017 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
51018 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
51019 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
51020 BIN(IS3+5)=BIN(IS1+5)
51023 C...Operations on pair of histograms: addition, subtraction,
51024 C...multiplication, division.
51025 IF(OPER.EQ.'+') THEN
51027 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
51029 ELSEIF(OPER.EQ.'-') THEN
51031 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
51033 ELSEIF(OPER.EQ.'*') THEN
51035 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
51037 ELSEIF(OPER.EQ.'/') THEN
51040 IF(ABS(FA2).LE.1D-20) THEN
51043 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
51047 C...Operations on single histogram: multiplication+addition,
51048 C...square root+addition, logarithm+addition.
51049 ELSEIF(OPER.EQ.'A') THEN
51051 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
51053 ELSEIF(OPER.EQ.'S') THEN
51055 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
51057 ELSEIF(OPER.EQ.'L') THEN
51060 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
51061 & ZMIN=0.8D0*BIN(IS1+IX)
51064 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
51067 C...Operation on two or three histograms: average and
51068 C...standard deviation.
51069 ELSEIF(OPER.EQ.'M') THEN
51071 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
51074 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
51077 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
51080 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
51084 BIN(IS1+IX)=F1*BIN(IS1+IX)
51091 C*********************************************************************
51094 C...Prints and resets all histograms.
51098 C...Double precision declaration.
51099 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51100 IMPLICIT INTEGER(I-N)
51102 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51105 C...Loop over histograms, print and reset used ones.
51106 DO 100 ID=1,IHIST(1)
51108 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
51117 C*********************************************************************
51120 C...Prints a histogram (but does not reset it).
51122 SUBROUTINE PYPLOT(ID)
51124 C...Double precision declaration.
51125 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51126 IMPLICIT INTEGER(I-N)
51128 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51129 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51130 SAVE /PYDAT1/,/PYBINS/
51131 C...Local arrays and character variables.
51132 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
51133 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
51135 C...Steps in histogram scale. Character sequence.
51136 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
51137 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
51139 C...Find initial address in memory; skip if empty histogram.
51140 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
51143 IF(NINT(BIN(IS+5)).LE.0) THEN
51144 WRITE(MSTU(11),5000) ID
51148 C...Number of histogram lines and x bins.
51152 C...Extract title by conversion from double precision via integer.
51154 IEQ=NINT(BIN(IS+8+NX+IT))
51155 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
51156 & //CHAR(MOD(IEQ,256))
51159 C...Find time; print title.
51161 IF(IDATI(1).GT.0) THEN
51162 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
51164 WRITE(MSTU(11),5200) ID, TITLE
51167 C...Find minimum and maximum bin content.
51170 DO 110 IX=IS+10,IS+8+NX
51171 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
51172 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
51175 C...Determine scale and step size for y axis.
51176 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
51177 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
51178 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
51179 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
51180 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
51181 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
51184 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
51188 C...Convert bin contents to integer form; fractional fill in top row.
51190 CTA=ABS(BIN(IS+8+IX))/DY
51191 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
51192 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
51194 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
51195 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
51197 C...Print histogram row by row.
51198 DO 150 IR=IRMA,IRMI,-1
51199 IF(IR.EQ.0) GOTO 150
51202 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
51203 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
51205 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
51208 C...Print sign and value of bin contents.
51209 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
51212 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
51213 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
51215 WRITE(MSTU(11),5400) OUT
51218 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
51220 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
51223 C...Print sign and value of lower bin edge.
51224 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
51228 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
51229 & OUT(IX:IX)=CHA(11)
51230 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
51232 WRITE(MSTU(11),5600) OUT
51235 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
51237 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
51241 C...Calculate and print statistics.
51246 CTA=ABS(BIN(IS+8+IX))
51247 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
51250 CXXSUM=CXXSUM+CTA*X**2
51252 XMEAN=CXSUM/MAX(CSUM,1D-20)
51253 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
51254 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
51255 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
51257 C...Formats for output.
51258 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
51259 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
51261 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
51262 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
51263 5400 FORMAT(/8X,'Contents',3X,A100)
51264 5500 FORMAT(9X,'*10**',I2,3X,A100)
51265 5600 FORMAT(/8X,'Low edge',3X,A100)
51266 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
51267 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
51268 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
51273 C*********************************************************************
51276 C...Resets bin contents of a histogram.
51278 SUBROUTINE PYNULL(ID)
51280 C...Double precision declaration.
51281 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51282 IMPLICIT INTEGER(I-N)
51284 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51287 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
51290 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
51297 C*********************************************************************
51300 C...Dumps histogram contents on file for reading by other program.
51301 C...Can also read back own dump.
51303 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
51305 C...Double precision declaration.
51306 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51307 IMPLICIT INTEGER(I-N)
51309 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51311 C...Local arrays and character variables.
51312 DIMENSION IHI(*),ISS(100),VAL(5)
51313 CHARACTER TITLE*60,FORMAT*13
51315 C...Dump all histograms that have been booked,
51316 C...including titles and ranges, one after the other.
51317 IF(MDUMP.EQ.1) THEN
51319 C...Loop over histograms and find which are wanted and booked.
51334 C...Write title, histogram size, filling statistics.
51337 IEQ=NINT(BIN(IS+8+NX+IT))
51338 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
51339 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
51341 WRITE(LFN,5100) ID,TITLE
51342 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
51343 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
51347 C...Write histogram contents, in groups of five.
51348 DO 120 IXG=1,(NX+4)/5
51352 VAL(IXV)=BIN(IS+8+IX)
51357 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
51360 C...Go to next histogram; finish.
51361 ELSEIF(NHI.GT.0) THEN
51362 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
51366 C...Read back in histograms dumped MDUMP=1.
51367 ELSEIF(MDUMP.EQ.2) THEN
51369 C...Read histogram number, title and range, and book.
51370 140 READ(LFN,5100,END=170) ID,TITLE
51371 READ(LFN,5200) NX,XL,XU
51372 CALL PYBOOK(ID,TITLE,NX,XL,XU)
51375 C...Read filling statistics.
51376 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
51377 BIN(IS+5)=DBLE(NENTRY)
51379 C...Read histogram contents, in groups of five.
51380 DO 160 IXG=1,(NX+4)/5
51381 READ(LFN,5400) (VAL(IXV),IXV=1,5)
51384 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
51388 C...Go to next histogram; finish.
51392 C...Write histogram contents in column format,
51393 C...convenient e.g. for GNUPLOT input.
51394 ELSEIF(MDUMP.EQ.3) THEN
51396 C...Find addresses to wanted histograms.
51410 IF(IS.NE.0.AND.NSS.LT.100) THEN
51413 ELSEIF(NSS.GE.100) THEN
51414 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
51415 ELSEIF(NHI.GT.0) THEN
51416 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
51420 C...Check that they have common number of x bins. Fix format.
51421 NX=NINT(BIN(ISS(1)+1))
51423 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
51424 CALL PYERRM(8,'(PYDUMP:) different number of bins')
51428 FORMAT='(1P,000E12.4)'
51429 WRITE(FORMAT(5:7),'(I3)') NSS+1
51431 C...Write histogram contents; first column x values.
51433 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
51434 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
51439 C...Formats for output.
51440 5100 FORMAT(I5,5X,A60)
51441 5200 FORMAT(I5,1P,2D12.4)
51442 5300 FORMAT(I12,1P,3D12.4)
51443 5400 FORMAT(1P,5D12.4)
51448 C*********************************************************************
51451 C...Dummy routine, which the user can replace in order to make cuts on
51452 C...the kinematics on the parton level before the matrix elements are
51453 C...evaluated and the event is generated. The cross-section estimates
51454 C...will automatically take these cuts into account, so the given
51455 C...values are for the allowed phase space region only. MCUT=0 means
51456 C...that the event has passed the cuts, MCUT=1 that it has failed.
51458 SUBROUTINE PYKCUT(MCUT)
51460 C...Double precision and integer declarations.
51461 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51462 IMPLICIT INTEGER(I-N)
51463 INTEGER PYK,PYCHGE,PYCOMP
51465 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51466 COMMON/PYINT1/MINT(400),VINT(400)
51467 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
51468 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
51470 C...Set default value (accepting event) for MCUT.
51473 C...Read out subprocess number.
51477 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
51481 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
51483 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
51485 C...Calculate x_1, x_2, x_F.
51486 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
51487 X1=SQRT(TAU)*EXP(YST)
51488 X2=SQRT(TAU)*EXP(-YST)
51490 X1=SQRT(TAUP)*EXP(YST)
51491 X2=SQRT(TAUP)*EXP(-YST)
51495 C...Calculate shat, that, uhat, p_T^2.
51501 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
51502 RPTS=4D0*VINT(71)**2/SHAT
51503 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
51506 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
51507 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
51508 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
51509 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
51511 C...Decisions by user to be put here.
51513 C...Stop program if this routine is ever called.
51514 C...You should not copy these lines to your own routine.
51515 WRITE(MSTU(11),5000)
51516 IF(PYR(0).LT.10D0) STOP
51518 C...Format for error printout.
51519 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
51520 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
51521 &1X,'Execution stopped!')
51526 C*********************************************************************
51529 C...Dummy routine, which the user can replace in order to multiply the
51530 C...standard PYTHIA differential cross-section by a process- and
51531 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
51532 C...to generation of weighted events, with weight 1/WTXS, while for
51533 C...MSTP(142)=2 it corresponds to a modification of the underlying
51536 SUBROUTINE PYEVWT(WTXS)
51538 C...Double precision and integer declarations.
51539 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51540 IMPLICIT INTEGER(I-N)
51541 INTEGER PYK,PYCHGE,PYCOMP
51543 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51544 COMMON/PYINT1/MINT(400),VINT(400)
51545 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
51546 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
51548 C...Set default weight for WTXS.
51551 C...Read out subprocess number.
51555 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
51559 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
51561 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
51563 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
51572 C...Modifications by user to be put here.
51574 C...Stop program if this routine is ever called.
51575 C...You should not copy these lines to your own routine.
51576 WRITE(MSTU(11),5000)
51577 IF(PYR(0).LT.10D0) STOP
51579 C...Format for error printout.
51580 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
51581 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
51582 &1X,'Execution stopped!')
51587 C*********************************************************************
51590 C...Dummy copy of routine to be called by user to set up a user-defined
51593 SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX)
51595 C...Double precision and integer declarations.
51596 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51597 IMPLICIT INTEGER(I-N)
51598 INTEGER PYK,PYCHGE,PYCOMP
51600 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51601 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
51602 COMMON/PYINT6/PROC(0:500)
51604 SAVE /PYDAT1/,/PYINT2/,/PYINT6/
51605 C...Local character variable.
51606 CHARACTER*(*) TITLE
51608 C...Check that subprocess number free.
51609 IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN
51610 WRITE(MSTU(11),5000) ISUB
51614 C...Fill information on new process.
51616 COEF(ISUB,1)=SIGMAX
51617 PROC(ISUB)=TITLE//' '
51619 C...Format for error output.
51620 5000 FORMAT(1X,'Error: user-defined subprocess code ',I4,
51621 &' not allowed.'//1X,'Execution stopped!')
51626 C*********************************************************************
51629 C...Dummy routine, to be replaced by user. When called from PYTHIA
51630 C...the subprocess number ISUB will be given, and PYUPEV is supposed
51631 C...to generate an event of this type, to be stored in the PYUPPR
51632 C...commonblock. SIGEV gives the differential cross-section associated
51633 C...with the event, i.e. the acceptance probability of the event is
51634 C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
51637 SUBROUTINE PYUPEV(ISUB,SIGEV)
51639 C...Double precision and integer declarations.
51640 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51641 IMPLICIT INTEGER(I-N)
51642 INTEGER PYK,PYCHGE,PYCOMP
51644 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51645 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
51646 SAVE /PYDAT1/,/PYUPPR/
51648 C...Stop program if this routine is ever called.
51649 C...You should not copy these lines to your own routine.
51650 WRITE(MSTU(11),5000)
51651 IF(PYR(0).LT.10D0) STOP
51654 C...Format for error printout.
51655 5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ',
51656 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
51657 &1X,'Execution stopped!')
51662 C*********************************************************************
51664 C...Dummy routine, to be replaced by user, to handle the decay of a
51665 C...polarized tau lepton.
51667 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
51668 C...IORIG is the position where the mother of the tau is stored;
51669 C... is 0 when the mother is not stored.
51670 C...KFORIG is the flavour of the mother of the tau;
51671 C... is 0 when the mother is not known.
51672 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
51673 C... e.g. in B hadron semileptonic decays the W propagator
51674 C... is not explicitly stored but the W code is still unambiguous.
51676 C...NDECAY is the number of decay products in the current tau decay.
51677 C...These decay products should be added to the /PYJETS/ common block,
51678 C...in positions N+1 through N+NDECAY. For each product I you must
51679 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
51680 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
51682 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
51684 C...Double precision and integer declarations.
51685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51686 IMPLICIT INTEGER(I-N)
51687 INTEGER PYK,PYCHGE,PYCOMP
51689 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51691 SAVE /PYJETS/,/PYDAT1/
51693 C...Stop program if this routine is ever called.
51694 C...You should not copy these lines to your own routine.
51695 NDECAY=ITAU+IORIG+KFORIG
51696 WRITE(MSTU(11),5000)
51697 IF(PYR(0).LT.10D0) STOP
51699 C...Format for error printout.
51700 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
51701 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
51702 &1X,'Execution stopped!')
51707 C*********************************************************************
51710 C...Finds current date and time.
51711 C...Since this task is not standardized in Fortran 77, the routine
51712 C...is dummy, to be replaced by the user. Examples are given for
51713 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
51714 C...you do not have access to suitable routines.
51716 SUBROUTINE PYTIME(IDATI)
51718 C...Double precision and integer declarations.
51719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51720 IMPLICIT INTEGER(I-N)
51721 INTEGER PYK,PYCHGE,PYCOMP
51724 INTEGER IDATI(6),IDTEMP(3)
51726 C...Example 0: if you do not have suitable routines.
51731 C...Example 1: Fortran 90 routine.
51733 C CALL DATE_AND_TIME(VALUES=IVAL)
51741 C...Example 2: DEC Fortran 77. AIX.
51742 C CALL IDATE(IMON,IDAY,IYEAR)
51743 C IF(IYEAR.LT.70) THEN
51744 C IDATI(1)=2000+IYEAR
51745 C ELSEIF(IYEAR.LT.100) THEN
51746 C IDATI(1)=1900+IYEAR
51752 C CALL ITIME(IHOUR,IMIN,ISEC)
51757 C...Example 3: DEC Fortran, IRIX, IRIX64.
51758 C CALL IDATE(IMON,IDAY,IYEAR)
51759 C IF(IYEAR.LT.70) THEN
51760 C IDATI(1)=2000+IYEAR
51761 C ELSEIF(IYEAR.LT.100) THEN
51762 C IDATI(1)=1900+IYEAR
51772 C READ(ATIME(1:2),'(I2)') IHOUR
51773 C READ(ATIME(4:5),'(I2)') IMIN
51774 C READ(ATIME(7:8),'(I2)') ISEC
51779 C...Example 4: GNU LINUX libU77, SunOS.
51780 C CALL IDATE(IDTEMP)
51781 C IDATI(1)=IDTEMP(3)
51782 C IDATI(2)=IDTEMP(2)
51783 C IDATI(3)=IDTEMP(1)
51784 C CALL ITIME(IDTEMP)
51785 C IDATI(4)=IDTEMP(1)
51786 C IDATI(5)=IDTEMP(2)
51787 C IDATI(6)=IDTEMP(3)
git://git.uio.no / u / mrichter / AliRoot.git / blob