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* Argonne National Laboratory **
20 C* 9700 South Cass Avenue, Argonne, IL 60439, USA **
21 C* phone + 1 - 630 - 252 - 7615 **
22 C* E-mail mrenna@hep.anl.gov **
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* CTEQ 3 parton distributions are by the CTEQ collaboration **
28 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
29 C* SaS photon parton distributions together with Gerhard Schuler **
30 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
31 C* MSSM Higgs mass calculation code by M. Carena, **
32 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
33 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
35 C* The latest program version and documentation is found on WWW **
36 C* http://www.thep.lu.se/tf2/staff/torbjorn/Pythia.html **
38 C* Copyright Torbjorn Sjostrand, Lund 1997 **
40 C*********************************************************************
41 C*********************************************************************
43 C List of subprograms in order of appearance, with main purpose *
44 C (S = subroutine, F = function, B = block data) *
46 C B PYDATA to contain all default values *
47 C S PYTEST to test the proper functioning of the package *
48 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
50 C S PYINIT to administer the initialization procedure *
51 C S PYEVNT to administer the generation of an event *
52 C S PYSTAT to print cross-section and other information *
53 C S PYINRE to initialize treatment of resonances *
54 C S PYINBM to read in beam, target and frame choices *
55 C S PYINKI to initialize kinematics of incoming particles *
56 C S PYINPR to set up the selection of included processes *
57 C S PYXTOT to give total, elastic and diffractive cross-sect. *
58 C S PYMAXI to find differential cross-section maxima *
59 C S PYPILE to select multiplicity of pileup events *
60 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
61 C S PYRAND to select subprocess and kinematics for event *
62 C S PYSCAT to set up kinematics and colour flow of event *
63 C S PYSSPA to simulate initial state spacelike showers *
64 C S PYRESD to perform resonance decays *
65 C S PYMULT to generate multiple interactions *
66 C S PYREMN to add on target remnants *
67 C S PYDIFF to set up kinematics for diffractive events *
68 C S PYDOCU to compute cross-sections and handle documentation *
69 C S PYFRAM to perform boosts between different frames *
70 C S PYWIDT to calculate full and partial widths of resonances *
71 C S PYOFSH to calculate partial width into off-shell channels *
72 C S PYRECO to handle colour reconnection in W+W- events *
73 C S PYKLIM to calculate borders of allowed kinematical region *
74 C S PYKMAP to construct value of kinematical variable *
75 C S PYSIGH to calculate differential cross-sections *
76 C S PYPDFU to evaluate parton distributions *
77 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
78 C S PYPDEL to evaluate electron parton distributions *
79 C S PYPDGA to evaluate photon parton distributions (generic) *
80 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
81 C S PYGVMD to evaluate VMD part of photon parton distributions *
82 C S PYGANO to evaluate anomalous part of photon pdf's *
83 C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
84 C S PYGDIR to evaluate direct contribution to photon pdf's *
85 C S PYPDPI to evaluate pion parton distributions *
86 C S PYPDPR to evaluate proton parton distributions *
87 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
88 C S PYGRVL to evaluate the GRV 94L pronton parton distributions *
89 C S PYGRVM to evaluate the GRV 94M pronton parton distributions *
90 C S PYGRVD to evaluate the GRV 94D pronton parton distributions *
91 C F PYGRVV auxiliary to the PYGRV* routines *
92 C F PYGRVW auxiliary to the PYGRV* routines *
93 C F PYGRVS auxiliary to the PYGRV* routines *
94 C F PYHFTH to evaluate threshold factor for heavy flavour *
95 C S PYSPLI to find flavours left in hadron when one removed *
96 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
97 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
98 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
99 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
100 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
102 C S PYMSIN to initialize the supersymmetry simulation *
103 C S PYAPPS to determine MSSM parameters from SUGRA input *
104 C F PYRNMQ to determine running quark masses *
105 C F PYRNMT to determine running top mass *
106 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
107 C S PYINOM to calculate neutralino/chargino mass eigenstates *
108 C F PYRNM3 to determine running M3, gluino mass *
109 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
110 C S PYHGGM to determine Higgs mass spectrum *
111 C S PYSUBH to determine Higgs masses in the MSSM *
112 C S PYPOLE to determine Higgs masses in the MSSM *
113 C S PYVACU to determine Higgs masses in the MSSM *
114 C S PYRGHM auxiliary to PYVACU *
115 C S PYGFXX auxiliary to PYRGHM *
116 C F PYFINT auxiliary to PYVACU *
117 C F PYFISB auxiliary to PYFINT *
118 C S PYSFDC to calculate sfermion decay partial widths *
119 C S PYGLUI to calculate gluino decay partial widths *
120 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
121 C S PYTBBC to calculate 3-body decay of gluino to chargino *
122 C S PYNJDC to calculate neutralino decay partial widths *
123 C S PYCJDC to calculate chargino decay partial widths *
124 C F PYXXZ5 auxiliary for neutralino 3-body decay *
125 C F PYXXW5 auxiliary for ino charge change 3-body decay *
126 C F PYXXGA auxiliary for ino -> ino + gamma decay *
127 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
128 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
129 C F PYXXZ2 auxiliary for chargino 3-body decay *
130 C S PYHEXT to calculate non-SM Higgs decay partial widths *
131 C F PYH2XX auxiliary for H -> ino + ino decay *
132 C F PYGAUS to perform Gaussian integration *
133 C F PYSIMP to perform Simpson integration *
134 C F PYLAMF to evaluate the lambda kinematics function *
135 C S PYTBDY to perform 3-body decay of gauginos *
137 C S PY1ENT to fill one entry (= parton or particle) *
138 C S PY2ENT to fill two entries *
139 C S PY3ENT to fill three entries *
140 C S PY4ENT to fill four entries *
141 C S PYJOIN to connect entries with colour flow information *
142 C S PYGIVE to fill (or query) commonblock variables *
143 C S PYEXEC to administrate fragmentation and decay chain *
144 C S PYPREP to rearrange showered partons along strings *
145 C S PYSTRF to do string fragmentation of jet system *
146 C S PYINDF to do independent fragmentation of one or many jets *
147 C S PYDECY to do the decay of a particle *
148 C S PYDCYK to select parton and hadron flavours in decays *
149 C S PYKFDI to select parton and hadron flavours in fragm *
150 C S PYNMES to select number of popcorn mesons *
151 C S PYKFIN to calculate falvour prod. ratios from input params. *
152 C S PYPTDI to select transverse momenta in fragm *
153 C S PYZDIS to select longitudinal scaling variable in fragm *
154 C S PYSHOW to do timelike parton shower evolution *
155 C S PYBOEI to include Bose-Einstein effects (crudely) *
156 C F PYMASS to give the mass of a particle or parton *
157 C S PYNAME to give the name of a particle or parton *
158 C F PYCHGE to give three times the electric charge *
159 C F PYCOMP to compress standard KF flavour code to internal KC *
160 C S PYERRM to write error messages and abort faulty run *
161 C F PYALEM to give the alpha_electromagnetic value *
162 C F PYALPS to give the alpha_strong value *
163 C F PYANGL to give the angle from known x and y components *
164 C F PYR to provide a random number generator *
165 C S PYRGET to save the state of the random number generator *
166 C S PYRSET to set the state of the random number generator *
167 C S PYROBO to rotate and/or boost an event *
168 C S PYEDIT to remove unwanted entries from record *
169 C S PYLIST to list event record or particle data *
170 C S PYLOGO to write a logo *
171 C S PYUPDA to update particle data *
172 C F PYK to provide integer-valued event information *
173 C F PYP to provide real-valued event information *
174 C S PYSPHE to perform sphericity analysis *
175 C S PYTHRU to perform thrust analysis *
176 C S PYCLUS to perform three-dimensional cluster analysis *
177 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
178 C S PYJMAS to give high and low jet mass of event *
179 C S PYFOWO to give Fox-Wolfram moments *
180 C S PYTABU to analyze events, with tabular output *
182 C S PYEEVT to administrate the generation of an e+e- event *
183 C S PYXTEE to give the total cross-section at given CM energy *
184 C S PYRADK to generate initial state photon radiation *
185 C S PYXKFL to select flavour of primary qqbar pair *
186 C S PYXJET to select (matrix element) jet multiplicity *
187 C S PYX3JT to select kinematics of three-jet event *
188 C S PYX4JT to select kinematics of four-jet event *
189 C S PYXDIF to select angular orientation of event *
190 C S PYONIA to perform generation of onium decay to gluons *
192 C S PYBOOK to book a histogram *
193 C S PYFILL to fill an entry in a histogram *
194 C S PYFACT to multiply histogram contents by a factor *
195 C S PYOPER to perform operations between histograms *
196 C S PYHIST to print and reset all histograms *
197 C S PYPLOT to print a single histogram *
198 C S PYNULL to reset contents of a single histogram *
199 C S PYDUMP to dump histogram contents onto a file *
201 C S PYKCUT dummy routine for user kinematical cuts *
202 C S PYEVWT dummy routine for weighting events *
203 C S PYUPIN dummy routine to initialize a user process *
204 C S PYUPEV dummy routine to generate a user process event *
205 C S PDFSET dummy routine to be removed when using PDFLIB *
206 C S STRUCTM dummy routine to be removed when using PDFLIB *
207 C S PYTAUD dummy routine for interface to tau decay libraries *
208 C S PYTIME dummy routine for giving date and time *
210 C*********************************************************************
213 C...Default values for switches and parameters,
214 C...and particle, decay and process data.
218 C...Double precision and integer declarations.
219 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
220 INTEGER PYK,PYCHGE,PYCOMP
222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
224 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
225 COMMON/PYDAT4/CHAF(500,2)
227 COMMON/PYDATR/MRPY(6),RRPY(100)
228 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
229 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
230 COMMON/PYINT1/MINT(400),VINT(400)
231 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
232 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
233 COMMON/PYINT4/MWID(500),WIDS(500,5)
234 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
235 COMMON/PYINT6/PROC(0:500)
237 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
238 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
239 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
241 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
242 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
243 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
244 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYBINS/
246 C...PYDAT1, containing status codes and most parameters.
248 & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
249 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
250 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
251 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
252 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
253 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
254 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
256 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
257 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
260 & 3.141592653589793D0, 6.283185307179586D0,
261 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
262 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
263 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
264 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
265 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
266 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
267 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
269 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
270 & 0D0, 0D0, 0D0, 0D0, 0D0,
271 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
272 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
273 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
274 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
275 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
276 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
277 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
278 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
279 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
280 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
282 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
283 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
284 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
285 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
286 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
287 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
289 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
290 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
293 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
294 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
295 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
296 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
297 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0,2.5D0,0.6D0,0D0,
298 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0,
299 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
300 5 -0.00001D0, -0.00001D0, -0.00001D0, 1.0D0, 0D0,
301 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
302 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0, 0D0, 0D0,
303 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0, 0D0,
304 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
305 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
306 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
307 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
308 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
309 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
312 C...PYDAT2, with particle data and flavour treatment parameters.
313 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
314 &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,28*0,2,-1,20*0,4*3,
315 &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,3*0,4,3*3,
316 &6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,
317 &3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,
318 &3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,
319 &-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,3*0,3,2*0,3,0,
320 &3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,
321 &2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
322 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
323 &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,
324 &-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,
326 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,
327 &11*0,1,2*0,1,26*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,12*1,3*0,
328 &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,0,4*1,
329 &3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
330 DATA (KCHG(I,4),I= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
331 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
332 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
333 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
334 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
335 &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
336 &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
337 &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
338 &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
339 &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
340 &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
341 &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
342 &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
343 &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
344 &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
345 &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
346 &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
347 &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
348 &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
349 &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
350 DATA (KCHG(I,4),I= 294, 500)/20443,20513,20523,20533,20543,20553,
351 &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
352 &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
353 &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
354 &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
355 &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
356 DATA (PMAS(I,1),I= 1, 214)/0.0099D0,0.0056D0,0.199D0,1.35D0,
357 &5D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,
358 &400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0,
359 &3*300D0,350D0,200D0,5000D0,10*0D0,3*100D0,3*200D0,26*0D0,1D0,2D0,
360 &5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,0.49767D0,0D0,0.13957D0,
361 &0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,1.275D0,2*0.49767D0,
362 &0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,0D0,0.95777D0,
363 &1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,2.0067D0,2.46D0,
364 &1.9685D0,2.1124D0,2.5735D0,0D0,2.9798D0,3.09688D0,3.5562D0,
365 &5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,5.3693D0,
366 &5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,9.9132D0,
367 &0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,0.93957D0,1.233D0,
368 &0.77133D0,0D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
369 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
370 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
371 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
372 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
373 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
374 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
375 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0/
376 DATA (PMAS(I,1),I= 215, 500)/5.641D0,5.84D0,7.00575D0,5.38897D0,
377 &5.40145D0,5.8D0,5.81D0,5.8D0,5.81D0,5.84D0,7.00575D0,5.56725D0,
378 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
379 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
380 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
381 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
382 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
383 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
384 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
385 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
386 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
387 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
389 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.4D0,16*0D0,2.47833D0,
390 &2.069D0,0.00295D0,6*0D0,14.67788D0,0D0,16.79392D0,8.45231D0,
391 &4.93534D0,5.80468D0,19.1898D0,0.39162D0,417.35283D0,62*0D0,
392 &0.151D0,0.107D0,3*0D0,0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0,
393 &2*0D0,0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0D0,0.0002D0,
394 &0.00443D0,0.076D0,2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0,
395 &0.0013D0,0D0,0.002D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,
396 &2*0D0,0.02D0,4*0D0,0.12D0,4*0D0,0.12D0,3*0D0,2*0.12D0,3*0D0,
397 &0.0394D0,4*0D0,0.036D0,0D0,0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,
398 &74*0D0,0.06D0,0.142D0,0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,
399 &0.287D0,0.09D0,0.25D0,0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,
400 &0D0,0.014D0,0.01D0,8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,
401 &0.053D0,3*0.05D0,0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,
402 &1D0,0D0,1D0,0D0,2.60511D0,2.60839D0,0.42904D0,0.41921D0,163*0D0/
403 DATA (PMAS(I,3),I= 1, 500)/5*0D0,14D0,16*0D0,24.78326D0,
404 &20.69D0,0.02954D0,6*0D0,146.77876D0,0D0,167.93924D0,84.52308D0,
405 &49.35344D0,58.04675D0,191.89803D0,3.91624D0,4173.5283D0,62*0D0,
406 &0.4D0,0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0,
407 &0.12D0,0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
408 &2*0D0,0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,
409 &2*0D0,0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0,
410 &3*0D0,2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,
411 &0.05D0,0D0,0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,
412 &0.4D0,0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,
413 &0.08D0,0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,
414 &2*0.3D0,0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,
415 &3*0D0,19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,
416 &0.00001D0,26.05109D0,26.08388D0,4.29043D0,4.19206D0,163*0D0/
417 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
418 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,0D0,7804.5D0,6*0D0,
419 &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
420 &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*0D0,
421 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
422 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
423 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
424 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,83*0D0,163*0D0/
426 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
427 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
428 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
429 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
430 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
431 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
432 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
433 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
434 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
435 9 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
436 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
437 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
438 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
440 4 0.2D0, 0.5D0, 8*0D0,
442 DATA ((VCKM(I,J),J=1,4),I=1,4)/
443 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
444 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
445 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
446 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
448 C...PYDAT3, with particle decay parameters and data.
449 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
450 &7*1,10*0,2*1,0,3*1,26*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,12*1,
451 &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,5*1,
452 &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,1,0,
454 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80,
455 &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414,
456 &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0,
457 &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696,
458 &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923,
459 &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095,
460 &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124,
461 &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155,
462 &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248,
463 &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284,
464 &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343,
465 &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419,
466 &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519,
467 &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559,
468 &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584,
469 &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623,
470 &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731,
471 &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0,
472 &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489,
474 DATA (MDCY(I,3),I= 1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3,
475 &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,2*5,0,20,24,18,
476 &26*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,11,0,6,11,6,
477 &63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,0,
478 &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,2*1,76,4,2*0,
479 &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,2*9,2*0,4*1,9,
480 &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,2*2,14,2*2,4,
481 &9*2,11,14,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0,
483 DATA (MDME(I,1),I= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
484 &7*1,-1,1,-1,12*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
485 &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,85*1,2*-1,
486 &6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,197*1,2*-1,2*1,-1,20*1,
487 &2*-1,6*1,2*-1,7*1,-1,3*1,-1,3*1,5*-1,3*1,-1,1,-1,6*1,2*-1,6*1,
489 DATA (MDME(I,2),I= 1,4000)/43*102,4*0,102,0,4*53,3*102,4*0,102,
490 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
491 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,21*0,62*53,8*32,14*0,
492 &16*32,27*0,62*53,18*0,62*53,9*0,18*53,3*32,0,6*32,3*0,2*32,3*0,
493 &2*32,7*0,8*32,12*0,16*32,6*0,8*32,8*0,12,2*42,2*11,9*42,0,2,3,
494 &15*0,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,
495 &3*0,1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,
496 &6*0,12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,
497 &3*13,2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,
498 &4*32,2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,
499 &2*42,2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
500 &2*42,2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,
501 &9*42,0,162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,
502 &4*32,2*4,5*0,828*53,1515*0/
503 DATA (BRAT(I) ,I= 1, 418)/43*0D0,0.00003D0,0.00177D0,0.9982D0,
504 &33*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,0.003D0,
505 &0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,0.0071D0,
506 &0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,0.0034D0,0.08D0,
507 &0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,0.0067D0,0.0005D0,
508 &0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,0.00075D0,0.0001D0,
509 &0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,0.0004D0,0.0001D0,
510 &2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,0.00025D0,35*0D0,
511 &0.15403D0,0.11945D0,0.15402D0,0.11931D0,0.15215D0,3*0D0,
512 &0.03357D0,0.0668D0,0.03357D0,0.0668D0,0.0335D0,0.0668D0,2*0D0,
513 &0.32139D0,0.0165D0,2*0D0,0.0165D0,0.32067D0,2*0D0,0.00001D0,
514 &0.00059D0,6*0D0,2*0.10814D0,0.10806D0,3*0D0,0.00031D0,0.04438D0,
515 &0.88031D0,4*0D0,0.0002D0,0.05531D0,0D0,0.01838D0,0.00071D0,0D0,
516 &0.00009D0,0.00032D0,62*0D0,0.14449D0,0.11223D0,0.14449D0,
517 &0.11223D0,0.14443D0,0.05782D0,2*0D0,0.03172D0,0.06305D0,
518 &0.03172D0,0.06305D0,0.03172D0,0.06305D0,8*0D0,0.24928D0,0.0128D0,
519 &0.00001D0,0D0,0.0128D0,0.24882D0,0.00039D0,0D0,0.00001D0,
520 &0.00046D0,0.22153D0,5*0D0,2*0.08464D0,0.08463D0,7*0D0,0.00005D0,
521 &0.00097D0,5*0D0,0.00007D0,0D0,0.00049D0,0.00001D0,0.00006D0,
522 &0.30591D0,0.68863D0,0D0,0.0038D0,66*0D0,0.00008D0,0.00167D0/
523 DATA (BRAT(I) ,I= 419, 722)/5*0D0,0.00013D0,0D0,0.00294D0,
524 &0.00001D0,3*0D0,0.99517D0,63*0D0,0.00002D0,0.07231D0,2*0D0,
525 &0.00001D0,0.00269D0,0D0,0.92497D0,18*0D0,0.0024D0,0.99483D0,
526 &0.00278D0,1D0,3*0.21511D0,0.21478D0,2*0D0,2*0.06995D0,2*0D0,1D0,
527 &3*0D0,0.95D0,0.05D0,3*0D0,4*0.25D0,16*0D0,4*0.25D0,20*0D0,1D0,
528 &17*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,
529 &0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,0.998739D0,
530 &0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,0.144D0,
531 &0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,
532 &2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,
533 &0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,
534 &0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,
535 &0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,
536 &0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,
537 &2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,
538 &0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,
539 &0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,
540 &0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,
541 &0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,
542 &0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0,0.48947D0/
543 DATA (BRAT(I) ,I= 723, 897)/0.34D0,3*0.043D0,0.027D0,0.0126D0,
544 &0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,
545 &2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,
546 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,
547 &0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,
548 &0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,
549 &0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,
550 &0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,
551 &0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,
552 &0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
553 &0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,
554 &2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,
555 &3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,
556 &0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,
557 &0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,
558 &0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,
559 &0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,
560 &0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,
561 &0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
562 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
563 DATA (BRAT(I) ,I= 898,1063)/0.079D0,0.095D0,0.052D0,0.0078D0,
564 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
565 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
566 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
567 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
568 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
569 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
570 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
571 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
572 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
573 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
574 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
575 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
576 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
577 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
578 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
579 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
580 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
581 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
582 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
583 DATA (BRAT(I) ,I=1064,1254)/0.122D0,0.006D0,0.012D0,0.035D0,
584 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
585 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
586 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
587 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
588 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
589 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
590 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
591 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
592 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
593 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
594 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
595 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
596 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
597 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
598 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
599 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
600 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
601 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
602 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
603 DATA (BRAT(I) ,I=1255,1447)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
604 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
605 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
606 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
607 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
608 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
609 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
610 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
611 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
612 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
613 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
614 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
615 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
616 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
617 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
618 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
619 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
620 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
621 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
622 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
623 DATA (BRAT(I) ,I=1448,1648)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
624 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
625 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
626 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
627 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
628 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
629 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
630 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
631 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
632 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
633 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
634 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
635 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
636 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
637 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
638 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
639 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
640 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
641 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
642 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
643 DATA (BRAT(I) ,I=1649,4000)/0.008D0,0.024D0,0.425D0,0.02D0,
644 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,827*0D0,0.8516D0,
645 &0.00539D0,0.04483D0,0.09819D0,0.85053D0,0.02152D0,0.02989D0,
646 &0.09806D0,0.29439D0,0.10943D0,0.59618D0,0.38983D0,0.61017D0,
648 DATA (KFDP(I,1),I= 1, 375)/21,22,23,4*-24,25,21,22,23,4*24,25,
649 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
650 &4*24,25,37,1000022,1000023,1000025,1000035,21,22,23,4*-24,25,
651 &2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,22,23,-24,25,
652 &23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,-37,23,24,37,
653 &1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,
654 &11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,
655 &3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,2*1000023,
656 &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
657 &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003,
658 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
659 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
660 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
661 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
662 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
663 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
664 &24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,
665 &4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,1000022,2*1000023,
666 &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
667 &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/
668 DATA (KFDP(I,1),I= 376, 606)/1000003,-1000003,1000004,2000004,
669 &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
670 &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
671 &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
672 &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
673 &1000015,-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,
674 &8,11,13,15,17,21,2*22,23,24,23,1000022,2*1000023,3*1000025,
675 &4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,-1000001,
676 &1000002,2000002,1000002,-1000002,1000003,2000003,1000003,
677 &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
678 &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
679 &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
680 &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
681 &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
682 &1000016,-1000016,-1,-3,-5,-7,-11,-13,-15,-17,24,2*1000022,
683 &2*1000023,2*1000025,2*1000035,1000006,2000006,1000006,2000006,
684 &-1000001,-1000003,-1000011,-1000013,-1000015,-2000015,5,6,21,2,1,
685 &2,3,4,5,6,11,13,15,4,5,11,13,15,2*4,-11,-13,-15,2*24,2*52,1,2,3,
686 &4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,2*52,4*-1,4*-3,4*-5,4*-7,
687 &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/
688 DATA (KFDP(I,1),I= 607,1001)/-11,-13,2*2,-12,-14,-16,2*-2,2*-4,
689 &-2,-4,2*22,211,111,221,13,11,213,-213,221,223,321,130,310,111,
690 &331,111,211,-12,12,-14,14,211,111,22,-13,-11,2*211,213,113,221,
691 &223,321,211,331,22,111,211,2*22,211,22,111,211,22,211,221,111,11,
692 &211,111,2*211,321,130,310,221,111,211,111,130,310,321,2*311,321,
693 &311,323,313,323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,
694 &313,323,313,323,311,4*321,211,111,3*22,111,321,130,-213,113,213,
695 &211,22,111,11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,
696 &-313,-311,-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,
697 &2*113,2*223,2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,
698 &-321,211,2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,
699 &423,413,421,411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
700 &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
701 &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
702 &-321,3*-311,211,113,321,2*421,411,421,413,423,413,423,411,421,
703 &-15,5*-11,5*-13,221,331,333,221,331,333,10221,211,213,211,213,
704 &321,323,321,323,2212,221,331,333,221,2*2,2*431,421,411,423,413,
705 &82,11,13,82,443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,
706 &2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,
707 &511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443/
708 DATA (KFDP(I,1),I=1002,1428)/2*20443,2*2,2*4,2,4,521,511,521,513,
709 &523,513,523,511,521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,
710 &3*441,3*443,3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,
711 &2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,
712 &521,513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,
713 &2212,2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,
714 &3222,3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,
715 &3322,3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,
716 &7*-13,2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,
717 &2*3322,3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,
718 &2*3214,2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,
719 &2*2,3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,
720 &-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,
721 &-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,
722 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,
723 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,
724 &-14,-16,2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,
725 &-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
726 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
727 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12/
728 DATA (KFDP(I,1),I=1429,1710)/-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
729 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
730 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
731 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
732 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
733 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
734 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
735 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
736 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
737 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
738 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
739 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
740 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
741 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
742 &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
743 &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
744 &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
745 &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024,
746 &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003,
747 &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/
748 DATA (KFDP(I,1),I=1711,1900)/1000025,1000035,1000006,2000006,
749 &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023,
750 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
751 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
752 &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022,
753 &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039,
754 &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014,
755 &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023,
756 &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024,
757 &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016,
758 &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
759 &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001,
760 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
761 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
762 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
763 &6*1000022,6*1000023,6*1000025,6*1000035,1000024,-1000024,1000024,
764 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
765 &1000037,-1000037,10*1000039,16*1000022,1000024,-1000024,1000024,
766 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
767 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/
768 DATA (KFDP(I,1),I=1901,2095)/-1000037,1000037,-1000037,1000037,
769 &-1000037,1000037,-1000037,1000024,-1000024,1000037,-1000037,
770 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
771 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
772 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
773 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
774 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
775 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
776 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
777 &2*1000039,6*1000022,6*1000023,6*1000025,6*1000035,1000022,
778 &1000023,1000025,1000035,1000002,2000002,-1000001,-2000001,
779 &1000004,2000004,-1000003,-2000003,1000006,2000006,-1000005,
780 &-2000005,1000012,2000012,-1000011,-2000011,1000014,2000014,
781 &-1000013,-2000013,1000016,2000016,-1000015,-2000015,2*1000021,
782 &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
783 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
784 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
785 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
786 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
787 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/
788 DATA (KFDP(I,1),I=2096,2323)/2000003,-2000003,1000004,-1000004,
789 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
790 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
791 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
792 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
793 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
794 &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
795 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
796 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
797 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
798 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
799 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
800 &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
801 &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
802 &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
803 &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
804 &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
805 &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
806 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
807 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/
808 DATA (KFDP(I,1),I=2324,4000)/-1000003,-2000003,1000006,2000006,
809 &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014,
810 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
811 &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
812 &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021,
813 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
814 &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039,
815 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
816 &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037,
817 &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003,
818 &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022,
819 &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006,
820 &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
821 &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021,
822 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
823 &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024,
824 &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014,
825 &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022,
826 &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016,
827 &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/
828 DATA (KFDP(I,2),I= 1, 337)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
829 &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,4*1000006,3*7,
830 &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,
831 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
832 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
833 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
834 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
835 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
836 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
837 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
838 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
839 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
840 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
841 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
842 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
843 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
844 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
845 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
846 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
847 &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/
848 DATA (KFDP(I,2),I= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23,
849 &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
850 &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
851 &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
852 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
853 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
854 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
855 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
856 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
857 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
858 &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
859 &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
860 &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
861 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
862 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
863 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
864 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
865 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
866 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
867 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
868 DATA (KFDP(I,2),I= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5,
869 &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7,
870 &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2,
871 &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
872 &-13,-14,-15,-16,-17,-18,-82,12,14,-1,-3,11,13,15,1,4,3,4,1,3,22,
873 &11,-211,2*22,-13,-11,-211,211,111,211,-321,130,310,22,2*111,-211,
874 &11,-11,13,-13,-211,111,22,14,12,111,22,111,3*211,-311,22,211,22,
875 &111,-211,211,11,-211,13,22,-211,111,-211,22,111,-11,-211,111,
876 &2*-211,-321,130,310,221,111,-211,111,2*0,-211,111,22,-211,111,
877 &-211,111,-211,211,-213,113,223,221,14,111,211,111,-11,-13,211,
878 &111,22,211,111,211,111,2*211,213,113,223,221,22,-211,111,113,223,
879 &22,111,-321,310,211,111,2*-211,221,22,-11,-13,-211,-321,130,310,
880 &221,-211,111,11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,
881 &213,211,213,211,213,211,213,211,213,211,213,3*211,213,211,2*321,
882 &8*211,2*113,3*211,111,22,211,111,211,111,4*211,8*12,8*14,2*211,
883 &2*213,2*111,221,2*113,223,333,20213,211,2*321,323,2*311,313,-211,
884 &111,113,2*211,321,2*211,311,321,310,211,-211,4*211,321,4*211,113,
885 &2*211,-321,111,22,-211,111,-211,111,-211,211,-211,211,16,5*12,
886 &5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,
887 &2*-1,22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13/
888 DATA (KFDP(I,2),I= 941,1318)/2*-15,211,213,20213,211,213,20213,
889 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
890 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
891 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1,
892 &-4,-3,-4,-1,-3,22,211,111,211,111,4*211,6*-11,6*-13,2*-15,211,
893 &213,20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,
894 &221,331,333,-1,-4,-3,-4,-1,-3,22,-321,-311,-321,-311,-15,-3,-1,
895 &2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,
896 &2*14,2,1,22,411,421,411,421,21,-11,-13,-15,-1,-2,-3,-4,2*21,22,
897 &21,2*-211,111,22,111,211,22,211,-211,11,2*-211,111,-211,111,22,
898 &11,22,111,-211,211,111,211,22,211,111,211,-211,22,11,13,11,-211,
899 &2*111,2*22,111,211,-321,-211,111,11,2*-211,7*12,7*14,-321,-323,
900 &-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,223,
901 &111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,333,
902 &10221,111,221,331,113,223,211,213,211,213,321,323,321,323,321,
903 &323,311,313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,12,
904 &14,-1,-3,2*111,2*211,12,14,-1,-3,22,111,2*22,111,22,12,14,-1,-3,
905 &22,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,
906 &12,14,-1,-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,
907 &-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1/
908 DATA (KFDP(I,2),I=1319,1774)/3,2*111,2*211,11,13,15,1,4,3,4,1,3,
909 &11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,
910 &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,
911 &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,
912 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
913 &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
914 &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
915 &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,-211,111,
916 &-321,130,310,-211,111,211,-211,111,-213,113,-211,111,223,211,111,
917 &213,113,211,111,223,-211,111,-321,130,310,2*-211,-311,311,-321,
918 &321,211,111,211,111,-211,111,-211,111,311,2*321,311,22,2*-82,
919 &-211,111,-211,111,211,111,211,111,-321,-311,-321,-311,411,421,
920 &411,421,22,2*21,-211,2*211,111,-211,111,2*211,111,-211,211,111,
921 &211,-321,2*-311,-321,22,-211,111,211,111,-311,311,-321,321,211,
922 &111,-211,111,321,311,22,-82,-211,111,211,111,-321,-311,411,421,
923 &22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
924 &2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,2*1,4*2,2*24,2*37,2,
925 &3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37,4,5,2*6,4*5,2*-24,
926 &2*-37,5,6,2*5,4*6,2*24,2*37,6,4,11,2*12,4*11,2*-24,2*-37,12,2*11,
927 &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/
928 DATA (KFDP(I,2),I=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15,
929 &4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,
930 &-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,
931 &-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,35,36,22,23,25,35,36,22,23,
932 &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
933 &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
934 &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,
935 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
936 &-16,16,-16,16,1,3,5,2,4,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,
937 &-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,
938 &2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,22,
939 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
940 &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
941 &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
942 &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
943 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
944 &-16,16,-16,16,1,3,5,2,4,22,23,25,35,36,22,23,11,13,15,12,14,16,1,
945 &3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,
946 &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,
947 &-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37/
948 DATA (KFDP(I,2),I=2219,4000)/37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
949 &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
950 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
951 &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,-13,-15,-1,-3,24,
952 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
953 &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
954 &-3,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36,
955 &2*24,2*37,2,3,2*4,4*3,23,25,35,36,2*-24,2*-37,3,4,2*3,4*4,23,25,
956 &35,36,2*24,2*37,4,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,6,2*5,4*6,
957 &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13,
958 &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24,
959 &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/
960 DATA (KFDP(I,3),I= 1,1087)/79*0,14,6*0,2*16,2*0,6*111,310,130,
961 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
962 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
963 &470*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
964 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
965 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
966 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
967 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
968 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
969 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
970 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
971 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
972 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
973 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
974 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
975 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
976 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
977 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
978 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
979 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
980 DATA (KFDP(I,3),I=1088,2186)/511,513,511,513,1,2,13*0,2*21,11*0,
981 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
982 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
983 &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
984 &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
985 &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
986 &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,
987 &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,
988 &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,
989 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
990 &-211,111,13*0,2*21,-211,111,167*0,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,
991 &-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,6,-2,2,-4,
992 &4,-6,6,12*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
993 &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
994 &-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
995 &12,14,16,2,4,28*0,2,4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
996 &5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,
997 &16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,
998 &-4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,
999 &-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5/
1000 DATA (KFDP(I,3),I=2187,4000)/-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,
1001 &-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,
1002 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,4*0,12,14,16,2,4,0,12,14,
1003 &16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,1657*0/
1004 DATA (KFDP(I,4),I= 1,4000)/92*0,4*111,6*0,111,2*0,-211,0,-211,
1005 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1006 &6*111,310,2*130,470*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1007 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1008 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1009 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1010 &-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,
1011 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1012 &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,
1013 &162*81,31*0,-211,111,2450*0/
1014 DATA (KFDP(I,5),I= 1,4000)/94*0,2*111,17*0,111,7*0,2*111,0,
1015 &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1016 &3*111,-211,111,3127*0/
1018 C...PYDAT4, with particle names (character strings).
1019 DATA (CHAF(I,1),I= 1, 190)/'d','u','s','c','b','t','b''','t''',
1020 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1021 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1022 &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1023 &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1024 &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav',
1025 &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster',
1026 &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
1027 &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0',
1028 &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2',
1029 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''',
1030 &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+',
1031 &'D*_s+','D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0',
1032 &'B*_20','B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+',
1033 &'B*_c+','B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-',
1034 &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+',
1035 &'Delta+','Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0',
1036 &'su_0','su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-',
1037 &'Xi*-','Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0',
1038 &'Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1','Sigma_c+'/
1039 DATA (CHAF(I,1),I= 191, 317)/'Sigma*_c+','Sigma_c++',
1040 &'Sigma*_c++','Xi_c+','cs_0','cs_1','Xi''_c0','Xi*_c0','Xi''_c+',
1041 &'Xi*_c+','Omega_c0','Omega*_c0','cc_1','Xi_cc+','Xi*_cc+',
1042 &'Xi_cc++','Xi*_cc++','Omega_cc+','Omega*_cc+','Omega*_ccc++',
1043 &'bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0','Xi_b-',
1044 &'Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1045 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1046 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1047 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1048 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1049 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1050 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1051 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1052 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1053 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1054 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1055 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1056 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1057 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1058 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+'/
1059 DATA (CHAF(I,1),I= 318, 500)/'~chi_30','~chi_40','~chi_2+',
1060 &'~gravitino','~d_R','~u_R','~s_R','~c_R','~b_2','~t_2','~e_R-',
1061 &'~nu_eR','~mu_R-','~nu_muR','~tau_2-','~nu_tauR','d*','u*','e*-',
1063 DATA (CHAF(I,2),I= 1, 206)/'dbar','ubar','sbar','cbar','bbar',
1064 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1065 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1066 &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1067 &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar',
1068 &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0',
1069 &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0',
1070 &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0',
1071 &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0',
1072 &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+',
1073 &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar',
1074 &'p_diffrbar-','pbar-','Deltabar-','Deltabar--','sd_0bar',
1075 &'sd_1bar','Sigmabar+','Sigma*bar+','Lambdabar0','su_0bar',
1076 &'su_1bar','Sigmabar0','Sigma*bar0','Sigmabar-','Sigma*bar-',
1077 &'ss_1bar','Xibar+','Xi*bar+','Xibar0','Xi*bar0','Omegabar+',
1078 &'cd_0bar','cd_1bar','Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-',
1079 &'Xi_cbar0','cu_0bar','cu_1bar','Sigma_cbar-','Sigma*_cbar-',
1080 &'Sigma_cbar--','Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar',
1081 &'Xi''_cbar0','Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1082 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--'/
1083 DATA (CHAF(I,2),I= 207, 324)/'Xi*_ccbar--','Omega_ccbar-',
1084 &'Omega*_ccbar-','Omega*_cccbar-','bd_0bar','bd_1bar',
1085 &'Sigma_bbar+','Sigma*_bbar+','Lambda_bbar0','Xi_bbar+',
1086 &'Xi_bcbar0','bu_0bar','bu_1bar','Sigma_bbar0','Sigma*_bbar0',
1087 &'Sigma_bbar-','Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar',
1088 &'bs_1bar','Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0',
1089 &'Omega_bbar+','Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar',
1090 &'Xi''_bcbar0','Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-',
1091 &'Omega''_bcba','Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-',
1092 &'bb_1bar','Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0',
1093 &'Omega_bbbar+','Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1094 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1095 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1096 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1097 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1098 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1099 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1100 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1101 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1102 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar'/
1103 DATA (CHAF(I,2),I= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar',
1104 &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1105 &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1107 C...PYDATR, with initial values for the random number generator.
1108 DATA MRPY/19780503,0,0,97,33,0/
1110 C...Default values for allowed processes and kinematics constraints.
1113 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1114 &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,
1117 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1118 & 1.0D0, -10D0, 10D0, -10D0, 10D0,
1119 1 -10D0, 10D0, -10D0, 10D0, -10D0,
1120 1 10D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1121 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1122 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1123 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1124 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1125 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1126 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1127 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1128 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1131 C...Default values for main switches and parameters. Reset information.
1132 DATA (MSTP(I),I=1,100)/
1133 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1134 1 1, 0, 1, 0, 5, 0, 0, 0, 0, 0,
1135 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1136 3 1, 2, 0, 1, 0, 2, 1, 5, 2, 0,
1137 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1138 5 4, 1, 3, 1, 5, 1, 1, 6, 1, 7,
1139 6 1, 3, 2, 2, 1, 1, 2, 0, 0, 0,
1140 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1141 8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
1142 9 1, 4, 1, 2, 0, 0, 0, 0, 0, 0/
1143 DATA (MSTP(I),I=101,200)/
1144 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1145 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1146 2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
1147 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1148 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1149 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1150 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1151 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1152 8 6, 115, 1998, 01, 27, 0, 0, 0, 0, 0,
1153 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1154 DATA (PARP(I),I=1,100)/
1155 & 0.25D0, 10D0, 8*0D0,
1156 1 0D0, 0D0, 1.0D0, 0.01D0, 0.6D0, 1.0D0, 1.0D0, 3*0D0,
1158 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1159 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
1161 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1162 7 4.0D0, 0.25D0, 8*0D0,
1163 8 1.40D0,1.55D0,0.5D0, 0.2D0,0.33D0,0.66D0, 0.7D0, 0.5D0,2*0D0,
1164 9 0.44D0,0.20D0,2.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,0.44D0,2.0D0/
1165 DATA (PARP(I),I=101,200)/
1166 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 6*0D0,
1167 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1168 2 1.0D0, 0.4D0, 8*0D0,
1170 4 0.33333D0, 82D0, 1D0, 4D0, 200D0, 5*0D0,
1171 5 0D0, 0D0, 0D0, 0D0, 6*0D0,
1172 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 6*0D0,
1173 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1180 C...Constants for the generation of the various processes.
1181 DATA (ISET(I),I=1,100)/
1182 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1183 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1184 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1185 3 2, -1, 2, 2, 2, 2, -1, -1, -1, -1,
1186 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1187 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1188 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1189 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1190 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1191 9 0, 0, 0, 0, 0, 9, -2, -2, -2, -2/
1192 DATA (ISET(I),I=101,200)/
1193 & -1, 1, 1, -2, -2, 2, 2, 2, -2, 2,
1194 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1195 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1196 3 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1197 4 1, 1, 1, 1, 1, -2, 1, 1, 1, -2,
1198 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1199 6 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1200 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1201 8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
1202 9 1, 1, 1, 2, -2, -2, -2, -2, -2, -2/
1203 DATA (ISET(I),I=201,300)/
1204 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1205 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1206 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1207 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1208 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1209 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1210 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1211 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1212 8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1213 9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
1214 DATA (ISET(I),I=301,500)/200*-2/
1215 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1216 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1217 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1218 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1219 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1220 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1221 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1222 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1223 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1224 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1225 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1226 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1227 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1228 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1229 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1230 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1231 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1232 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1233 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1234 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1235 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1236 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1237 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1238 & 23, 0, 25, 0, 25, 0, 0, 0, 0, 0,
1239 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1240 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1241 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1242 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1243 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1244 3 23, 5, 0, 0, 0, 0, 0, 0, 0, 0,
1245 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1246 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
1247 4 0, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
1248 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1249 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1250 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1251 6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
1252 6 11, 0, 0, 4000001, 0, 4000002, 0, 0, 0, 0,
1253 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1254 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1255 8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
1256 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
1257 9 54, 0, 55, 0, 56, 0, 11, 0, 0, 0,
1258 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1259 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1260 & 1000011, 1000011, 2000011, 2000011, 1000011,
1261 & 2000011, 1000013, 1000013, 2000013, 2000013,
1262 & 1000013, 2000013, 1000015, 1000015, 2000015,
1263 & 2000015, 1000015, 2000015, 1000011, 1000012,
1264 1 1000015, 1000016, 2000015, 1000016, 1000012,
1265 1 1000012, 1000016, 1000016, 0, 0,
1266 1 1000022, 1000022, 1000023, 1000023, 1000025,
1267 1 1000025, 1000035, 1000035, 1000022, 1000023,
1268 2 1000022, 1000025, 1000022, 1000035, 1000023,
1269 2 1000025, 1000023, 1000035, 1000025, 1000035,
1270 2 1000024, 1000024, 1000037, 1000037, 1000024,
1271 2 1000037, 1000022, 1000024, 1000023, 1000024,
1272 3 1000025, 1000024, 1000035, 1000024, 1000022,
1273 3 1000037, 1000023, 1000037, 1000025, 1000037,
1274 3 1000035, 1000037, 1000021, 1000022, 1000021,
1275 3 1000023, 1000021, 1000025, 1000021, 1000035/
1276 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1277 4 1000021, 1000024, 1000021, 1000037, 1000021,
1278 4 1000021, 1000021, 1000021, 0, 0,
1279 4 1000002, 1000022, 2000002, 1000022, 1000002,
1280 4 1000023, 2000002, 1000023, 1000002, 1000025,
1281 5 2000002, 1000025, 1000002, 1000035, 2000002,
1282 5 1000035, 1000001, 1000024, 2000005, 1000024,
1283 5 1000001, 1000037, 2000005, 1000037, 1000002,
1284 5 1000021, 2000002, 1000021, 0, 0,
1285 6 1000006, 1000006, 2000006, 2000006, 1000006,
1286 6 2000006, 1000006, 1000006, 2000006, 2000006,
1289 7 1000002, 1000002, 2000002, 2000002, 1000002,
1290 7 2000002, 1000002, 1000002, 2000002, 2000002,
1291 7 1000002, 2000002, 1000002, 1000002, 2000002,
1292 7 2000002, 1000002, 1000002, 2000002, 2000002/
1293 DATA ((KFPR(I,J),J=1,2),I=281,500)/440*0/
1294 DATA COEF/10000*0D0/
1295 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1296 &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,
1297 &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,
1298 &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,
1299 &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,
1300 &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,
1301 &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,
1302 &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,
1303 &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,
1304 &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,
1305 &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/
1307 C...Treatment of resonances.
1308 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1309 &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1311 C...Character constants: name of processes.
1312 DATA PROC(0)/ 'All included subprocesses '/
1313 DATA (PROC(I),I=1,20)/
1314 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1315 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1316 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1317 &' ', 'W+ + W- -> h0 ',
1318 &' ', 'f + f'' -> f + f'' (QFD) ',
1319 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1320 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1321 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1322 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1323 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1324 DATA (PROC(I),I=21,40)/
1325 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1326 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1327 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1328 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1329 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1330 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1331 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1332 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1333 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1334 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1335 DATA (PROC(I),I=41,60)/
1336 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1337 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1338 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1339 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1340 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1341 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1342 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1343 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1344 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1345 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1346 DATA (PROC(I),I=61,80)/
1347 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1348 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1349 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1350 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1351 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1352 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1353 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1354 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1355 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1356 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1357 DATA (PROC(I),I=81,100)/
1358 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1359 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1360 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1361 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1362 8'g + g -> chi_2c + g ', ' ',
1363 9'Elastic scattering ', 'Single diffractive (XB) ',
1364 9'Single diffractive (AX) ', 'Double diffractive ',
1365 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1368 DATA (PROC(I),I=101,120)/
1369 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1370 &'gamma + gamma -> h0 ', ' ',
1371 &' ', 'g + g -> J/Psi + gamma ',
1372 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1373 &' ', 'f + fbar -> gamma + h0 ',
1374 1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
1375 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1376 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1377 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1379 DATA (PROC(I),I=121,140)/
1380 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1381 2'f + f'' -> f + f'' + h0 ',
1382 2'f + f'' -> f" + f"'' + h0 ',
1386 3'g + g -> Z0 + q + qbar ', ' ',
1391 DATA (PROC(I),I=141,160)/
1392 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1393 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1394 4'q + l -> LQ ', ' ',
1395 4'd + g -> d* ', 'u + g -> u* ',
1396 4'g + g -> eta_techni ', ' ',
1397 5'f + fbar -> H0 ', 'g + g -> H0 ',
1398 5'gamma + gamma -> H0 ', ' ',
1399 5' ', 'f + fbar -> A0 ',
1400 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1402 DATA (PROC(I),I=161,180)/
1403 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1404 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1405 6'f + fbar -> f'' + fbar'' (g/Z)',
1406 6'f +fbar'' -> f" + fbar"'' (W) ',
1407 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1409 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1410 7'f + f'' -> f + f'' + H0 ',
1411 7'f + f'' -> f" + f"'' + H0 ',
1412 7' ', 'f + fbar -> Z0 + A0 ',
1413 7'f + fbar'' -> W+/- + A0 ',
1414 7'f + f'' -> f + f'' + A0 ',
1415 7'f + f'' -> f" + f"'' + A0 ',
1417 DATA (PROC(I),I=181,200)/
1418 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1420 8' ', 'g + g -> Q + Qbar + A0 ',
1421 8'q + qbar -> Q + Qbar + A0 ', ' ',
1423 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
1424 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (technic)',
1428 DATA (PROC(I),I=201,220)/
1429 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1430 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1431 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1432 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1433 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1434 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1435 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1436 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1437 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1438 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1439 DATA (PROC(I),I=221,240)/
1440 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1441 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1442 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1443 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1444 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1445 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1446 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1447 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1448 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1449 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1450 DATA (PROC(I),I=241,260)/
1451 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1452 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1453 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1454 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1455 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1456 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1457 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1458 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1459 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1460 5'qj + g -> ~qj_R + ~g ', ' '/
1461 DATA (PROC(I),I=261,280)/
1462 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1463 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1464 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1467 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1468 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1469 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1470 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1471 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar '/
1472 DATA (PROC(I),I=281,500)/220*' '/
1474 C...Cross sections and slope offsets.
1477 C...Supersymmetry switches and parameters.
1479 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1482 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1483 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1484 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,24D17,2*0D0,
1487 C...Data for histogramming routines.
1488 DATA IHIST/1000,20000,55,1/
1493 C*********************************************************************
1496 C...A simple program (disguised as subroutine) to run at installation
1497 C...as a check that the program works as intended.
1499 SUBROUTINE PYTEST(MTEST)
1501 C...Double precision and integer declarations.
1502 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1503 INTEGER PYK,PYCHGE,PYCOMP
1505 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1506 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1507 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1508 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
1509 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1510 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1511 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1513 DIMENSION PSUM(5),PINI(6),PFIN(6)
1515 C...Save defaults for values that are changed.
1532 C...First part: loop over simple events to be generated.
1533 IF(MTEST.GE.1) CALL PYTABU(20)
1537 C...Reset parameter values. Switch on some nonstandard features.
1552 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1554 C...Ten events each for some single jets configurations.
1558 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1559 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1560 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1561 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1562 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1563 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1565 C...Ten events each for some simple jet systems; string fragmentation.
1566 ELSEIF(IEV.LE.130) THEN
1568 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1569 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1570 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1571 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1572 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1573 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1574 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1575 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1576 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1578 C...Seventy events with independent fragmentation and momentum cons.
1579 ELSEIF(IEV.LE.200) THEN
1581 MSTJ(2)=1+MOD(IEV-131,4)
1582 MSTJ(3)=1+MOD((IEV-131)/4,4)
1583 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1584 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1585 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1586 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1587 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1588 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1590 C...A hundred events with random jets (check invariant mass).
1591 ELSEIF(IEV.LE.300) THEN
1598 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1599 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1600 EJET=5D0+20D0*PYR(0)
1601 THETA=ACOS(2D0*PYR(0)-1D0)
1603 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1604 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1605 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1606 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1608 PSUM(J)=PSUM(J)+P(I,J)
1611 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
1612 & (PSUM(5)+PARJ(32))**2) GOTO 100
1614 C...Fifty e+e- continuum events with matrix elements.
1615 ELSEIF(IEV.LE.350) THEN
1619 C...Fifty e+e- continuum event with varying shower options.
1620 ELSEIF(IEV.LE.400) THEN
1621 MSTJ(42)=1+MOD(IEV,2)
1622 MSTJ(43)=1+MOD(IEV/2,4)
1623 MSTJ(44)=MOD(IEV/8,3)
1626 C...Fifty e+e- continuum events with coherent shower.
1627 ELSEIF(IEV.LE.450) THEN
1628 CALL PYEEVT(0,500D0)
1630 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1632 CALL PYONIA(5,9.46D0)
1635 C...Generate event. Find total momentum, energy and charge.
1646 C...Check conservation of energy, momentum and charge;
1647 C...usually exact, but only approximate for single jets.
1650 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4D0)
1652 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
1653 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
1654 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
1657 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
1659 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
1661 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1662 & (PFIN(J),J=1,4),PFIN(6)
1664 C...Check that all KF codes are known ones, and that partons/particles
1665 C...satisfy energy-momentum-mass relation. Store particle statistics.
1667 IF(K(I,1).GT.20) GOTO 170
1668 IF(PYCOMP(K(I,2)).EQ.0) THEN
1669 WRITE(MSTU(11),5100) I
1672 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
1673 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
1675 WRITE(MSTU(11),5200) I
1679 IF(MTEST.GE.1) CALL PYTABU(21)
1681 C...List all erroneous events and some normal ones.
1682 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
1683 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1685 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
1689 C...Stop execution if too many errors.
1690 IF(MERR.NE.0) NERR=NERR+1
1692 WRITE(MSTU(11),6300)
1698 C...Summarize result of run.
1699 IF(MTEST.GE.1) CALL PYTABU(22)
1701 C...Reset commonblock variables changed during run.
1718 C...Second part: complete events of various kinds.
1719 C...Common initial values. Loop over initiating conditions.
1720 MSTP(122)=MAX(0,MIN(2,MTEST))
1721 MDCY(PYCOMP(111),1)=0
1724 C...Reset process type, kinematics cuts, and the flags used.
1741 C...Prompt photon production at fixed target.
1744 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
1748 CALL PYINIT('FIXT','pi+','p',PZSUM)
1750 C...QCD processes at ISR energies.
1751 ELSEIF(IPROC.EQ.2) THEN
1757 CALL PYINIT('CMS','p','p',PESUM)
1759 C...W production + multiple interactions at CERN Collider.
1760 ELSEIF(IPROC.EQ.3) THEN
1769 CALL PYINIT('CMS','p','pbar',PESUM)
1771 C...W/Z gauge boson pairs + pileup events at the Tevatron.
1772 ELSEIF(IPROC.EQ.4) THEN
1784 CALL PYINIT('CMS','p','pbar',PESUM)
1786 C...Higgs production at LHC.
1787 ELSEIF(IPROC.EQ.5) THEN
1799 CALL PYINIT('CMS','p','p',PESUM)
1801 C...Z' production at SSC.
1802 ELSEIF(IPROC.EQ.6) THEN
1811 CALL PYINIT('CMS','p','p',PESUM)
1813 C...W pair production at 1 TeV e+e- collider.
1814 ELSEIF(IPROC.EQ.7) THEN
1821 CALL PYINIT('CMS','e+','e-',PESUM)
1823 C...Deep inelastic scattering at a LEP+LHC ep collider.
1824 ELSEIF(IPROC.EQ.8) THEN
1837 CALL PYINIT('USER','p','e-',PESUM)
1840 C...Generate 20 events of each required type.
1844 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
1846 C...Check conservation of energy/momentum/flavour.
1857 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
1858 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
1859 DEVQ=ABS(PFIN(6)-PINI(6))
1860 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
1861 & DEVQ.GT.0.1D0) MERR=1
1862 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1863 & (PFIN(J),J=1,4),PFIN(6)
1865 C...Check that all KF codes are known ones, and that partons/particles
1866 C...satisfy energy-momentum-mass relation.
1868 IF(K(I,1).GT.20) GOTO 210
1869 IF(PYCOMP(K(I,2)).EQ.0) THEN
1870 WRITE(MSTU(11),5100) I
1873 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
1875 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
1876 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
1877 WRITE(MSTU(11),5200) I
1882 C...Listing of erroneous events, and first event of each type.
1883 IF(MERR.GE.1) NERR=NERR+1
1885 WRITE(MSTU(11),6300)
1889 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
1890 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1895 C...List statistics for each process type.
1896 IF(MTEST.GE.1) CALL PYSTAT(1)
1899 C...Summarize result of run.
1900 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
1901 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
1903 C...Format statements for output.
1904 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
1905 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
1906 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
1907 &4(1X,F12.5),1X,F8.2)
1908 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
1909 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
1911 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
1912 &'wrong.'/5X,'Execution will be stopped after listing of event.')
1913 6400 FORMAT(5X,'Faulty event follows:')
1914 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
1915 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
1916 &5X,'This should not have happened!')
1921 C*********************************************************************
1924 C...Converts PYTHIA event record contents to or from
1925 C...the standard event record commonblock.
1927 SUBROUTINE PYHEPC(MCONV)
1929 C...Double precision and integer declarations.
1930 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1931 INTEGER PYK,PYCHGE,PYCOMP
1933 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1934 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1935 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1936 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
1937 C...HEPEVT commonblock.
1938 PARAMETER (NMXHEP=4000)
1939 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
1940 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
1941 DOUBLE PRECISION PHEP,VHEP
1944 C...Conversion from PYTHIA to standard, the easy part.
1947 IF(N.GT.NMXHEP) CALL PYERRM(8,
1948 & '(PYHEPC:) no more space in /HEPEVT/')
1952 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
1953 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
1954 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
1955 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
1959 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
1973 C...Check if new event (from pileup).
1977 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
1980 C...Fill in missing mother information.
1981 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
1983 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
1987 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
1990 IF(I1.GE.I) CALL PYERRM(8,
1991 & '(PYHEPC:) translation of inconsistent event history')
1992 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
1994 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
1995 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
1997 ELSEIF(K(I,2).EQ.94) THEN
1999 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2000 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2001 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2002 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2003 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2006 C...Fill in missing daughter information.
2007 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2008 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2009 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2013 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2015 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2016 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2017 IF(JDAHEP(1,I1).EQ.0) THEN
2024 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2025 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2028 C...Conversion from standard to PYTHIA, the easy part.
2030 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2031 & '(PYHEPC:) no more space in /PYJETS/')
2037 IF(ISTHEP(I).EQ.1) K(I,1)=1
2038 IF(ISTHEP(I).EQ.2) K(I,1)=11
2039 IF(ISTHEP(I).EQ.3) K(I,1)=21
2051 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2053 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2054 & PHEP(5,I)/PHEP(4,I)
2057 C...Fill in missing information on colour connection in jet systems.
2058 IF(ISTHEP(I).EQ.1) THEN
2061 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2062 IF(KQ.NE.0) NKQ=NKQ+1
2063 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2064 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2066 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2067 IF(K(I+1,2).EQ.21) K(I,1)=2
2071 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2072 & '(PYHEPC:) input parton configuration not colour singlet')
2077 C*********************************************************************
2080 C...Initializes the generation procedure; finds maxima of the
2081 C...differential cross-sections to be used for weighting.
2083 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2085 C...Double precision and integer declarations.
2086 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2087 INTEGER PYK,PYCHGE,PYCOMP
2089 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2090 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2091 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2092 COMMON/PYDAT4/CHAF(500,2)
2094 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2095 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2096 COMMON/PYINT1/MINT(400),VINT(400)
2097 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2098 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2099 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2100 &/PYINT1/,/PYINT2/,/PYINT5/
2101 C...Local arrays and character variables.
2102 DIMENSION ALAMIN(20),NFIN(20)
2103 CHARACTER*(*) FRAME,BEAM,TARGET
2104 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHLH(2)*6
2106 C...Interface to PDFLIB.
2107 COMMON/W50512/QCDL4,QCDL5
2109 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2110 CHARACTER*20 PARM(20)
2111 DATA VALUE/20*0D0/,PARM/20*' '/
2113 C...Data:Lambda and n_f values for parton distributions; months.
2114 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2115 &14*0.2D0/,NFIN/20*4/
2116 DATA CHLH/'lepton','hadron'/
2118 C...Reset MINT and VINT arrays. Write headers.
2123 IF(MSTU(12).GE.1) CALL PYLIST(0)
2124 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2126 C...Maximum 4 generations; set maximum number of allowed flavours.
2127 MSTP(1)=MIN(4,MSTP(1))
2128 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2129 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2131 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2135 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2138 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2139 IPM=(5-ISIGN(1,I))/2
2141 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2142 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2144 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2149 C...Initialize parton distributions: PDFLIB.
2150 IF(MSTP(52).EQ.2) THEN
2154 VALUE(2)=MSTP(51)/1000
2156 VALUE(3)=MOD(MSTP(51),1000)
2159 CALL PDFSET(PARM,VALUE)
2160 MINT(93)=1000000+MSTP(51)
2163 C...Choose Lambda value to use in alpha-strong.
2165 IF(MSTP(3).GE.2) THEN
2168 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.10) THEN
2169 ALAM=ALAMIN(MSTP(51))
2171 ELSEIF(MSTP(52).EQ.2) THEN
2180 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2183 C...Initialize the SUSY generation: couplings, masses,
2184 C...decay modes, branching ratios, and so on.
2187 C...Initialize widths and partial widths for resonances.
2189 C...Set Z0 mass and width for e+e- routines.
2190 PARJ(123)=PMAS(23,1)
2191 PARJ(124)=PMAS(23,2)
2193 C...Identify beam and target particles and frame of process.
2197 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2198 IF(MINT(65).EQ.1) GOTO 170
2200 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2201 C...For e-gamma allow 2 alternatives.
2204 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2205 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2206 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2207 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2208 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2209 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2212 C...Set up kinematics of process.
2215 C...Precalculate flavour selection weights
2218 C...Loop over gamma-p or gamma-gamma alternatives.
2219 DO 160 IGA=1,MINT(121)
2222 C...Select partonic subprocesses to be included in the simulation.
2225 C...Count number of subprocesses on.
2228 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2229 & MSUB(ISUB).EQ.1) THEN
2230 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2232 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2233 WRITE(MSTU(11),5300) ISUB
2235 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2236 WRITE(MSTU(11),5400) ISUB
2238 ELSEIF(MSUB(ISUB).EQ.1) THEN
2242 IF(MINT(48).EQ.0) THEN
2243 WRITE(MSTU(11),5500)
2246 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2248 C...Reset variables for cross-section calculation.
2256 C...Find parametrized total cross-sections.
2259 C...Maxima of differential cross-sections.
2260 IF(MSTP(121).LE.1) CALL PYMAXI
2262 C...Initialize possibility of pileup events.
2263 IF(MINT(121).GT.1) MSTP(131)=0
2264 IF(MSTP(131).NE.0) CALL PYPILE(1)
2266 C...Initialize multiple interactions with variable impact parameter.
2267 IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2268 & MSTP(82).GE.2) CALL PYMULT(1)
2270 C...Save results for gamma-p and gamma-gamma alternatives.
2271 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2274 C...Initialization finished.
2275 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2277 C...Formats for initialization information.
2278 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2279 &'routines',1X,17('*'))
2280 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2281 &'-',A6,' interactions.'/1X,'Execution stopped!')
2282 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2283 &1X,'Execution stopped!')
2284 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2285 &1X,'Execution stopped!')
2286 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2287 &1X,'Execution stopped.')
2288 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2294 C*********************************************************************
2297 C...Administers the generation of a high-pT event via calls to
2298 C...a number of subroutines.
2302 C...Double precision and integer declarations.
2303 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2304 INTEGER PYK,PYCHGE,PYCOMP
2306 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2307 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2308 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2309 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2310 COMMON/PYINT1/MINT(400),VINT(400)
2311 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2312 COMMON/PYINT4/MWID(500),WIDS(500,5)
2313 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2314 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
2315 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,
2316 &/PYINT4/,/PYINT5/,/PYUPPR/
2320 C...Initial values for some counters.
2331 C...If variable energies: redo incoming kinematics and cross-section.
2333 IF(MSTP(171).EQ.1) THEN
2335 IF(MSTI(61).EQ.1) THEN
2339 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2343 C...Loop over number of pileup events; check space left.
2344 IF(MSTP(131).LE.0) THEN
2350 DO 260 IPILE=1,NPILE
2351 IF(MINT(84)+100.GE.MSTU(4)) THEN
2353 & '(PYEVNT:) no more space in PYJETS for pileup events')
2354 IF(MSTU(21).GE.1) GOTO 270
2358 C...Generate variables of hard scattering.
2362 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2367 IF(MSTI(61).EQ.1) THEN
2371 IF(MINT(51).EQ.2) RETURN
2373 IF(MSTP(111).EQ.-1) GOTO 250
2375 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
2376 C...Hard scattering (including low-pT):
2377 C...reconstruct kinematics and colour flow of hard scattering.
2380 IF(MINT(51).EQ.1) GOTO 100
2383 IF(ISUB.EQ.95) GOTO 130
2385 C...Showering of initial state partons (optional).
2388 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2390 IF(MINT(51).EQ.1) GOTO 100
2392 C...Showering of final state partons (optional).
2395 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2399 IF(ISET(ISUB).EQ.5) IPU4=-3
2401 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2402 CALL PYSHOW(IPU3,IPU4,QMAX)
2403 ELSEIF(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN
2405 IPU3=IFUP(IUP,1)+MINT(84)
2406 IPU4=IFUP(IUP,2)+MINT(84)
2407 QMAX=SQRT(MAX(0D0,Q2UP(IUP)))
2408 CALL PYSHOW(IPU3,IPU4,QMAX)
2413 C...Decay of final state resonances.
2415 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2416 IF(MINT(51).EQ.1) GOTO 100
2419 C...Multiple interactions.
2420 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2423 C...Hadron remnants and primordial kT.
2424 130 CALL PYREMN(IPU1,IPU2)
2425 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2426 IF(MINT(51).EQ.1) GOTO 100
2429 C...Diffractive and elastic scattering.
2433 C...Check that no odd resonance left undecayed.
2434 IF(MSTP(111).GE.1) THEN
2436 DO 140 I=MINT(84)+1,NFIX
2437 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2438 & K(I,2).NE.22) THEN
2439 IF(MWID(PYCOMP(K(I,2))).NE.0) THEN
2441 IF(MINT(51).EQ.1) GOTO 100
2447 C...Recalculate energies from momenta and masses (if desired).
2448 IF(MSTP(113).GE.1) THEN
2449 DO 150 I=MINT(83)+1,N
2450 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2451 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2456 C...Rearrange partons along strings, check invariant mass cuts.
2458 IF(MSTP(111).LE.0) MSTJ(14)=-1
2459 CALL PYPREP(MINT(84)+1)
2461 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2462 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2463 DO 180 I=MINT(84)+1,N
2464 IF(K(I,2).EQ.94) THEN
2465 DO 170 I1=I+1,MIN(N,I+3)
2466 IF(K(I1,3).EQ.I) THEN
2467 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2468 IF(K(I1,3).EQ.0) THEN
2469 DO 160 II=MINT(84)+1,I-1
2470 IF(K(II,2).EQ.K(I1,2)) THEN
2471 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2472 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2475 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2483 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2484 IF(MSTP(125).EQ.0) MINT(4)=0
2485 DO 200 I=MINT(83)+1,N
2486 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2488 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2489 IF(K(I1,3).EQ.I) K(I,5)=I1
2495 C...Introduce separators between sections in PYLIST event listing.
2496 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2499 ELSEIF(IPILE.EQ.1) THEN
2506 C...Go back to lab frame (needed for vertices, also in fragmentation).
2509 C...Set nonvanishing production vertex (optional).
2510 IF(MSTP(151).EQ.1) THEN
2512 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2513 & SIN(PARU(2)*PYR(0))
2515 DO 230 I=MINT(83)+1,N
2517 V(I,J)=V(I,J)+VTX(J)
2522 C...Perform hadronization (if desired).
2523 IF(MSTP(111).GE.1) THEN
2525 IF(MSTU(24).NE.0) GOTO 100
2527 IF(MSTP(113).GE.1) THEN
2529 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
2530 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2533 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
2535 C...Store event information and calculate Monte Carlo estimates of
2536 C...subprocess cross-sections.
2537 250 IF(IPILE.EQ.1) CALL PYDOCU
2539 C...Set counters for current pileup event and loop to next one.
2541 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
2542 IF(MSTU70.LT.10) THEN
2547 MINT(84)=N+MSTP(126)
2548 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
2551 C...Generic information on pileup events. Reconstruct missing history.
2552 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
2556 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
2560 C...Transform to the desired coordinate frame.
2561 270 CALL PYFRAM(MSTP(124))
2568 C***********************************************************************
2571 C...Prints out information about cross-sections, decay widths, branching
2572 C...ratios, kinematical limits, status codes and parameter values.
2574 SUBROUTINE PYSTAT(MSTAT)
2576 C...Double precision and integer declarations.
2577 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2578 INTEGER PYK,PYCHGE,PYCOMP
2579 C...Parameter statement to help give large particle numbers.
2580 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2583 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2584 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2585 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2586 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2587 COMMON/PYINT1/MINT(400),VINT(400)
2588 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2589 COMMON/PYINT4/MWID(500),WIDS(500,5)
2590 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2591 COMMON/PYINT6/PROC(0:500)
2593 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2594 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
2595 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/
2596 C...Local arrays, character variables and data.
2597 DIMENSION WDTP(0:200),WDTE(0:200,0:5)
2598 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
2599 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28
2601 &'VMD/hadron * VMD ','VMD/hadron * direct ',
2602 &'VMD/hadron * anomalous ','direct * direct ',
2603 &'direct * anomalous ','anomalous * anomalous '/
2604 DATA DISGA/'e * VMD','e * anomalous'/
2605 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
2606 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2607 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
2608 &' y*_small ',' eta*_large ',' eta*_small ',
2609 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
2610 &' x_2 ',' x_F ',' cos(theta_hard) ',
2611 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
2612 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
2617 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
2618 WRITE(MSTU(11),5000)
2619 WRITE(MSTU(11),5100)
2620 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
2622 IF(MSUB(I).NE.1) GOTO 100
2623 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
2625 IF(MINT(121).GT.1) THEN
2626 WRITE(MSTU(11),5300)
2627 DO 110 IGA=1,MINT(121)
2629 IF(MINT(121).EQ.2) THEN
2630 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
2633 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
2639 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
2640 & MAX(1D0,DBLE(NGEN(0,2)))
2642 C...Decay widths and branching ratios.
2643 ELSEIF(MSTAT.EQ.2) THEN
2644 WRITE(MSTU(11),5500)
2645 WRITE(MSTU(11),5600)
2648 CALL PYNAME(KF,CHKF)
2651 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
2652 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
2653 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
2654 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
2655 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
2657 IF(MWID(KC).LE.0) GOTO 140
2658 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
2659 & KF/KSUSY1.EQ.2)) GOTO 140
2661 C...Off-shell branchings.
2664 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
2665 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
2666 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
2667 DO 120 J=1,MDCY(KC,3)
2670 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2671 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2673 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2674 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2675 CALL PYNAME(KFDP(IDC,1),CHD1)
2676 CALL PYNAME(KFDP(IDC,2),CHD2)
2677 IF(KFDP(IDC,3).EQ.0) THEN
2678 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2679 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2680 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2682 CALL PYNAME(KFDP(IDC,3),CHD3)
2683 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2684 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2685 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2688 C...On-shell decays.
2690 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
2692 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
2693 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
2694 & STATE(MDCY(KC,1)),BRFIN
2695 DO 130 J=1,MDCY(KC,3)
2698 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2699 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2701 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2702 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2704 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
2705 CALL PYNAME(KFDP(IDC,1),CHD1)
2706 CALL PYNAME(KFDP(IDC,2),CHD2)
2707 IF(KFDP(IDC,3).EQ.0) THEN
2708 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2709 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2710 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
2711 & STATE(MDME(IDC,1)),BRFIN
2713 CALL PYNAME(KFDP(IDC,3),CHD3)
2714 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2715 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2716 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
2717 & STATE(MDME(IDC,1)),BRFIN
2722 WRITE(MSTU(11),6000)
2724 C...Allowed incoming partons/particles at hard interaction.
2725 ELSEIF(MSTAT.EQ.3) THEN
2726 WRITE(MSTU(11),6100)
2727 CALL PYNAME(MINT(11),CHAU)
2729 CALL PYNAME(MINT(12),CHAU)
2731 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
2735 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
2736 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
2738 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
2741 WRITE(MSTU(11),6400)
2743 C...User-defined limits on kinematical variables.
2744 ELSEIF(MSTAT.EQ.4) THEN
2745 WRITE(MSTU(11),6500)
2746 WRITE(MSTU(11),6600)
2748 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
2749 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
2750 PTHMIN=MAX(CKIN(3),CKIN(5))
2752 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
2753 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
2754 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
2756 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
2759 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
2760 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
2761 WRITE(MSTU(11),7000)
2763 C...Status codes and parameter values.
2764 ELSEIF(MSTAT.EQ.5) THEN
2765 WRITE(MSTU(11),7100)
2766 WRITE(MSTU(11),7200)
2768 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
2772 C...List of all processes implemented in the program.
2773 ELSEIF(MSTAT.EQ.6) THEN
2774 WRITE(MSTU(11),7400)
2775 WRITE(MSTU(11),7500)
2777 IF(ISET(I).LT.0) GOTO 180
2778 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
2780 WRITE(MSTU(11),7700)
2783 C...Formats for printouts.
2784 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
2785 &'Events and Cross-sections',1X,9('*'))
2786 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
2787 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
2788 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
2789 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
2790 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
2791 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
2793 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
2795 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
2796 &1X,'I',34X,'I',28X,'I',12X,'I')
2797 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
2798 &1X,'********* Fraction of events that fail fragmentation ',
2799 &'cuts =',1X,F8.5,' *********'/)
2800 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
2801 &'Ratios',1X,27('*'))
2802 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2803 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
2804 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
2805 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2807 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
2808 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
2809 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
2810 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
2811 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2812 &1P,D10.3,0P,1X,'I')
2813 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
2814 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2815 &1P,D10.3,0P,1X,'I')
2816 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
2817 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
2818 &'Particles at Hard Interaction',1X,7('*'))
2819 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
2820 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
2821 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
2822 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
2823 &78('=')/1X,'I',38X,'I',37X,'I')
2824 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
2825 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
2826 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
2827 &'Kinematical Variables',1X,12('*'))
2828 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
2829 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
2831 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
2832 &1X,'<',1X,1P,D10.3,0P,16X,'I')
2833 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
2834 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
2835 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
2836 &'Parameter Values',1X,12('*'))
2837 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
2839 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
2840 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
2842 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
2843 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
2844 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
2845 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
2846 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
2851 C*********************************************************************
2854 C...Calculates full and effective widths of gauge bosons, stores
2855 C...masses and widths, rescales coefficients to be used for
2856 C...resonance production generation.
2860 C...Double precision and integer declarations.
2861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2862 INTEGER PYK,PYCHGE,PYCOMP
2863 C...Parameter statement to help give large particle numbers.
2864 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2867 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2868 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2869 COMMON/PYDAT4/CHAF(500,2)
2871 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2872 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2873 COMMON/PYINT1/MINT(400),VINT(400)
2874 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2875 COMMON/PYINT4/MWID(500),WIDS(500,5)
2876 COMMON/PYINT6/PROC(0:500)
2878 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2879 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2880 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
2881 C...Local arrays and data.
2882 DIMENSION WDTP(0:200),WDTE(0:200,0:5),WDTPM(0:200),
2883 &WDTEM(0:200,0:5),KCORD(500),PMORD(500)
2885 C...Born level couplings in MSSM Higgs doublet sector.
2888 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
2890 IF(MSTP(4).EQ.2) THEN
2892 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
2896 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
2897 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
2899 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
2900 WRITE(MSTU(11),5000)
2903 PMAS(35,1)=SQRT(SQMHP)
2904 PMAS(36,1)=SQRT(SQMA)
2905 PMAS(37,1)=SQRT(SQMHC)
2906 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
2911 PARU(161)=-SIN(ALSU)/COS(BESU)
2912 PARU(162)=COS(ALSU)/SIN(BESU)
2914 PARU(164)=SIN(BESU-ALSU)
2916 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
2917 PARU(171)=COS(ALSU)/COS(BESU)
2918 PARU(172)=SIN(ALSU)/SIN(BESU)
2920 PARU(174)=COS(BESU-ALSU)
2922 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
2924 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
2925 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
2931 PARU(186)=COS(BESU-ALSU)
2932 PARU(187)=SIN(BESU-ALSU)
2936 PARU(195)=COS(BESU-ALSU)
2939 C...Reset effective widths of gauge bosons.
2946 C...Order resonances by increasing mass (except Z0 and W+/-).
2950 IF(KF.EQ.0) GOTO 140
2951 IF(MWID(KC).EQ.0) GOTO 140
2952 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
2953 IF(MSTP(1).LE.3) GOTO 140
2955 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
2956 IF(IMSS(1).LE.0) GOTO 140
2960 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
2961 DO 120 I1=NRES-1,1,-1
2962 IF(PMRES.GE.PMORD(I1)) GOTO 130
2963 KCORD(I1+1)=KCORD(I1)
2964 PMORD(I1+1)=PMORD(I1)
2970 C...Loop over possible resonances.
2975 C...Check that no fourth generation channels on by mistake.
2976 IF(MSTP(1).LE.3) THEN
2977 DO 150 J=1,MDCY(KC,3)
2979 KFA1=IABS(KFDP(IDC,1))
2980 KFA2=IABS(KFDP(IDC,2))
2981 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
2982 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
2987 C...Check that no supersymmetric channels on by mistake.
2988 IF(IMSS(1).LE.0) THEN
2989 DO 160 J=1,MDCY(KC,3)
2991 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
2992 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
2993 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
2998 C...Find mass and evaluate width.
3000 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3001 IF(MWID(KC).EQ.3) MINT(63)=1
3002 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3005 C...Evaluate suppression factors due to non-simulated channels.
3006 IF(KCHG(KC,3).EQ.0) THEN
3007 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3008 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3009 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3010 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3015 IF(MWID(KC).EQ.3) MINT(63)=1
3016 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3018 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3019 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3020 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3021 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3022 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3023 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3024 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3025 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3026 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3027 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3028 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3029 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3032 C...Set resonance widths and branching ratios;
3033 C...also on/off switch for decays.
3034 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3036 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3038 DO 170 J=1,MDCY(KC,3)
3041 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3046 C...Flavours of leptoquark: redefine charge and name.
3047 KFLQQ=KFDP(MDCY(39,2),1)
3048 KFLQL=KFDP(MDCY(39,2),2)
3049 KCHG(39,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3050 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3052 IF(IABS(KFLQL).EQ.13) LL=2
3053 IF(IABS(KFLQL).EQ.15) LL=3
3054 CHAF(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3055 &CHAF(IABS(KFLQL),1)(1:LL)//' '
3056 CHAF(39,2)=CHAF(39,2)(1:4+LL)//'bar '
3058 C...Special cases in treatment of gamma*/Z0: redefine process name.
3059 IF(MSTP(43).EQ.1) THEN
3060 PROC(1)='f + fbar -> gamma*'
3061 PROC(15)='f + fbar -> g + gamma*'
3062 PROC(19)='f + fbar -> gamma + gamma*'
3063 PROC(30)='f + g -> f + gamma*'
3064 PROC(35)='f + gamma -> f + gamma*'
3065 ELSEIF(MSTP(43).EQ.2) THEN
3066 PROC(1)='f + fbar -> Z0'
3067 PROC(15)='f + fbar -> g + Z0'
3068 PROC(19)='f + fbar -> gamma + Z0'
3069 PROC(30)='f + g -> f + Z0'
3070 PROC(35)='f + gamma -> f + Z0'
3071 ELSEIF(MSTP(43).EQ.3) THEN
3072 PROC(1)='f + fbar -> gamma*/Z0'
3073 PROC(15)='f + fbar -> g + gamma*/Z0'
3074 PROC(19)='f + fbar -> gamma + gamma*/Z0'
3075 PROC(30)='f + g -> f + gamma*/Z0'
3076 PROC(35)='f + gamma -> f + gamma*/Z0'
3079 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3080 IF(MSTP(44).EQ.1) THEN
3081 PROC(141)='f + fbar -> gamma*'
3082 ELSEIF(MSTP(44).EQ.2) THEN
3083 PROC(141)='f + fbar -> Z0'
3084 ELSEIF(MSTP(44).EQ.3) THEN
3085 PROC(141)='f + fbar -> Z''0'
3086 ELSEIF(MSTP(44).EQ.4) THEN
3087 PROC(141)='f + fbar -> gamma*/Z0'
3088 ELSEIF(MSTP(44).EQ.5) THEN
3089 PROC(141)='f + fbar -> gamma*/Z''0'
3090 ELSEIF(MSTP(44).EQ.6) THEN
3091 PROC(141)='f + fbar -> Z0/Z''0'
3092 ELSEIF(MSTP(44).EQ.7) THEN
3093 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3096 C...Special cases in treatment of WW -> WW: redefine process name.
3097 IF(MSTP(45).EQ.1) THEN
3098 PROC(77)='W+ + W+ -> W+ + W+'
3099 ELSEIF(MSTP(45).EQ.2) THEN
3100 PROC(77)='W+ + W- -> W+ + W-'
3101 ELSEIF(MSTP(45).EQ.3) THEN
3102 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3105 C...Format for error information.
3106 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3107 &'combination'/1X,'Execution stopped!')
3112 C*********************************************************************
3115 C...Identifies the two incoming particles and the choice of frame.
3117 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3119 C...Double precision and integer declarations.
3120 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3121 INTEGER PYK,PYCHGE,PYCOMP
3123 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3124 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3125 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3126 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3127 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3128 COMMON/PYINT1/MINT(400),VINT(400)
3129 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3130 C...Local arrays, character variables and data.
3131 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
3132 &CHIDNT(3)*8,CHTEMP*8,CHCDE(29)*8,CHINIT*76
3133 DIMENSION LEN(3),KCDE(29),PM(2)
3134 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3135 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3136 DATA CHCDE/'e- ','e+ ','nu_e ','nu_ebar ',
3137 &'mu- ','mu+ ','nu_mu ','nu_mubar','tau- ',
3138 &'tau+ ','nu_tau ','nu_tauba','pi+ ','pi- ',
3139 &'n0 ','nbar0 ','p+ ','pbar- ','gamma ',
3140 &'lambda0 ','sigma- ','sigma0 ','sigma+ ','xi- ',
3141 &'xi0 ','omega- ','pi0 ','reggeon ','pomeron '/
3142 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3143 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3144 &3312,3322,3334,111,28,29/
3146 C...Store initial energy. Default frame.
3150 C...Convert character variables to lowercase and find their length.
3157 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
3159 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
3165 C...Fix up bar, underscore and charge in particle name (if needed).
3167 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
3169 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:6)//' '
3172 IF(CHIDNT(I)(7:7).EQ.'~') CHIDNT(I)(7:8)='ba'
3173 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
3175 CHIDNT(I)='nu_'//CHTEMP(3:7)
3176 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
3177 CHIDNT(I)(1:3)='n0 '
3178 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
3179 CHIDNT(I)(1:5)='nbar0'
3180 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
3181 CHIDNT(I)(1:3)='p+ '
3182 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
3183 & CHIDNT(I)(1:2).EQ.'p-') THEN
3184 CHIDNT(I)(1:5)='pbar-'
3185 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
3187 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
3188 CHIDNT(I)(1:7)='reggeon'
3189 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
3190 CHIDNT(I)(1:7)='pomeron'
3194 C...Identify free initialization.
3195 IF(CHCOM(1)(1:2).EQ.'no') THEN
3200 C...Identify incoming beam and target particles.
3203 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
3205 PM(I)=PYMASS(MINT(10+I))
3208 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
3209 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
3210 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
3212 C...Identify choice of frame and input energies.
3215 C...Events defined in the CM frame.
3216 IF(CHCOM(1)(1:2).EQ.'cm') THEN
3219 IF(MSTP(122).GE.1) THEN
3220 IF(CHCOM(2)(1:1).NE.'e') THEN
3221 LOFFS=(31-(LEN(2)+LEN(3)))/2
3222 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
3223 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3226 LOFFS=(30-(LEN(2)+LEN(3)))/2
3227 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
3228 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3231 WRITE(MSTU(11),5200) CHINIT
3232 WRITE(MSTU(11),5300) WIN
3235 C...Events defined in fixed target frame.
3236 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
3238 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
3239 IF(MSTP(122).GE.1) THEN
3240 LOFFS=(29-(LEN(2)+LEN(3)))/2
3241 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3242 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3243 & ' fixed target'//' '
3244 WRITE(MSTU(11),5200) CHINIT
3245 WRITE(MSTU(11),5400) WIN
3246 WRITE(MSTU(11),5500) SQRT(S)
3249 C...Frame defined by user three-vectors.
3250 ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
3254 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3255 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3256 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3257 & (P(1,3)+P(2,3))**2
3258 IF(MSTP(122).GE.1) THEN
3259 LOFFS=(12-(LEN(2)+LEN(3)))/2
3260 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3261 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3262 & ' user-specified configuration'//' '
3263 WRITE(MSTU(11),5200) CHINIT
3264 WRITE(MSTU(11),5600)
3265 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3266 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3267 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3270 C...Frame defined by user four-vectors.
3271 ELSEIF(CHCOM(1)(1:4).EQ.'four') THEN
3273 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3274 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3275 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3276 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3277 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3278 & (P(1,3)+P(2,3))**2
3279 IF(MSTP(122).GE.1) THEN
3280 LOFFS=(12-(LEN(2)+LEN(3)))/2
3281 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3282 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3283 & ' user-specified configuration'//' '
3284 WRITE(MSTU(11),5200) CHINIT
3285 WRITE(MSTU(11),5600)
3286 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3287 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3288 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3291 C...Frame defined by user five-vectors.
3292 ELSEIF(CHCOM(1)(1:4).EQ.'five') THEN
3294 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3295 & (P(1,3)+P(2,3))**2
3296 IF(MSTP(122).GE.1) THEN
3297 LOFFS=(12-(LEN(2)+LEN(3)))/2
3298 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3299 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3300 & ' user-specified configuration'//' '
3301 WRITE(MSTU(11),5200) CHINIT
3302 WRITE(MSTU(11),5600)
3303 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3304 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3305 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3308 C...Unknown frame. Error for too low CM energy.
3310 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
3313 IF(S.LT.PARP(2)**2) THEN
3314 WRITE(MSTU(11),5900) SQRT(S)
3318 C...Formats for initialization and error information.
3319 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
3320 &1X,'Execution stopped!')
3321 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
3322 &1X,'Execution stopped!')
3323 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
3324 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
3325 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
3326 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
3327 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
3328 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
3329 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
3330 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
3331 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
3332 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
3333 &1X,'Execution stopped!')
3334 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
3335 &'generation.'/1X,'Execution stopped!')
3340 C*********************************************************************
3343 C...Sets up kinematics, including rotations and boosts to/from CM frame.
3345 SUBROUTINE PYINKI(MODKI)
3347 C...Double precision and integer declarations.
3348 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3349 INTEGER PYK,PYCHGE,PYCOMP
3351 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3352 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3353 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3354 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3355 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3356 COMMON/PYINT1/MINT(400),VINT(400)
3357 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3359 C...Set initial flavour state.
3366 C...Reset boost. Do kinematics for various cases.
3371 C...Set up kinematics for events defined in CM frame.
3372 IF(MINT(111).EQ.1) THEN
3374 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3382 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
3385 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3386 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
3388 C...Set up kinematics for fixed target events.
3389 ELSEIF(MINT(111).EQ.2) THEN
3391 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3399 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3402 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
3403 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
3404 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
3406 C...Set up kinematics for events in user-defined frame.
3407 ELSEIF(MINT(111).EQ.3) THEN
3410 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3411 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3413 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3415 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3416 VINT(7)=PYANGL(P(1,1),P(1,2))
3417 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3418 VINT(6)=PYANGL(P(1,3),P(1,1))
3419 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3420 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
3422 C...Set up kinematics for events with user-defined four-vectors.
3423 ELSEIF(MINT(111).EQ.4) THEN
3424 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3425 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3426 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3427 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3429 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3431 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3432 VINT(7)=PYANGL(P(1,1),P(1,2))
3433 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3434 VINT(6)=PYANGL(P(1,3),P(1,1))
3435 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3436 S=(P(1,4)+P(2,4))**2
3438 C...Set up kinematics for events with user-defined five-vectors.
3439 ELSEIF(MINT(111).EQ.5) THEN
3441 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3443 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3444 VINT(7)=PYANGL(P(1,1),P(1,2))
3445 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3446 VINT(6)=PYANGL(P(1,3),P(1,1))
3447 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3448 S=(P(1,4)+P(2,4))**2
3451 C...Return or error for too low CM energy.
3452 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
3453 IF(MSTP(172).LE.1) THEN
3455 & '(PYINKI:) too low invariant mass in this event')
3462 C...Save information on incoming particles.
3465 IF(MINT(111).GE.4) VINT(3)=P(1,5)
3466 IF(MINT(111).GE.4) VINT(4)=P(2,5)
3468 IF(MODKI.EQ.0) VINT(289)=S
3476 C...Store pT cut-off and related constants to be used in generation.
3477 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
3478 IF(MSTP(82).LE.1) THEN
3479 IF(MINT(121).GT.1) PARP(81)=1.30D0+0.15D0*LOG(VINT(1)/200D0)/
3483 IF(MINT(121).GT.1) PARP(82)=1.25D0+0.15D0*LOG(VINT(1)/200D0)/
3487 VINT(149)=4D0*PTMN**2/S
3492 C*********************************************************************
3495 C...Selects partonic subprocesses to be included in the simulation.
3499 C...Double precision and integer declarations.
3500 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3501 INTEGER PYK,PYCHGE,PYCOMP
3503 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3504 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3505 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3506 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3507 COMMON/PYINT1/MINT(400),VINT(400)
3508 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3509 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
3511 C...Reset processes to be included.
3518 C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous.
3519 IF(MINT(121).EQ.2) THEN
3521 MINT(123)=MINT(122)+1
3523 C...For gamma-p or gamma-gamma with MSTP(14)=10 allow mixture.
3524 C...Here also set a few parameters otherwise normally not touched.
3525 ELSEIF(MINT(121).GT.1) THEN
3527 C...Parton distributions dampened at small Q2; go to low energies,
3528 C...alpha_s <1; no minimum pT cut-off a priori.
3536 C...Define pT cut-off parameters and whether run involves low-pT.
3537 IF(MSTP(82).LE.1) THEN
3538 PTMVMD=1.30D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3540 PTMVMD=1.25D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3544 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
3545 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
3547 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
3548 IF(MSEL.EQ.2) IPTL=1
3550 C...Set up for p/VMD * VMD.
3551 IF(MINT(122).EQ.1) THEN
3559 IF(IPTL.EQ.1) MSUB(95)=1
3568 IF(IPTL.EQ.1) CKIN(3)=0D0
3570 C...Set up for p/VMD * direct gamma.
3571 ELSEIF(MINT(122).EQ.2) THEN
3573 IF(MINT(121).EQ.6) MINT(123)=5
3576 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3578 C...Set up for p/VMD * anomalous gamma.
3579 ELSEIF(MINT(122).EQ.3) THEN
3581 IF(MINT(121).EQ.6) MINT(123)=7
3588 IF(MSTP(82).GE.2) MSTP(85)=1
3589 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3591 C...Set up for direct * direct gamma (switch off leptons).
3592 ELSEIF(MINT(122).EQ.4) THEN
3595 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3596 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3598 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3600 C...Set up for direct * anomalous gamma.
3601 ELSEIF(MINT(122).EQ.5) THEN
3605 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3607 C...Set up for anomalous * anomalous gamma.
3608 ELSEIF(MINT(122).EQ.6) THEN
3616 IF(MSTP(82).GE.2) MSTP(85)=1
3617 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3620 C...End of special set up for gamma-p and gamma-gamma.
3624 C...Flavour information for individual beams.
3627 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
3628 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
3629 IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2
3630 MINT(44+I)=MINT(40+I)
3631 IF(MSTP(11).GE.1.AND.IABS(MINT(10+I)).EQ.11) MINT(44+I)=3
3634 C...If two gammas, whereof one direct, pick the first.
3635 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3636 IF(MINT(123).GE.4.AND.MINT(123).LE.6) THEN
3640 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
3641 IF(MINT(123).GE.4) CALL PYERRM(26,
3642 & '(PYINPR:) unallowed MSTP(14) code for single photon')
3645 C...Flavour information on combination of incoming particles.
3646 MINT(43)=2*MINT(41)+MINT(42)-2
3648 IF(MINT(123).LE.0) THEN
3649 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
3650 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
3651 ELSEIF(MINT(123).LE.3) THEN
3652 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
3653 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
3654 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3658 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
3659 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
3661 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
3662 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.MINT(123).GE.3)
3665 IF(MINT(11).EQ.22) THEN
3667 IF(MINT(123).GE.4) MINT(107)=0
3668 IF(MINT(123).EQ.7) MINT(107)=2
3671 IF(MINT(12).EQ.22) THEN
3673 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
3674 IF(MINT(123).EQ.7) MINT(108)=3
3677 C...Select default processes according to incoming beams
3678 C...(already done for gamma-p and gamma-gamma with MSTP(14)=10).
3679 IF(MINT(121).GT.1) THEN
3680 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
3682 IF(MINT(43).EQ.1) THEN
3683 C...Lepton + lepton -> gamma/Z0 or W.
3684 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
3685 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
3687 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
3688 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
3689 C...Unresolved photon + lepton: Compton scattering.
3692 ELSEIF(MINT(43).LE.3) THEN
3693 C...Lepton + hadron: deep inelastic scattering.
3696 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
3697 & MINT(12).EQ.22) THEN
3698 C...Two unresolved photons: fermion pair production.
3701 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
3702 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
3703 & MINT(12).EQ.22)) THEN
3704 C...Unresolved photon + hadron: photon-parton scattering.
3709 ELSEIF(MSEL.EQ.1) THEN
3710 C...High-pT QCD processes:
3717 IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
3718 IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
3719 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
3722 C...All QCD processes:
3736 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
3737 C...Heavy quark production.
3741 DO 130 J=1,MIN(8,MDCY(21,3))
3742 MDME(MDCY(21,2)+J-1,1)=0
3744 MDME(MDCY(21,2)+MSEL-1,1)=1
3746 DO 140 J=1,MIN(12,MDCY(22,3))
3747 MDME(MDCY(22,2)+J-1,1)=0
3749 MDME(MDCY(22,2)+MSEL-1,1)=1
3751 ELSEIF(MSEL.EQ.10) THEN
3752 C...Prompt photon production:
3757 ELSEIF(MSEL.EQ.11) THEN
3758 C...Z0/gamma* production:
3761 ELSEIF(MSEL.EQ.12) THEN
3762 C...W+/- production:
3765 ELSEIF(MSEL.EQ.13) THEN
3770 ELSEIF(MSEL.EQ.14) THEN
3775 ELSEIF(MSEL.EQ.15) THEN
3776 C...Z0 & W+/- pair production:
3783 ELSEIF(MSEL.EQ.16) THEN
3791 ELSEIF(MSEL.EQ.17) THEN
3792 C...h0 & Z0 or W+/- pair production:
3796 ELSEIF(MSEL.EQ.18) THEN
3797 C...h0 production; interesting processes in e+e-.
3803 ELSEIF(MSEL.EQ.19) THEN
3804 C...h0, H0 and A0 production; interesting processes in e+e-.
3818 ELSEIF(MSEL.EQ.21) THEN
3822 ELSEIF(MSEL.EQ.22) THEN
3823 C...W'+/- production:
3826 ELSEIF(MSEL.EQ.23) THEN
3827 C...H+/- production:
3830 ELSEIF(MSEL.EQ.24) THEN
3834 ELSEIF(MSEL.EQ.25) THEN
3835 C...LQ (leptoquark) production.
3841 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
3842 C...Production of one heavy quark (W exchange):
3844 DO 150 J=1,MIN(8,MDCY(21,3))
3845 MDME(MDCY(21,2)+J-1,1)=0
3847 MDME(MDCY(21,2)+MSEL-31,1)=1
3849 CMRENNA++Define SUSY alternatives.
3850 ELSEIF(MSEL.EQ.39) THEN
3851 C...Turn on all SUSY processes.
3852 IF(MINT(43).EQ.4) THEN
3853 C...Hadron-hadron processes.
3855 IF(ISET(I).GE.0) MSUB(I)=1
3857 ELSEIF(MINT(43).EQ.1) THEN
3858 C...Lepton-lepton processes: QED production of squarks.
3875 ELSEIF(MSEL.EQ.40) THEN
3876 C...Gluinos and squarks.
3877 IF(MINT(43).EQ.4) THEN
3889 ELSEIF(MINT(43).EQ.1) THEN
3894 ELSEIF(MSEL.EQ.41) THEN
3895 C...Stop production.
3899 IF(MINT(43).EQ.4) THEN
3904 ELSEIF(MSEL.EQ.42) THEN
3905 C...Slepton production.
3909 IF(MINT(43).NE.4) THEN
3915 ELSEIF(MSEL.EQ.43) THEN
3916 C...Neutralino/Chargino + Gluino/Squark.
3917 IF(MINT(43).EQ.4) THEN
3926 ELSEIF(MSEL.EQ.44) THEN
3927 C...Neutralino/Chargino pair production.
3928 IF(MINT(43).EQ.4) THEN
3932 ELSEIF(MINT(43).EQ.1) THEN
3939 C...Find heaviest new quark flavour allowed in processes 81-84.
3941 DO 260 I=1,MIN(8,MDCY(21,3))
3943 IF(MDME(IDC,1).LE.0) GOTO 260
3946 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
3957 C...Find heaviest new fermion flavour allowed in process 85.
3959 DO 270 I=1,MIN(12,MDCY(22,3))
3961 IF(MDME(IDC,1).LE.0) GOTO 270
3964 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
3965 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
3973 C*********************************************************************
3976 C...Parametrizes total, elastic and diffractive cross-sections
3977 C...for different energies and beams. Donnachie-Landshoff for
3978 C...total and Schuler-Sjostrand for elastic and diffractive.
3979 C...Process code IPROC:
3986 C...= 7 : J/psi + p;
3987 C...= 11 : rho + rho;
3988 C...= 12 : rho + phi;
3989 C...= 13 : rho + J/psi;
3990 C...= 14 : phi + phi;
3991 C...= 15 : phi + J/psi;
3992 C...= 16 : J/psi + J/psi;
3993 C...= 21 : gamma + p (DL);
3994 C...= 22 : gamma + p (VDM).
3995 C...= 23 : gamma + pi (DL);
3996 C...= 24 : gamma + pi (VDM);
3997 C...= 25 : gamma + gamma (DL);
3998 C...= 26 : gamma + gamma (VDM).
4002 C...Double precision and integer declarations.
4003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4004 INTEGER PYK,PYCHGE,PYCOMP
4006 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4007 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4008 COMMON/PYINT1/MINT(400),VINT(400)
4009 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4010 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4011 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
4013 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
4014 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
4015 &CEFFD(10,9),SIGTMP(6,0:5)
4017 C...Common constants.
4018 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
4019 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
4022 C...Number of multiple processes to be evaluated (= 0 : undefined).
4023 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4024 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4025 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
4026 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
4027 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
4029 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
4030 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
4031 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
4033 C...Beam and target hadron class:
4034 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4035 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4036 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
4037 C...Characteristic class masses, slope parameters, beta = sqrt(X).
4038 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
4039 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
4040 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
4042 C...Fitting constants used in parametrizations of diffractive results.
4043 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4044 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4045 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
4046 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
4047 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
4048 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
4049 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
4050 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
4051 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
4052 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
4053 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
4054 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
4055 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
4056 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
4057 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
4058 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
4059 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
4060 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
4061 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
4062 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
4063 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
4064 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
4065 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
4066 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
4067 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
4068 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
4069 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
4070 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
4071 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
4073 C...Parameters. Combinations of the energy.
4082 C...Ratio of gamma/pi (for rescaling in parton distributions).
4083 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
4084 &(XPAR(5)*SEPS+YPAR(5)*SETA)
4085 IF(MINT(50).NE.1) RETURN
4087 C...Order flavours of incoming particles: KF1 < KF2.
4088 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
4097 ISGN12=ISIGN(1,MINT(11)*MINT(12))
4099 C...Find process number (for lookup tables).
4100 IF(KF1.GT.1000) THEN
4102 IF(ISGN12.LT.0) IPROC=2
4103 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
4105 IF(ISGN12.LT.0) IPROC=4
4106 IF(KF1.EQ.111) IPROC=5
4107 ELSEIF(KF1.GT.100) THEN
4109 ELSEIF(KF2.GT.1000) THEN
4111 IF(MINT(123).EQ.2) IPROC=22
4112 ELSEIF(KF2.GT.100) THEN
4114 IF(MINT(123).EQ.2) IPROC=24
4117 IF(MINT(123).EQ.2) IPROC=26
4120 C... Number of multiple processes to be stored; beam/target side.
4126 ELSEIF(NPR.EQ.6) THEN
4131 IF(MINT(101).EQ.4) N1=4
4133 IF(MINT(102).EQ.4) N2=4
4135 C...Do not do any more for user-set or undefined cross-sections.
4136 IF(MSTP(31).LE.0) RETURN
4137 IF(NPR.EQ.0) CALL PYERRM(26,
4138 &'(PYXTOT:) cross section for this process not yet implemented')
4140 C...Parameters. Combinations of the energy.
4149 C...Loop over multiple processes (for VDM).
4153 ELSEIF(NPR.EQ.3) THEN
4155 IF(KF2.LT.1000) IPR=I+10
4156 ELSEIF(NPR.EQ.6) THEN
4160 C...Evaluate hadron species, mass, slope contribution and fit number.
4170 C...Skip if energy too low relative to masses.
4174 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
4176 C...Total cross-section. Elastic slope parameter and cross-section.
4177 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
4178 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
4179 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
4181 C...Diffractive scattering A + B -> X + B.
4184 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
4185 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4186 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4187 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
4188 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
4189 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
4190 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
4192 C...Diffractive scattering A + B -> A + X.
4195 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
4196 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4197 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4198 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
4199 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
4200 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
4201 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
4203 C...Order single diffractive correctly.
4206 SIGTMP(I,2)=SIGTMP(I,3)
4210 C...Double diffractive scattering A + B -> X1 + X2.
4211 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
4212 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
4213 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
4214 IF(YEFF.LE.0) SUM1=0D0
4215 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
4216 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
4217 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
4218 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
4220 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
4221 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
4222 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
4224 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
4225 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
4226 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
4227 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
4228 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
4230 C...Non-diffractive by unitarity.
4231 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
4235 C...Put temporary results in output array: only one process.
4236 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
4238 SIGT(0,0,J)=SIGTMP(1,J)
4241 C...Beam multiple processes.
4242 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
4244 CONV=AEM/PARP(160+I)
4247 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
4251 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4254 C...Target multiple processes.
4255 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
4257 CONV=AEM/PARP(160+I)
4260 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
4264 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
4267 C...Both beam and target multiple processes.
4271 CONV=AEM**2/(PARP(160+I1)*PARP(160+I2))
4274 ELSEIF(I2.LE.2) THEN
4276 ELSEIF(I1.EQ.I2) THEN
4283 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
4284 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
4290 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
4291 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
4293 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4297 C...Scale up uniformly for Donnachie-Landshoff parametrization.
4298 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
4299 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
4303 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
4312 C*********************************************************************
4315 C...Finds optimal set of coefficients for kinematical variable selection
4316 C...and the maximum of the part of the differential cross-section used
4317 C...in the event weighting.
4321 C...Double precision and integer declarations.
4322 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4323 INTEGER PYK,PYCHGE,PYCOMP
4324 C...Parameter statement to help give large particle numbers.
4325 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
4327 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4328 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4329 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
4330 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4331 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4332 COMMON/PYINT1/MINT(400),VINT(400)
4333 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4334 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
4335 COMMON/PYINT4/MWID(500),WIDS(500,5)
4336 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4337 COMMON/PYINT6/PROC(0:500)
4339 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4340 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4341 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
4342 C...Local arrays, character variables and data.
4344 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
4345 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
4346 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
4347 DATA CVAR/'tau ','tau''','y* ','cth '/
4350 C...Select subprocess to study: skip cases not applicable.
4357 IF(ISET(ISUB).EQ.11) THEN
4358 XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
4361 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
4362 XSEC(ISUB,1)=SIGT(0,0,ISUB-90)
4363 IF(MSUB(ISUB).NE.1) GOTO 460
4366 ELSEIF(ISUB.EQ.96) THEN
4367 IF(MINT(50).EQ.0) GOTO 460
4368 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
4370 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
4371 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
4372 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
4373 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
4375 IF(MSUB(ISUB).NE.1) GOTO 460
4379 IF(ISUB.EQ.96) ISTSB=2
4380 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
4382 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
4383 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
4385 C...Find resonances (explicit or implicit in cross-section).
4388 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
4390 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
4391 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
4393 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
4394 & .OR.ISUB.EQ.177) THEN
4396 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
4398 IF(MSTP(46).EQ.5) THEN
4401 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
4403 ELSEIF(ISUB.EQ.194) THEN
4407 IF(CKMX.LE.0D0) CKMX=VINT(1)
4410 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
4411 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
4414 TAUR1=PMAS(KCR1,1)**2/VINT(2)
4415 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
4422 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
4424 IF(ISUB.EQ.194) KFR2=56
4426 TAUR2=PMAS(KCR2,1)**2/VINT(2)
4427 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
4428 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
4429 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
4430 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
4435 ELSEIF(KFR2.NE.0) THEN
4447 C...Find product masses and minimum pT of process.
4453 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4457 IF(KFPR(ISUB,I).EQ.0) THEN
4458 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
4460 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4461 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4464 C...This prevents SUSY/t particles from becoming too light.
4466 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
4469 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
4470 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
4471 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
4472 & PMAS(PYCOMP(KFDP(IDC,2)),1)
4473 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
4474 & PMAS(PYCOMP(KFDP(IDC,3)),1)
4475 PMMN(I)=MIN(PMMN(I),PMSUM)
4478 ELSEIF(KFLW.EQ.6) THEN
4479 PMMN(I)=PMAS(24,1)+PMAS(5,1)
4486 CKIN(41)=MAX(PMMN(1),CKIN(41))
4487 CKIN(43)=MAX(PMMN(2),CKIN(43))
4488 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
4491 IF(MINT(51).EQ.1) THEN
4492 WRITE(MSTU(11),5100) ISUB
4499 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
4500 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
4501 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
4502 IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08D0*PARP(82)
4507 C...Prepare for additional variable choices in 2 -> 3.
4510 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
4512 VINT(204)=PMAS(23,1)
4513 IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
4514 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
4515 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
4519 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
4520 NPTS(1)=2+2*MINT(72)
4521 IF(MINT(47).EQ.1) THEN
4522 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
4523 ELSEIF(MINT(47).EQ.5) THEN
4524 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
4527 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
4528 IF(MINT(47).GE.2) NPTS(2)=2
4529 IF(MINT(47).EQ.5) NPTS(2)=3
4532 IF(MINT(47).GE.4) NPTS(3)=3
4533 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
4534 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
4536 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
4537 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
4539 C...Reset coefficients of cross-section weighting.
4555 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
4556 C...in grid of phase space points.
4562 IF(METAU.EQ.1) GOTO 150
4563 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
4564 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
4565 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
4567 C...Special case when both resonances have same mass,
4568 C...as is often the case in process 194.
4569 IF(MINT(72).EQ.2) THEN
4570 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
4571 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
4572 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
4574 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
4579 CALL PYKMAP(1,MTAU,RTAU)
4580 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
4583 IF(METAUP.EQ.1) GOTO 150
4584 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
4586 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
4587 CALL PYKMAP(4,MTAUP,0.5D0)
4589 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
4593 IF(MEYST.EQ.1) GOTO 150
4594 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
4595 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
4596 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
4597 CALL PYKMAP(2,MYST,0.5D0)
4601 IF(MECTH.EQ.1) GOTO 150
4602 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4603 MCTH=1+MOD(ITRY-1,NPTS(4))
4604 CALL PYKMAP(3,MCTH,0.5D0)
4606 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
4608 C...Store position and limits.
4611 IF(MINT(51).EQ.1) GOTO 150
4614 MVARPT(NACC,2)=MTAUP
4618 VINTPT(NACC,J)=VINT(10+J)
4621 C...Normal case: calculate cross-section.
4623 CALL PYSIGH(NCHN,SIGS)
4629 C..2 -> 3: find highest value out of a number of tries.
4632 DO 140 IKIN3=1,MSTP(129)
4633 CALL PYKMAP(5,0,0D0)
4634 IF(MINT(51).EQ.1) GOTO 140
4635 CALL PYSIGH(NCHN,SIGTMP)
4640 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4644 C...Store cross-section.
4646 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
4647 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
4648 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
4651 WRITE(MSTU(11),5100) ISUB
4654 ELSEIF(SIGSAM.EQ.0D0) THEN
4655 WRITE(MSTU(11),5300) ISUB
4659 IF(ISUB.NE.96) NPOSI=NPOSI+1
4661 C...Calculate integrals in tau over maximal phase space limits.
4664 ATAU1=LOG(TAUMAX/TAUMIN)
4665 IF(NPTS(1).GE.2) THEN
4666 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
4668 IF(NPTS(1).GE.4) THEN
4669 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
4670 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
4673 IF(NPTS(1).GE.6) THEN
4674 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
4675 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
4678 IF(NPTS(1).GT.2+2*MINT(72)) THEN
4679 ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
4682 C...Reset. Sum up cross-sections in points calculated.
4684 IF(NPTS(IVAR).EQ.1) GOTO 320
4685 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
4696 IBIN=MVARPT(IACC,IVAR)
4697 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
4698 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
4699 NAREL(IBIN)=NAREL(IBIN)+1
4700 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
4702 C...Sum up tau cross-section pieces in points used.
4705 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4706 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
4708 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
4709 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
4710 & ((TAU-TAUR1)**2+GAMR1**2)
4713 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
4714 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
4715 & ((TAU-TAUR2)**2+GAMR2**2)
4717 IF(NBIN.GT.2+2*MINT(72)) THEN
4718 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
4719 & TAU/MAX(2D-6,1D0-TAU)
4722 C...Sum up tau' cross-section pieces in points used.
4723 ELSEIF(IVAR.EQ.2) THEN
4725 TAUP=VINTPT(IACC,16)
4726 TAUPMN=VINTPT(IACC,6)
4727 TAUPMX=VINTPT(IACC,26)
4728 ATAUP1=LOG(TAUPMX/TAUPMN)
4729 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
4730 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4731 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
4732 & (1D0-TAU/TAUP)**3/TAUP
4734 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
4735 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
4736 & TAUP/MAX(2D-6,1D0-TAUP)
4739 C...Sum up y* cross-section pieces in points used.
4740 ELSEIF(IVAR.EQ.3) THEN
4742 YSTMIN=VINTPT(IACC,2)
4743 YSTMAX=VINTPT(IACC,22)
4745 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
4747 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
4748 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
4749 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
4750 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
4751 IF(MINT(45).EQ.3) THEN
4752 TAUE=VINTPT(IACC,11)
4753 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4754 YST0=-0.5D0*LOG(TAUE)
4755 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
4756 & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
4757 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
4758 & MAX(1D-6,1D0-EXP(YST-YST0))
4760 IF(MINT(46).EQ.3) THEN
4761 TAUE=VINTPT(IACC,11)
4762 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4763 YST0=-0.5D0*LOG(TAUE)
4764 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
4765 & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
4766 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
4767 & MAX(1D-6,1D0-EXP(-YST-YST0))
4770 C...Sum up cos(theta-hat) cross-section pieces in points used.
4772 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
4774 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
4776 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
4779 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
4780 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
4781 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
4782 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
4784 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4785 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
4786 & MAX(RM34,RSQM-CTH)
4787 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
4788 & MAX(RM34,RSQM+CTH)
4789 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
4790 & MAX(RM34,RSQM-CTH)**2
4791 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
4792 & MAX(RM34,RSQM+CTH)**2
4796 C...Check that equation system solvable.
4797 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
4801 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
4802 & IRED=1,NBIN),WTREL(IBIN)
4803 IF(NAREL(IBIN).EQ.0) MSOLV=0
4804 WTRELS=WTRELS+WTREL(IBIN)
4806 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
4808 C...Solve to find relative importance of cross-section pieces.
4811 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
4813 DO 230 IRED=1,NBIN-1
4814 DO 220 IBIN=IRED+1,NBIN
4815 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
4819 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
4820 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
4821 DO 210 ICOE=IRED,NBIN
4822 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
4826 DO 250 IRED=NBIN,1,-1
4827 DO 240 ICOE=IRED+1,NBIN
4828 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
4830 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
4834 C...Share evenly if failure.
4835 260 IF(MSOLV.EQ.0) THEN
4839 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
4840 & WTREL(IBIN)/WTRELS)
4844 C...Normalize coefficients, with piece shared democratically.
4848 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
4849 COEFSU=COEFSU+COEFU(IBIN)
4850 WTRELS=WTRELS+WTRELN(IBIN)
4852 IF(COEFSU.GT.0D0) THEN
4854 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
4855 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
4859 COEFO(IBIN)=1D0/NBIN
4862 IF(IVAR.EQ.1) IOFF=0
4863 IF(IVAR.EQ.2) IOFF=17
4864 IF(IVAR.EQ.3) IOFF=7
4865 IF(IVAR.EQ.4) IOFF=12
4868 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
4869 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
4870 COEF(ISUB,ICOF)=COEFO(IBIN)
4872 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
4873 & (COEFO(IBIN),IBIN=1,NBIN)
4876 C...Find two most promising maxima among points previously determined.
4884 VINT(10+J)=VINTPT(IACC,J)
4887 CALL PYSIGH(NCHN,SIGS)
4894 DO 350 IKIN3=1,MSTP(129)
4895 CALL PYKMAP(5,0,0D0)
4896 IF(MINT(51).EQ.1) GOTO 350
4897 CALL PYSIGH(NCHN,SIGTMP)
4902 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4907 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
4910 DO 370 IMV=NMAX,1,-1
4912 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
4913 IACCMX(IMV+1)=IACCMX(IMV)
4914 SIGSMX(IMV+1)=SIGSMX(IMV)
4917 380 IACCMX(IIN)=IACC
4919 IF(NMAX.LE.1) NMAX=NMAX+1
4923 C...Read out starting position for search.
4924 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
4929 MTAUP=MVARPT(IACC,2)
4937 C...Starting point and step size in parameter space.
4940 IF(NPTS(IVAR).EQ.1) GOTO 420
4941 IF(IVAR.EQ.1) VVAR=VTAU
4942 IF(IVAR.EQ.2) VVAR=VTAUP
4943 IF(IVAR.EQ.3) VVAR=VYST
4944 IF(IVAR.EQ.4) VVAR=VCTH
4945 IF(IVAR.EQ.1) MVAR=MTAU
4946 IF(IVAR.EQ.2) MVAR=MTAUP
4947 IF(IVAR.EQ.3) MVAR=MYST
4948 IF(IVAR.EQ.4) MVAR=MCTH
4949 IF(IRPT.EQ.1) VDEL=0.1D0
4950 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
4952 IF(IRPT.EQ.1) VMAR=0.02D0
4953 IF(IRPT.EQ.2) VMAR=0.002D0
4955 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
4958 C...Define new point in parameter space.
4962 ELSEIF(IMOV.EQ.1) THEN
4965 ELSEIF(IMOV.EQ.2) THEN
4968 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
4969 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
4975 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
4976 & VVAR-2D0*VDEL.GT.VMAR) THEN
4982 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
4996 C...Convert to relevant variables and find derived new limits.
5000 CALL PYKMAP(1,MTAU,VTAU)
5001 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5003 IF(MINT(51).EQ.1) ILERR=1
5006 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
5008 IF(IVAR.EQ.2) VTAUP=VNEW
5009 CALL PYKMAP(4,MTAUP,VTAUP)
5011 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
5013 IF(MINT(51).EQ.1) ILERR=1
5015 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
5016 IF(IVAR.EQ.3) VYST=VNEW
5017 CALL PYKMAP(2,MYST,VYST)
5019 IF(MINT(51).EQ.1) ILERR=1
5021 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
5023 IF(IVAR.EQ.4) VCTH=VNEW
5024 CALL PYKMAP(3,MCTH,VCTH)
5026 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
5028 C...Evaluate cross-section. Save new maximum. Final maximum.
5031 ELSEIF(ISTSB.NE.5) THEN
5032 CALL PYSIGH(NCHN,SIGS)
5039 DO 400 IKIN3=1,MSTP(129)
5040 CALL PYKMAP(5,0,0D0)
5041 IF(MINT(51).EQ.1) GOTO 400
5042 CALL PYSIGH(NCHN,SIGTMP)
5047 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5051 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5052 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
5053 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5058 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
5059 XSEC(ISUB,1)=1.05D0*SIGSAM
5061 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
5062 & PARP(174)*XSEC(ISUB,1)
5063 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
5067 C...Print summary table.
5069 WRITE(MSTU(11),5900)
5072 IF(MSTP(122).GE.1) THEN
5073 WRITE(MSTU(11),6000)
5074 WRITE(MSTU(11),6100)
5076 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
5077 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
5078 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
5079 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
5080 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
5081 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
5082 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
5084 WRITE(MSTU(11),6300)
5087 C...Format statements for maximization results.
5088 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
5089 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
5090 &'cth',9X,'tau''',7X,'sigma')
5091 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
5092 &'phase space.'/1X,'Process switched off!')
5093 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
5094 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
5095 &'cross-section.'/1X,'Process switched off!')
5096 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
5097 5500 FORMAT(1X,1P,8D11.3)
5098 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
5099 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
5100 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
5101 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
5102 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
5103 &'cross-section.'/1X,'Execution stopped!')
5104 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
5105 &'cross-section maximum search',1X,8('*'))
5106 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
5107 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
5108 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
5109 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
5110 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
5115 C*********************************************************************
5118 C...Initializes multiplicity distribution and selects mutliplicity
5119 C...of pileup events, i.e. several events occuring at the same
5122 SUBROUTINE PYPILE(MPILE)
5124 C...Double precision and integer declarations.
5125 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5126 INTEGER PYK,PYCHGE,PYCOMP
5128 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5129 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5130 COMMON/PYINT1/MINT(400),VINT(400)
5131 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5132 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
5133 C...Local arrays and saved variables.
5134 DIMENSION WTI(0:200)
5135 SAVE IMIN,IMAX,WTI,WTS
5137 C...Sum of allowed cross-sections for pileup events.
5139 VINT(131)=SIGT(0,0,5)
5140 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
5141 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
5142 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
5143 IF(MSTP(133).LE.0) RETURN
5145 C...Initialize multiplicity distribution at maximum.
5146 XNAVE=VINT(131)*PARP(131)
5147 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
5148 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
5151 WTN=WTI(INAVE)*INAVE
5153 C...Find shape of multiplicity distribution below maximum.
5155 DO 100 I=INAVE-1,1,-1
5156 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
5157 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
5158 IF(WTI(I).LT.1D-6) GOTO 110
5164 C...Find shape of multiplicity distribution above maximum.
5166 DO 120 I=INAVE+1,200
5167 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
5168 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
5169 IF(WTI(I).LT.1D-6) GOTO 130
5176 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
5177 & WTS/(WTS+WTI(1)/XNAVE)
5178 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
5179 IF(MSTP(133).GE.2) VINT(134)=XNAVE
5181 C...Pick multiplicity of pileup events.
5183 IF(MSTP(133).LE.0) THEN
5184 MINT(81)=MAX(1,MSTP(134))
5190 IF(WTR.LE.0D0) GOTO 150
5196 C...Format statement for error message.
5197 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
5198 &'crossing too large, ',1P,D12.4)
5203 C*********************************************************************
5206 C...Saves and restores parameter and cross section values for the
5207 C...3 gamma-p and 6 gamma-gamma alnternatives. Also makes random
5208 C...choice between alternatives.
5210 SUBROUTINE PYSAVE(ISAVE,IGA)
5212 C...Double precision and integer declarations.
5213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5214 INTEGER PYK,PYCHGE,PYCOMP
5216 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5217 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5218 COMMON/PYINT1/MINT(400),VINT(400)
5219 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5220 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5221 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/
5222 C...Local arrays and saved variables.
5223 DIMENSION NCP(10),NSUBCP(10,20),MSUBCP(10,20),COEFCP(10,20,20),
5224 &NGENCP(10,0:20,3),XSECCP(10,0:20,3),INTCP(10,20),RECP(10,20)
5225 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,INTCP,RECP
5227 C...Save list of subprocesses and cross-section information.
5231 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
5234 MSUBCP(IGA,ICP)=MSUB(I)
5236 COEFCP(IGA,ICP,J)=COEF(I,J)
5239 NGENCP(IGA,ICP,J)=NGEN(I,J)
5240 XSECCP(IGA,ICP,J)=XSEC(I,J)
5245 NGENCP(IGA,0,J)=NGEN(0,J)
5246 XSECCP(IGA,0,J)=XSEC(0,J)
5248 C...Save various common process variables.
5250 INTCP(IGA,J)=MINT(40+J)
5252 INTCP(IGA,11)=MINT(101)
5253 INTCP(IGA,12)=MINT(102)
5254 INTCP(IGA,13)=MINT(107)
5255 INTCP(IGA,14)=MINT(108)
5256 INTCP(IGA,15)=MINT(123)
5259 C...Save cross-section information only.
5260 ELSEIF(ISAVE.EQ.2) THEN
5261 DO 160 ICP=1,NCP(IGA)
5264 NGENCP(IGA,ICP,J)=NGEN(I,J)
5265 XSECCP(IGA,ICP,J)=XSEC(I,J)
5269 NGENCP(IGA,0,J)=NGEN(0,J)
5270 XSECCP(IGA,0,J)=XSEC(0,J)
5273 C...Choose between allowed alternatives.
5274 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
5277 DO 180 IG=1,MINT(121)
5278 XSUMCP=XSUMCP+XSECCP(IG,0,1)
5280 XSUMCP=XSUMCP*PYR(0)
5281 DO 190 IG=1,MINT(121)
5283 XSUMCP=XSUMCP-XSECCP(IG,0,1)
5284 IF(XSUMCP.LE.0D0) GOTO 200
5289 C...Restore cross-section information.
5293 DO 240 ICP=1,NCP(IGA)
5295 MSUB(I)=MSUBCP(IGA,ICP)
5297 COEF(I,J)=COEFCP(IGA,ICP,J)
5300 NGEN(I,J)=NGENCP(IGA,ICP,J)
5301 XSEC(I,J)=XSECCP(IGA,ICP,J)
5305 NGEN(0,J)=NGENCP(IGA,0,J)
5306 XSEC(0,J)=XSECCP(IGA,0,J)
5309 C...Restore various common process variables.
5311 MINT(40+J)=INTCP(IGA,J)
5313 MINT(101)=INTCP(IGA,11)
5314 MINT(102)=INTCP(IGA,12)
5315 MINT(107)=INTCP(IGA,13)
5316 MINT(108)=INTCP(IGA,14)
5317 MINT(123)=INTCP(IGA,15)
5321 C...Sum up cross-section info (for PYSTAT).
5322 ELSEIF(ISAVE.EQ.5) THEN
5333 DO 290 IG=1,MINT(121)
5334 DO 280 ICP=1,NCP(IG)
5336 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
5337 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
5338 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
5339 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
5341 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
5342 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
5343 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
5344 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
5351 C*********************************************************************
5354 C...Generates quantities characterizing the high-pT scattering at the
5355 C...parton level according to the matrix elements. Chooses incoming,
5356 C...reacting partons, their momentum fractions and one of the possible
5361 C...Double precision and integer declarations.
5362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5363 INTEGER PYK,PYCHGE,PYCOMP
5364 C...Parameter statement to help give large particle numbers.
5365 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
5367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5368 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5369 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
5370 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5371 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5372 COMMON/PYINT1/MINT(400),VINT(400)
5373 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5374 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5375 COMMON/PYINT4/MWID(500),WIDS(500,5)
5376 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5377 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5378 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
5379 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5380 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5381 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/PYMSSM/
5383 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
5385 C...Parameters and data used in elastic/diffractive treatment.
5386 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
5387 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5389 C...Initial values, specifically for (first) semihard interaction.
5396 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
5402 C...Choice of process type - first event of pileup.
5403 IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
5405 C...For gamma-p or gamma-gamma first pick between alternatives.
5406 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
5409 C...For gamma + gamma with different nature, flip at random.
5410 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
5411 & PYR(0).GT.0.5D0) THEN
5421 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
5424 C...Pick process type.
5425 RSUB=XSEC(0,1)*PYR(0)
5427 IF(MSUB(I).NE.1) GOTO 110
5430 IF(RSUB.LE.0D0) GOTO 120
5432 120 IF(ISUB.EQ.95) ISUB=96
5433 IF(ISUB.EQ.96) CALL PYMULT(2)
5435 C...Choice of inclusive process type - pileup events.
5436 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
5437 RSUB=VINT(131)*PYR(0)
5439 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
5440 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
5441 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
5442 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
5444 IF(ISUB.EQ.96) CALL PYMULT(2)
5446 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
5447 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
5448 IF(ISUB.EQ.96.AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
5449 &NGEN(97,1)=NGEN(97,1)+1
5453 C...Random choice of flavour for some SUSY processes.
5454 IF(ISUB.GE.201.AND.ISUB.LE.280) THEN
5455 C...~e_L ~nu_e or ~mu_L ~nu_mu.
5456 IF(ISUB.EQ.210) THEN
5457 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
5458 KFPR(ISUB,2)=KFPR(ISUB,1)+1
5459 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
5460 ELSEIF(ISUB.EQ.213) THEN
5461 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
5462 KFPR(ISUB,2)=KFPR(ISUB,1)
5463 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
5464 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
5465 IF(MOD(ISUB,2).EQ.0) THEN
5466 KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5468 KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5470 C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b.
5471 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
5472 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
5475 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
5478 ELSEIF(PYR(0).LT.0.5D0) THEN
5485 KFPR(ISUB,1)=KSU1+1+INT(5D0*PYR(0))
5486 KFPR(ISUB,2)=KSU2+1+INT(5D0*PYR(0))
5487 C...~q ~q(bar); ~q = ~d, ~u, ~s, ~c or ~b.
5488 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
5489 KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5490 KFPR(ISUB,2)=KFPR(ISUB,1)
5491 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
5492 KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5493 KFPR(ISUB,2)=KFPR(ISUB,1)
5497 C...Find resonances (explicit or implicit in cross-section).
5500 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5502 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
5503 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5505 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
5508 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5510 IF(MSTP(46).EQ.5) THEN
5513 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5515 ELSEIF(ISUB.EQ.194) THEN
5519 IF(CKMX.LE.0D0) CKMX=VINT(1)
5522 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5523 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5526 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5527 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5533 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
5535 IF(ISUB.EQ.194) KFR2=56
5537 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5538 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5539 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5540 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5541 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5546 ELSEIF(KFR2.NE.0) THEN
5557 C...Find product masses and minimum pT of process,
5558 C...optionally with broadening according to a truncated Breit-Wigner.
5563 IF(MINT(82).GE.2) VINT(71)=0D0
5565 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5569 IF(KFPR(ISUB,I).EQ.0) THEN
5570 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5572 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5575 C...This prevents SUSY/t particles from becoming too light.
5577 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5580 DO 130 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5581 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5582 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5583 & PMAS(PYCOMP(KFDP(IDC,2)),1)
5584 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5585 & PMAS(PYCOMP(KFDP(IDC,3)),1)
5586 PMMN(I)=MIN(PMMN(I),PMSUM)
5589 ELSEIF(KFLW.EQ.6) THEN
5590 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5597 CKIN(41)=MAX(PMMN(1),CKIN(41))
5598 CKIN(43)=MAX(PMMN(2),CKIN(43))
5599 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5602 IF(MINT(51).EQ.1) THEN
5603 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5613 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
5614 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5617 C...Prepare for additional variable choices in 2 -> 3.
5620 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5622 VINT(204)=PMAS(23,1)
5623 IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
5624 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
5625 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5629 C...Select incoming VDM particle (rho/omega/phi/J/psi).
5630 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
5631 &(MINT(123).EQ.2.OR.MINT(123).EQ.5.OR.MINT(123).EQ.7)) THEN
5632 VRN=PYR(0)*SIGT(0,0,5)
5633 IF(MINT(101).LE.1) THEN
5640 IF(MINT(102).LE.1) THEN
5651 VRN=VRN-SIGT(I1,I2,5)
5652 IF(VRN.LE.0D0) GOTO 170
5655 170 IF(MINT(101).GE.2) MINT(103)=KFV1
5656 IF(MINT(102).GE.2) MINT(104)=KFV2
5660 C...Elastic scattering or single or double diffractive scattering.
5662 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
5667 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
5669 VRN=PYR(0)*SIGT(0,0,JJ)
5670 IF(MINT(101).LE.1) THEN
5677 IF(MINT(102).LE.1) THEN
5688 VRN=VRN-SIGT(I1,I2,JJ)
5689 IF(VRN.LE.0D0) GOTO 200
5692 200 IF(MINT(101).GE.2) THEN
5696 IF(MINT(102).GE.2) THEN
5702 C...Side/sides of diffractive system.
5705 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
5706 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
5708 C...Find masses of particles and minimal masses of diffractive states.
5711 VINT(66+JT)=PDIF(JT)
5712 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
5719 SMRES1=(PMM(1)+PMRC)**2
5720 SMRES2=(PMM(2)+PMRC)**2
5722 C...Find elastic slope and lower limit diffractive slope.
5723 IHA=MAX(2,IABS(MINT(103))/110)
5725 IHB=MAX(2,IABS(MINT(104))/110)
5728 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
5729 ELSEIF(ISUB.EQ.92) THEN
5730 BMN=MAX(2D0,2D0*BHAD(IHB))
5731 ELSEIF(ISUB.EQ.93) THEN
5732 BMN=MAX(2D0,2D0*BHAD(IHA))
5733 ELSEIF(ISUB.EQ.94) THEN
5737 C...Determine maximum possible t range and coefficient of generation.
5738 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
5739 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5740 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5741 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5742 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5743 & (SQM1*SQM4-SQM2*SQM3)/SH
5744 THL=-0.5D0*(THA+THB)
5746 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
5748 C...Select diffractive mass/masses according to dm^2/m^2.
5750 IF(MINT(16+JT).EQ.0) THEN
5754 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
5755 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
5761 C..Additional mass factors, including resonance enhancement.
5762 IF(PDIF(3)+PDIF(4).GE.VINT(1)) GOTO 220
5764 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
5765 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5766 ELSEIF(ISUB.EQ.93) THEN
5767 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
5768 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5769 ELSEIF(ISUB.EQ.94) THEN
5770 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
5771 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
5772 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
5773 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 220
5776 C...Select t according to exp(Bmn*t) and correct to right slope.
5777 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
5780 BADD=2D0*ALP*LOG(SH/SQM3)
5781 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
5782 ELSEIF(ISUB.EQ.93) THEN
5783 BADD=2D0*ALP*LOG(SH/SQM4)
5784 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
5785 ELSEIF(ISUB.EQ.94) THEN
5786 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
5788 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 220
5791 C...Check whether m^2 and t choices are consistent.
5792 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5793 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5794 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5795 IF(THB.LE.1D-8) GOTO 220
5796 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5797 & (SQM1*SQM4-SQM2*SQM3)/SH
5798 THLM=-0.5D0*(THA+THB)
5800 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 220
5802 C...Information to output.
5805 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
5807 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
5811 C...Note: in the following, by In is meant the integral over the
5812 C...quantity multiplying coefficient cn.
5813 C...Choose tau according to h1(tau)/tau, where
5814 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
5815 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
5816 C...I1/I5*c5*1/(tau+tau_R') +
5817 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
5818 C...I1/I7*c7*tau/(1.-tau), and
5819 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
5820 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
5822 IF(MINT(51).NE.0) THEN
5823 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5832 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
5833 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
5834 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
5835 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
5837 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5838 & COEF(ISUB,5)) MTAU=6
5839 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5840 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
5841 CALL PYKMAP(1,MTAU,PYR(0))
5843 C...2 -> 3, 4 processes:
5844 C...Choose tau' according to h4(tau,tau')/tau', where
5845 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
5846 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
5847 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5849 IF(MINT(51).NE.0) THEN
5850 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5859 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
5860 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
5861 CALL PYKMAP(4,MTAUP,PYR(0))
5864 C...Choose y* according to h2(y*), where
5865 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
5866 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
5867 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
5868 C...and c1 + c2 + c3 + c4 + c5 = 1.
5870 IF(MINT(51).NE.0) THEN
5871 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5880 IF(RYST.GT.COEF(ISUB,8)) MYST=2
5881 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
5882 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
5883 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
5884 & COEF(ISUB,11)) MYST=5
5885 CALL PYKMAP(2,MYST,PYR(0))
5887 C...2 -> 2 processes:
5888 C...Choose cos(theta-hat) (cth) according to h3(cth), where
5889 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
5890 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
5891 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
5892 C...and c0 + c1 + c2 + c3 + c4 = 1.
5894 IF(MINT(51).NE.0) THEN
5895 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5902 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5905 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
5906 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
5907 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
5908 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
5909 & COEF(ISUB,16)) MCTH=5
5910 CALL PYKMAP(3,MCTH,PYR(0))
5913 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
5915 CALL PYKMAP(5,0,0D0)
5916 IF(MINT(51).NE.0) THEN
5917 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5926 C...Low-pT or multiple interactions (first semihard interaction).
5927 ELSEIF(ISTSB.EQ.9) THEN
5931 C...Generate user-defined process: kinematics plus weight.
5932 ELSEIF(ISTSB.EQ.11) THEN
5934 CALL PYUPEV(ISUB,SIGS)
5938 IF(MINT(82).EQ.1) THEN
5939 NGEN(0,1)=NGEN(0,1)-1
5940 NGEN(0,2)=NGEN(0,2)-1
5941 NGEN(ISUB,1)=NGEN(ISUB,1)-1
5943 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5947 C...Construct 'trivial' kinematical variables needed.
5950 VINT(41)=2D0*PUP(1,4)/VINT(1)
5951 VINT(42)=2D0*PUP(2,4)/VINT(1)
5952 VINT(21)=VINT(41)*VINT(42)
5953 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
5954 VINT(44)=VINT(21)*VINT(2)
5955 VINT(43)=SQRT(MAX(0D0,VINT(44)))
5957 VINT(55)=SQRT(MAX(0D0,VINT(56)))
5959 C...Construct other kinematical variables needed (approximately).
5962 VINT(45)=-0.5D0*VINT(44)
5963 VINT(46)=-0.5D0*VINT(44)
5973 IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+
5974 & PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(1)
5975 IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+
5978 VINT(47)=SQRT(VINT(48))
5980 C...Calculate parton distribution weights.
5981 IF(MINT(47).GE.2) THEN
5982 DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
5983 MINT(105)=MINT(102+I)
5984 MINT(109)=MINT(106+I)
5985 IF(MSTP(57).LE.1) THEN
5986 CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
5988 CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
5991 XSFX(I,KFL)=XPQ(KFL)
5997 C...Choose azimuthal angle.
5998 VINT(24)=PARU(2)*PYR(0)
6000 C...Check against user cuts on kinematics at parton level.
6002 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
6003 IF(MINT(51).NE.0) THEN
6004 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6011 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
6013 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
6016 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6025 C...Calculate differential cross-section for different subprocesses.
6026 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
6030 C...Multiply cross-section by user-defined weights.
6031 IF(MSTP(173).EQ.1) THEN
6034 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
6036 SIGLPT=PARP(173)*SIGLPT
6042 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
6043 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
6044 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
6047 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
6050 C...Calculations for Monte Carlo estimate of all cross-sections.
6051 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
6052 IF(MSTP(142).LE.1) THEN
6053 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6055 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
6057 ELSEIF(MINT(82).EQ.1) THEN
6058 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6060 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
6061 &XSEC(97,2)=XSEC(97,2)+SIGLPT
6063 C...Multiple interactions: store results of cross-section calculation.
6064 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
6069 C...Check that weight not negative.
6070 VIOL=SIGSWT/XSEC(ISUB,1)
6071 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
6072 IF(MSTP(123).LE.0) THEN
6073 IF(VIOL.LT.-1D-3) THEN
6074 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
6075 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6076 & VINT(22),VINT(23),VINT(26)
6080 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
6082 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
6083 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6084 & VINT(22),VINT(23),VINT(26)
6088 C...Weighting using estimate of maximum of differential cross-section.
6090 IF(VIOL.LT.PYR(0)) THEN
6091 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6094 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
6095 IF(VIOL.LT.PYR(0)) THEN
6097 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6101 RATND=SIGLPT/XSEC(95,1)
6102 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
6104 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6108 IF(VIOL.LT.PYR(0)) THEN
6109 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6114 C...Check for possible violation of estimated maximum of differential
6115 C...cross-section used in weighting.
6116 IF(MSTP(123).LE.0) THEN
6117 IF(VIOL.GT.1D0) THEN
6118 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
6119 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6120 & VINT(22),VINT(23),VINT(26)
6123 ELSEIF(MSTP(123).EQ.1) THEN
6124 IF(VIOL.GT.VINT(108)) THEN
6126 IF(VIOL.GT.1D0) THEN
6128 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6129 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6130 & VINT(22),VINT(23),VINT(26)
6133 ELSEIF(VIOL.GT.VINT(108)) THEN
6135 IF(VIOL.GT.1D0) THEN
6137 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
6138 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
6139 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
6140 & XSEC(0,1)=XSEC(0,1)+XDIF
6141 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6142 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6143 & VINT(22),VINT(23),VINT(26)
6145 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
6146 ELSEIF(ISUB.LE.99) THEN
6147 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
6149 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
6155 C...Multiple interactions: choose impact parameter.
6157 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
6158 &MSTP(82).GE.3) THEN
6160 IF(VINT(150).LT.PYR(0)) THEN
6161 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6169 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
6170 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
6171 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
6172 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
6174 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
6176 C...Choose flavour of reacting partons (and subprocess).
6177 IF(ISTSB.GE.11) GOTO 290
6180 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
6181 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
6182 &PYR(0).GT.RQQBAR)) THEN
6186 MINT(2)=ISIG(ICHN,3)
6187 RSIGS=RSIGS-SIGH(ICHN)
6188 IF(RSIGS.LE.0D0) GOTO 290
6191 C...Multiple interactions: choose qqbar preferentially at small pT.
6192 ELSEIF(ISUB.EQ.96) THEN
6195 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
6198 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
6201 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
6203 C...Low-pT: choose string drawing configuration.
6209 IF(RSIGS.GT.1D0) MINT(2)=2
6210 IF(RSIGS.GT.2D0) MINT(2)=3
6213 C...Reassign QCD process. Partons before initial state radiation.
6214 290 IF(MINT(2).GT.10) THEN
6216 MINT(2)=MOD(MINT(2),10)
6218 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
6229 C...Calculate x value of photon for parton inside photon inside e.
6234 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
6235 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
6236 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
6241 MINT(105)=MINT(102+JT)
6242 MINT(109)=MINT(106+JT)
6243 IF(MSTP(57).LE.1) THEN
6244 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
6246 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
6249 IF(MSTP(13).EQ.2) THEN
6250 Q2PMS=Q2HRD/PMAS(11,1)**2
6251 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
6254 XG=MIN(0.999999D0,XHRD/XE)
6255 IF(MSTP(57).LE.1) THEN
6256 CALL PYPDFU(22,XG,Q2HRD,XPQ)
6258 CALL PYPDFL(22,XG,Q2HRD,XPQ)
6260 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
6261 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
6262 IF(WT.LT.PYR(0)*WTMX) GOTO 300
6266 XSFX(JT,KFLS)=XPQ(KFLS)
6271 C...Pick scale where photon is resolved.
6272 IF(MINT(107).EQ.3) VINT(283)=PARP(15)**2*
6273 &(VINT(54)/PARP(15)**2)**PYR(0)
6274 IF(MINT(108).EQ.3) VINT(284)=PARP(15)**2*
6275 &(VINT(54)/PARP(15)**2)**PYR(0)
6276 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6278 C...Format statements for differential cross-section maximum violations.
6279 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
6280 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6281 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
6282 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
6283 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
6285 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
6286 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6287 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
6289 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
6290 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
6291 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
6296 C*********************************************************************
6299 C...Finds outgoing flavours and event type; sets up the kinematics
6300 C...and colour flow of the hard scattering
6304 C...Double precision and integer declarations
6305 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6306 INTEGER PYK,PYCHGE,PYCOMP
6307 C...Parameter statement to help give large particle numbers.
6308 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
6310 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6311 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6312 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6313 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
6314 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6315 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6316 COMMON/PYINT1/MINT(400),VINT(400)
6317 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6318 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6319 COMMON/PYINT4/MWID(500),WIDS(500,5)
6320 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6321 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
6322 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
6324 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
6325 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/
6326 C...Local arrays and saved variables
6327 DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2),
6328 &PHI(2),KUPPO(20),VINTSV(41:66)
6331 C...Read out process
6335 C...Restore information for low-pT processes
6336 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
6338 100 VINT(J)=VINTSV(J)
6341 C...Convert H' or A process into equivalent H one
6344 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
6347 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
6349 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
6350 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
6351 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
6352 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
6353 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
6354 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
6355 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
6356 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
6357 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
6360 C...Choice of subprocess, number of documentation lines
6362 IF(ISUB.EQ.95) IDOC=8
6363 IF(ISET(ISUB).EQ.5) IDOC=9
6364 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
6366 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
6375 C...Reset K, P and V vectors. Store incoming particles
6376 DO 120 JT=1,MSTP(126)+20
6389 P(I,J)=VINT(285+5*JT+J)
6395 C...Store incoming partons in their CM-frame
6398 SHP=VINT(26)*VINT(2)
6401 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
6406 K(I,3)=MINT(83)+2+JT
6407 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
6411 C...Copy incoming partons to documentation lines
6423 C...Choose new quark/lepton flavour for relevant annihilation graphs
6424 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58) THEN
6426 IF(ISUB.EQ.58) IGLGA=22
6427 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
6428 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
6429 DO 190 I=1,MDCY(IGLGA,3)
6430 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
6431 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
6432 IF(RKFL.LE.0D0) GOTO 200
6435 IF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
6436 & IABS(KFLF).GE.3) THEN
6437 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
6439 FACCIB=VINT(46)**2/PARU(155)**4
6440 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
6441 ELSEIF(ISUB.EQ.54) THEN
6442 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
6443 ELSEIF(ISUB.EQ.58) THEN
6444 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
6448 C...Final state flavours and colour flow: default values
6455 KCS=ISIGN(1,MINT(15))
6457 IF(ISET(ISUB).EQ.11) THEN
6458 C...User-defined processes: find products
6461 IF(KUP(IUP,1).NE.1) THEN
6462 ELSEIF(IRUP.LE.5) THEN
6464 MINT(20+IRUP)=KUP(IUP,2)
6468 ELSEIF(ISUB.LE.10) THEN
6470 C...f + fbar -> gamma*/Z0
6473 ELSEIF(ISUB.EQ.2) THEN
6474 C...f + fbar' -> W+/-
6475 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6476 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6477 KFRES=ISIGN(24,KCH1+KCH2)
6479 ELSEIF(ISUB.EQ.3) THEN
6480 C...f + fbar -> h0 (or H0, or A0)
6483 ELSEIF(ISUB.EQ.4) THEN
6484 C...gamma + W+/- -> W+/-
6486 ELSEIF(ISUB.EQ.5) THEN
6491 PMQ(1)=PYMASS(MINT(21))
6492 PMQ(2)=PYMASS(MINT(22))
6493 220 JT=INT(1.5D0+PYR(0))
6494 ZMIN=2D0*PMQ(JT)/SHPR
6495 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6496 & (SHPR*(SHPR-PMQ(3-JT)))
6497 ZMAX=MIN(1D0-XH,ZMAX)
6498 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6499 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6500 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
6501 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6502 IF(SQC1.LT.1.D-8) GOTO 220
6504 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6505 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6506 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6507 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6508 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6509 IF(SQC1.LT.1.D-8) GOTO 220
6511 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6512 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6513 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6516 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6517 & SQRT(1D0-CTHE(2)**2)*CPHI
6519 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6520 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6521 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6522 & PMQ(3-JT)**2/SHP))
6523 ZMIN=2D0*PMQ(3-JT)/SHPR
6524 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6525 ZMAX=MIN(1D0-XH,ZMAX)
6526 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
6530 ELSEIF(ISUB.EQ.6) THEN
6531 C...Z0 + W+/- -> W+/-
6533 ELSEIF(ISUB.EQ.7) THEN
6536 ELSEIF(ISUB.EQ.8) THEN
6543 RVCKM=VINT(180+I)*PYR(0)
6546 IPM=(5-ISIGN(1,I))/2
6548 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
6549 MINT(20+JT)=ISIGN(IB,I)
6550 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6551 IF(RVCKM.LE.0D0) GOTO 250
6554 IB=2*((IA+1)/2)-1+MOD(IA,2)
6555 MINT(20+JT)=ISIGN(IB,I)
6557 250 PMQ(JT)=PYMASS(MINT(20+JT))
6559 JT=INT(1.5D0+PYR(0))
6560 ZMIN=2D0*PMQ(JT)/SHPR
6561 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6562 & (SHPR*(SHPR-PMQ(3-JT)))
6563 ZMAX=MIN(1D0-XH,ZMAX)
6564 IF(ZMIN.GE.ZMAX) GOTO 230
6565 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6566 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6567 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
6568 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6569 IF(SQC1.LT.1.D-8) GOTO 230
6571 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6572 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6573 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6574 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6575 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6576 IF(SQC1.LT.1.D-8) GOTO 230
6578 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6579 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6580 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6583 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6584 & SQRT(1D0-CTHE(2)**2)*CPHI
6586 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6587 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6588 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6589 & PMQ(3-JT)**2/SHP))
6590 ZMIN=2D0*PMQ(3-JT)/SHPR
6591 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6592 ZMAX=MIN(1D0-XH,ZMAX)
6593 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
6597 ELSEIF(ISUB.EQ.10) THEN
6598 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
6599 IF(MINT(2).EQ.1) THEN
6602 C...W exchange: need to mix flavours according to CKM matrix
6607 RVCKM=VINT(180+I)*PYR(0)
6610 IPM=(5-ISIGN(1,I))/2
6612 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
6613 MINT(20+JT)=ISIGN(IB,I)
6614 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6615 IF(RVCKM.LE.0D0) GOTO 280
6618 IB=2*((IA+1)/2)-1+MOD(IA,2)
6619 MINT(20+JT)=ISIGN(IB,I)
6626 ELSEIF(ISUB.LE.20) THEN
6628 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
6630 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
6632 ELSEIF(ISUB.EQ.12) THEN
6633 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
6634 MINT(21)=ISIGN(KFLF,MINT(15))
6638 ELSEIF(ISUB.EQ.13) THEN
6639 C...f + fbar -> g + g; th arbitrary
6644 ELSEIF(ISUB.EQ.14) THEN
6645 C...f + fbar -> g + gamma; th arbitrary
6646 IF(PYR(0).GT.0.5D0) JS=2
6651 ELSEIF(ISUB.EQ.15) THEN
6652 C...f + fbar -> g + Z0; th arbitrary
6653 IF(PYR(0).GT.0.5D0) JS=2
6658 ELSEIF(ISUB.EQ.16) THEN
6659 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6660 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6661 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6662 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6664 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6667 ELSEIF(ISUB.EQ.17) THEN
6668 C...f + fbar -> g + h0; th arbitrary
6669 IF(PYR(0).GT.0.5D0) JS=2
6674 ELSEIF(ISUB.EQ.18) THEN
6675 C...f + fbar -> gamma + gamma; th arbitrary
6679 ELSEIF(ISUB.EQ.19) THEN
6680 C...f + fbar -> gamma + Z0; th arbitrary
6681 IF(PYR(0).GT.0.5D0) JS=2
6685 ELSEIF(ISUB.EQ.20) THEN
6686 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
6687 C...(p(fbar')-p(W+))**2
6688 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6689 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6690 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6692 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6695 ELSEIF(ISUB.LE.30) THEN
6697 C...f + fbar -> gamma + h0; th arbitrary
6698 IF(PYR(0).GT.0.5D0) JS=2
6702 ELSEIF(ISUB.EQ.22) THEN
6703 C...f + fbar -> Z0 + Z0; th arbitrary
6707 ELSEIF(ISUB.EQ.23) THEN
6708 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6709 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6710 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6711 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6713 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6715 ELSEIF(ISUB.EQ.24) THEN
6716 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
6717 IF(PYR(0).GT.0.5D0) JS=2
6721 ELSEIF(ISUB.EQ.25) THEN
6722 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
6723 MINT(21)=-ISIGN(24,MINT(15))
6726 ELSEIF(ISUB.EQ.26) THEN
6727 C...f + fbar' -> W+/- + h0 (or H0, or A0);
6728 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6729 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6730 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6731 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
6732 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
6735 ELSEIF(ISUB.EQ.27) THEN
6736 C...f + fbar -> h0 + h0
6738 ELSEIF(ISUB.EQ.28) THEN
6739 C...f + g -> f + g; th = (p(f)-p(f))**2
6741 IF(MINT(15).EQ.21) KCC=KCC+2
6742 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
6743 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
6745 ELSEIF(ISUB.EQ.29) THEN
6746 C...f + g -> f + gamma; th = (p(f)-p(f))**2
6747 IF(MINT(15).EQ.21) JS=2
6750 KCS=ISIGN(1,MINT(14+JS))
6752 ELSEIF(ISUB.EQ.30) THEN
6753 C...f + g -> f + Z0; th = (p(f)-p(f))**2
6754 IF(MINT(15).EQ.21) JS=2
6757 KCS=ISIGN(1,MINT(14+JS))
6760 ELSEIF(ISUB.LE.40) THEN
6762 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
6763 IF(MINT(15).EQ.21) JS=2
6766 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6767 RVCKM=VINT(180+I)*PYR(0)
6770 IPM=(5-ISIGN(1,I))/2
6772 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
6773 MINT(20+JS)=ISIGN(IB,I)
6774 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6775 IF(RVCKM.LE.0D0) GOTO 300
6778 KCS=ISIGN(1,MINT(14+JS))
6780 ELSEIF(ISUB.EQ.32) THEN
6781 C...f + g -> f + h0; th = (p(f)-p(f))**2
6782 IF(MINT(15).EQ.21) JS=2
6785 KCS=ISIGN(1,MINT(14+JS))
6787 ELSEIF(ISUB.EQ.33) THEN
6788 C...f + gamma -> f + g; th=(p(f)-p(f))**2
6789 IF(MINT(15).EQ.22) JS=2
6792 KCS=ISIGN(1,MINT(14+JS))
6794 ELSEIF(ISUB.EQ.34) THEN
6795 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
6796 IF(MINT(15).EQ.22) JS=2
6798 KCS=ISIGN(1,MINT(14+JS))
6800 ELSEIF(ISUB.EQ.35) THEN
6801 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
6802 IF(MINT(15).EQ.22) JS=2
6806 ELSEIF(ISUB.EQ.36) THEN
6807 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
6808 IF(MINT(15).EQ.22) JS=2
6811 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6813 RVCKM=VINT(180+I)*PYR(0)
6816 IPM=(5-ISIGN(1,I))/2
6818 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
6819 MINT(20+JS)=ISIGN(IB,I)
6820 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6821 IF(RVCKM.LE.0D0) GOTO 320
6824 IB=2*((IA+1)/2)-1+MOD(IA,2)
6825 MINT(20+JS)=ISIGN(IB,I)
6829 ELSEIF(ISUB.EQ.37) THEN
6830 C...f + gamma -> f + h0
6832 ELSEIF(ISUB.EQ.38) THEN
6835 ELSEIF(ISUB.EQ.39) THEN
6836 C...f + Z0 -> f + gamma
6838 ELSEIF(ISUB.EQ.40) THEN
6839 C...f + Z0 -> f + Z0
6842 ELSEIF(ISUB.LE.50) THEN
6844 C...f + Z0 -> f' + W+/-
6846 ELSEIF(ISUB.EQ.42) THEN
6847 C...f + Z0 -> f + h0
6849 ELSEIF(ISUB.EQ.43) THEN
6850 C...f + W+/- -> f' + g
6852 ELSEIF(ISUB.EQ.44) THEN
6853 C...f + W+/- -> f' + gamma
6855 ELSEIF(ISUB.EQ.45) THEN
6856 C...f + W+/- -> f' + Z0
6858 ELSEIF(ISUB.EQ.46) THEN
6859 C...f + W+/- -> f' + W+/-
6861 ELSEIF(ISUB.EQ.47) THEN
6862 C...f + W+/- -> f' + h0
6864 ELSEIF(ISUB.EQ.48) THEN
6867 ELSEIF(ISUB.EQ.49) THEN
6868 C...f + h0 -> f + gamma
6870 ELSEIF(ISUB.EQ.50) THEN
6871 C...f + h0 -> f + Z0
6874 ELSEIF(ISUB.LE.60) THEN
6876 C...f + h0 -> f' + W+/-
6878 ELSEIF(ISUB.EQ.52) THEN
6879 C...f + h0 -> f + h0
6881 ELSEIF(ISUB.EQ.53) THEN
6882 C...g + g -> f + fbar; th arbitrary
6883 KCS=(-1)**INT(1.5D0+PYR(0))
6884 MINT(21)=ISIGN(KFLF,KCS)
6888 ELSEIF(ISUB.EQ.54) THEN
6889 C...g + gamma -> f + fbar; th arbitrary
6890 KCS=(-1)**INT(1.5D0+PYR(0))
6891 MINT(21)=ISIGN(KFLF,KCS)
6894 IF(MINT(16).EQ.21) KCC=28
6896 ELSEIF(ISUB.EQ.55) THEN
6897 C...g + Z0 -> f + fbar
6899 ELSEIF(ISUB.EQ.56) THEN
6900 C...g + W+/- -> f + fbar'
6902 ELSEIF(ISUB.EQ.57) THEN
6903 C...g + h0 -> f + fbar
6905 ELSEIF(ISUB.EQ.58) THEN
6906 C...gamma + gamma -> f + fbar; th arbitrary
6907 KCS=(-1)**INT(1.5D0+PYR(0))
6908 MINT(21)=ISIGN(KFLF,KCS)
6912 ELSEIF(ISUB.EQ.59) THEN
6913 C...gamma + Z0 -> f + fbar
6915 ELSEIF(ISUB.EQ.60) THEN
6916 C...gamma + W+/- -> f + fbar'
6919 ELSEIF(ISUB.LE.70) THEN
6921 C...gamma + h0 -> f + fbar
6923 ELSEIF(ISUB.EQ.62) THEN
6924 C...Z0 + Z0 -> f + fbar
6926 ELSEIF(ISUB.EQ.63) THEN
6927 C...Z0 + W+/- -> f + fbar'
6929 ELSEIF(ISUB.EQ.64) THEN
6930 C...Z0 + h0 -> f + fbar
6932 ELSEIF(ISUB.EQ.65) THEN
6933 C...W+ + W- -> f + fbar
6935 ELSEIF(ISUB.EQ.66) THEN
6936 C...W+/- + h0 -> f + fbar'
6938 ELSEIF(ISUB.EQ.67) THEN
6939 C...h0 + h0 -> f + fbar
6941 ELSEIF(ISUB.EQ.68) THEN
6942 C...g + g -> g + g; th arbitrary
6944 KCS=(-1)**INT(1.5D0+PYR(0))
6946 ELSEIF(ISUB.EQ.69) THEN
6947 C...gamma + gamma -> W+ + W-; th arbitrary
6952 ELSEIF(ISUB.EQ.70) THEN
6953 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
6954 IF(MINT(15).EQ.22) MINT(21)=23
6955 IF(MINT(16).EQ.22) MINT(22)=23
6959 ELSEIF(ISUB.LE.80) THEN
6960 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
6961 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
6965 PMQ(1)=PYMASS(MINT(21))
6966 PMQ(2)=PYMASS(MINT(22))
6967 330 JT=INT(1.5D0+PYR(0))
6968 ZMIN=2D0*PMQ(JT)/SHPR
6969 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6970 & (SHPR*(SHPR-PMQ(3-JT)))
6971 ZMAX=MIN(1D0-XH,ZMAX)
6972 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6973 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6974 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
6975 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6976 IF(SQC1.LT.1.D-8) GOTO 330
6978 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6979 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6980 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6981 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6982 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6983 IF(SQC1.LT.1.D-8) GOTO 330
6985 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6986 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6987 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6990 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6991 & SQRT(1D0-CTHE(2)**2)*CPHI
6993 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6994 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6995 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6996 & PMQ(3-JT)**2/SHP))
6997 ZMIN=2D0*PMQ(3-JT)/SHPR
6998 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6999 ZMAX=MIN(1D0-XH,ZMAX)
7000 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
7003 ELSEIF(ISUB.EQ.73) THEN
7004 C...Z0 + W+/- -> Z0 + W+/-
7011 RVCKM=VINT(180+I)*PYR(0)
7014 IPM=(5-ISIGN(1,I))/2
7016 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
7017 MINT(20+JT)=ISIGN(IB,I)
7018 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7019 IF(RVCKM.LE.0D0) GOTO 360
7022 IB=2*((IA+1)/2)-1+MOD(IA,2)
7023 MINT(20+JT)=ISIGN(IB,I)
7025 360 PMQ(JT)=PYMASS(MINT(20+JT))
7026 MINT(23-JT)=MINT(17-JT)
7027 PMQ(3-JT)=PYMASS(MINT(23-JT))
7028 JT=INT(1.5D0+PYR(0))
7029 ZMIN=2D0*PMQ(JT)/SHPR
7030 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7031 & (SHPR*(SHPR-PMQ(3-JT)))
7032 ZMAX=MIN(1D0-XH,ZMAX)
7033 IF(ZMIN.GE.ZMAX) GOTO 340
7034 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7035 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7036 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
7037 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7038 IF(SQC1.LT.1.D-8) GOTO 340
7040 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7041 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7042 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7043 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7044 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7045 IF(SQC1.LT.1.D-8) GOTO 340
7047 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7048 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7049 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7052 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7053 & SQRT(1D0-CTHE(2)**2)*CPHI
7055 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7056 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7057 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7058 & PMQ(3-JT)**2/SHP))
7059 ZMIN=2D0*PMQ(3-JT)/SHPR
7060 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7061 ZMAX=MIN(1D0-XH,ZMAX)
7062 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
7065 ELSEIF(ISUB.EQ.74) THEN
7066 C...Z0 + h0 -> Z0 + h0
7068 ELSEIF(ISUB.EQ.75) THEN
7069 C...W+ + W- -> gamma + gamma
7071 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
7072 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
7078 RVCKM=VINT(180+I)*PYR(0)
7081 IPM=(5-ISIGN(1,I))/2
7083 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
7084 MINT(20+JT)=ISIGN(IB,I)
7085 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7086 IF(RVCKM.LE.0D0) GOTO 390
7089 IB=2*((IA+1)/2)-1+MOD(IA,2)
7090 MINT(20+JT)=ISIGN(IB,I)
7092 390 PMQ(JT)=PYMASS(MINT(20+JT))
7094 JT=INT(1.5D0+PYR(0))
7095 ZMIN=2D0*PMQ(JT)/SHPR
7096 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7097 & (SHPR*(SHPR-PMQ(3-JT)))
7098 ZMAX=MIN(1D0-XH,ZMAX)
7099 IF(ZMIN.GE.ZMAX) GOTO 370
7100 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7101 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7102 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
7103 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7104 IF(SQC1.LT.1.D-8) GOTO 370
7106 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7107 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7108 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7109 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7110 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7111 IF(SQC1.LT.1.D-8) GOTO 370
7113 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7114 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7115 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7118 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7119 & SQRT(1D0-CTHE(2)**2)*CPHI
7121 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7122 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7123 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7124 & PMQ(3-JT)**2/SHP))
7125 ZMIN=2D0*PMQ(3-JT)/SHPR
7126 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7127 ZMAX=MIN(1D0-XH,ZMAX)
7128 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
7131 ELSEIF(ISUB.EQ.78) THEN
7132 C...W+/- + h0 -> W+/- + h0
7134 ELSEIF(ISUB.EQ.79) THEN
7135 C...h0 + h0 -> h0 + h0
7137 ELSEIF(ISUB.EQ.80) THEN
7138 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
7139 IF(MINT(15).EQ.22) JS=2
7142 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
7144 MINT(20+JS)=ISIGN(IB,I)
7148 ELSEIF(ISUB.LE.90) THEN
7150 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
7151 MINT(21)=ISIGN(MINT(55),MINT(15))
7155 ELSEIF(ISUB.EQ.82) THEN
7156 C...g + g -> Q + Qbar; th arbitrary
7157 KCS=(-1)**INT(1.5D0+PYR(0))
7158 MINT(21)=ISIGN(MINT(55),KCS)
7162 ELSEIF(ISUB.EQ.83) THEN
7163 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
7165 IF(MINT(2).EQ.2) KFOLD=MINT(15)
7167 IF(KFAOLD.GT.10) THEN
7168 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
7170 RCKM=VINT(180+KFOLD)*PYR(0)
7171 IPM=(5-ISIGN(1,KFOLD))/2
7172 KFANEW=-MOD(KFAOLD+1,2)
7174 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
7175 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
7176 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
7177 & VCKM(KFAOLD/2,(KFANEW+1)/2)
7178 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
7179 & VCKM(KFANEW/2,(KFAOLD+1)/2)
7181 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
7183 IF(MINT(2).EQ.1) THEN
7184 MINT(21)=ISIGN(MINT(55),MINT(15))
7185 MINT(22)=ISIGN(KFANEW,MINT(16))
7187 MINT(21)=ISIGN(KFANEW,MINT(15))
7188 MINT(22)=ISIGN(MINT(55),MINT(16))
7193 ELSEIF(ISUB.EQ.84) THEN
7194 C...g + gamma -> Q + Qbar; th arbitary
7195 KCS=(-1)**INT(1.5D0+PYR(0))
7196 MINT(21)=ISIGN(MINT(55),KCS)
7199 IF(MINT(16).EQ.21) KCC=28
7201 ELSEIF(ISUB.EQ.85) THEN
7202 C...gamma + gamma -> F + Fbar; th arbitary
7203 KCS=(-1)**INT(1.5D0+PYR(0))
7204 MINT(21)=ISIGN(MINT(56),KCS)
7208 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
7209 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
7210 MINT(21)=KFPR(ISUB,1)
7211 MINT(22)=KFPR(ISUB,2)
7213 KCS=(-1)**INT(1.5D0+PYR(0))
7216 ELSEIF(ISUB.LE.100) THEN
7218 C...Low-pT ( = energyless g + g -> g + g)
7220 KCS=(-1)**INT(1.5D0+PYR(0))
7222 ELSEIF(ISUB.EQ.96) THEN
7223 C...Multiple interactions (should be reassigned to QCD process)
7226 ELSEIF(ISUB.LE.110) THEN
7227 IF(ISUB.EQ.101) THEN
7228 C...g + g -> gamma*/Z0
7232 ELSEIF(ISUB.EQ.102) THEN
7233 C...g + g -> h0 (or H0, or A0)
7237 ELSEIF(ISUB.EQ.103) THEN
7238 C...gamma + gamma -> h0 (or H0, or A0)
7242 ELSEIF(ISUB.EQ.106) THEN
7243 C...g + g -> J/Psi + gamma
7244 MINT(21)=KFPR(ISUB,1)
7245 MINT(22)=KFPR(ISUB,2)
7248 ELSEIF(ISUB.EQ.107) THEN
7249 C...g + gamma -> J/Psi + g
7250 MINT(21)=KFPR(ISUB,1)
7251 MINT(22)=KFPR(ISUB,2)
7253 IF(MINT(16).EQ.22) KCC=33
7255 ELSEIF(ISUB.EQ.108) THEN
7256 C...gamma + gamma -> J/Psi + gamma
7257 MINT(21)=KFPR(ISUB,1)
7258 MINT(22)=KFPR(ISUB,2)
7260 ELSEIF(ISUB.EQ.110) THEN
7261 C...f + fbar -> gamma + h0; th arbitrary
7262 IF(PYR(0).GT.0.5D0) JS=2
7267 ELSEIF(ISUB.LE.120) THEN
7268 IF(ISUB.EQ.111) THEN
7269 C...f + fbar -> g + h0; th arbitrary
7270 IF(PYR(0).GT.0.5D0) JS=2
7275 ELSEIF(ISUB.EQ.112) THEN
7276 C...f + g -> f + h0; th = (p(f) - p(f))**2
7277 IF(MINT(15).EQ.21) JS=2
7280 KCS=ISIGN(1,MINT(14+JS))
7282 ELSEIF(ISUB.EQ.113) THEN
7283 C...g + g -> g + h0; th arbitrary
7284 IF(PYR(0).GT.0.5D0) JS=2
7287 KCS=(-1)**INT(1.5D0+PYR(0))
7289 ELSEIF(ISUB.EQ.114) THEN
7290 C...g + g -> gamma + gamma; th arbitrary
7291 IF(PYR(0).GT.0.5D0) JS=2
7296 ELSEIF(ISUB.EQ.115) THEN
7297 C...g + g -> g + gamma; th arbitrary
7298 IF(PYR(0).GT.0.5D0) JS=2
7301 KCS=(-1)**INT(1.5D0+PYR(0))
7303 ELSEIF(ISUB.EQ.116) THEN
7304 C...g + g -> gamma + Z0
7306 ELSEIF(ISUB.EQ.117) THEN
7307 C...g + g -> Z0 + Z0
7309 ELSEIF(ISUB.EQ.118) THEN
7310 C...g + g -> W+ + W-
7313 ELSEIF(ISUB.LE.140) THEN
7314 IF(ISUB.EQ.121) THEN
7315 C...g + g -> Q + Qbar + h0
7316 KCS=(-1)**INT(1.5D0+PYR(0))
7317 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
7319 KCC=11+INT(0.5D0+PYR(0))
7322 ELSEIF(ISUB.EQ.122) THEN
7323 C...q + qbar -> Q + Qbar + h0
7324 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
7329 ELSEIF(ISUB.EQ.123) THEN
7330 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
7335 ELSEIF(ISUB.EQ.124) THEN
7336 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
7342 RVCKM=VINT(180+I)*PYR(0)
7345 IPM=(5-ISIGN(1,I))/2
7347 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
7348 MINT(20+JT)=ISIGN(IB,I)
7349 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7350 IF(RVCKM.LE.0D0) GOTO 430
7353 IB=2*((IA+1)/2)-1+MOD(IA,2)
7354 MINT(20+JT)=ISIGN(IB,I)
7360 ELSEIF(ISUB.EQ.131) THEN
7361 C...g + g -> Z0 + q + qbar
7364 ELSEIF(ISUB.LE.160) THEN
7365 IF(ISUB.EQ.141) THEN
7366 C...f + fbar -> gamma*/Z0/Z'0
7369 ELSEIF(ISUB.EQ.142) THEN
7370 C...f + fbar' -> W'+/-
7371 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7372 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7373 KFRES=ISIGN(34,KCH1+KCH2)
7375 ELSEIF(ISUB.EQ.143) THEN
7376 C...f + fbar' -> H+/-
7377 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7378 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7379 KFRES=ISIGN(37,KCH1+KCH2)
7381 ELSEIF(ISUB.EQ.144) THEN
7383 KFRES=ISIGN(40,MINT(15)+MINT(16))
7385 ELSEIF(ISUB.EQ.145) THEN
7386 C...q + l -> LQ (leptoquark)
7387 IF(IABS(MINT(16)).LE.8) JS=2
7388 KFRES=ISIGN(39,MINT(14+JS))
7390 KCS=ISIGN(1,MINT(14+JS))
7392 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
7393 C...q + g -> q* (excited quark)
7394 IF(MINT(15).EQ.21) JS=2
7395 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
7397 KCS=ISIGN(1,MINT(14+JS))
7399 ELSEIF(ISUB.EQ.149) THEN
7400 C...g + g -> eta_techni
7403 KCS=(-1)**INT(1.5D0+PYR(0))
7406 ELSEIF(ISUB.LE.200) THEN
7407 IF(ISUB.EQ.161) THEN
7408 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
7409 IF(MINT(15).EQ.21) JS=2
7412 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
7413 IB=IA+MOD(IA,2)-MOD(IA+1,2)
7414 MINT(20+JS)=ISIGN(IB,I)
7416 KCS=ISIGN(1,MINT(14+JS))
7418 ELSEIF(ISUB.EQ.162) THEN
7419 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
7420 IF(MINT(15).EQ.21) JS=2
7421 MINT(20+JS)=ISIGN(39,MINT(14+JS))
7422 KFLQL=KFDP(MDCY(39,2),2)
7423 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
7425 KCS=ISIGN(1,MINT(14+JS))
7427 ELSEIF(ISUB.EQ.163) THEN
7428 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
7429 KCS=(-1)**INT(1.5D0+PYR(0))
7430 MINT(21)=ISIGN(39,KCS)
7434 ELSEIF(ISUB.EQ.164) THEN
7435 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
7436 MINT(21)=ISIGN(39,MINT(15))
7440 ELSEIF(ISUB.EQ.165) THEN
7441 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
7442 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7445 ELSEIF(ISUB.EQ.166) THEN
7446 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
7447 IF(MOD(MINT(15),2).EQ.0) THEN
7448 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
7449 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
7451 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7452 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
7455 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
7456 C...q + q' -> q" + q* (excited quark)
7458 KFQEXC=MOD(KFQSTR,KEXCIT)
7460 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
7461 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
7462 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
7465 ELSEIF(ISUB.EQ.191) THEN
7466 C...f + fbar -> rho_tech0.
7469 ELSEIF(ISUB.EQ.192) THEN
7470 C...f + fbar' -> rho_tech+/-
7471 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7472 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7473 KFRES=ISIGN(55,KCH1+KCH2)
7475 ELSEIF(ISUB.EQ.193) THEN
7476 C...f + fbar -> omega_tech0.
7479 ELSEIF(ISUB.EQ.194) THEN
7480 C...f + fbar -> f' + fbar' via mixture of s-channel
7481 C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
7482 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7487 ELSEIF(ISUB.LE.215) THEN
7488 IF(ISUB.EQ.201) THEN
7489 C...f + fbar -> ~e_L + ~e_Lbar
7490 MINT(21)=ISIGN(KSUSY1+11,KCS)
7493 ELSEIF(ISUB.EQ.202) THEN
7494 C...f + fbar -> ~e_R + ~e_Rbar
7495 MINT(21)=ISIGN(KSUSY2+11,KCS)
7498 ELSEIF(ISUB.EQ.203) THEN
7499 C...f + fbar -> ~e_R + ~e_Lbar
7501 IF(MINT(2).EQ.2) KCS=-1
7502 MINT(21)=ISIGN(KSUSY1+11,KCS)
7503 MINT(22)=-ISIGN(KSUSY2+11,KCS)
7505 ELSEIF(ISUB.EQ.204) THEN
7506 C...f + fbar -> ~mu_L + ~mu_Lbar
7507 MINT(21)=ISIGN(KSUSY1+13,KCS)
7510 ELSEIF(ISUB.EQ.205) THEN
7511 C...f + fbar -> ~mu_R + ~mu_Rbar
7512 MINT(21)=ISIGN(KSUSY2+13,KCS)
7515 ELSEIF(ISUB.EQ.206) THEN
7516 C...f + fbar -> ~mu_L + ~mu_Rbar
7518 IF(MINT(2).EQ.2) KCS=-1
7519 MINT(21)=ISIGN(KSUSY1+13,KCS)
7520 MINT(22)=-ISIGN(KSUSY2+13,KCS)
7522 ELSEIF(ISUB.EQ.207) THEN
7523 C...f + fbar -> ~tau_1 + ~tau_1bar
7524 MINT(21)=ISIGN(KSUSY1+15,KCS)
7527 ELSEIF(ISUB.EQ.208) THEN
7528 C...f + fbar -> ~tau_2 + ~tau_2bar
7529 MINT(21)=ISIGN(KSUSY2+15,KCS)
7532 ELSEIF(ISUB.EQ.209) THEN
7533 C...f + fbar -> ~tau_1 + ~tau_2bar
7535 IF(MINT(2).EQ.2) KCS=-1
7536 MINT(21)=ISIGN(KSUSY1+15,KCS)
7537 MINT(22)=-ISIGN(KSUSY2+15,KCS)
7539 ELSEIF(ISUB.EQ.210) THEN
7540 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
7541 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7542 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7543 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
7544 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
7546 ELSEIF(ISUB.EQ.211) THEN
7547 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
7548 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7549 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7550 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
7551 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7553 ELSEIF(ISUB.EQ.212) THEN
7554 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
7555 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7556 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7557 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
7558 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7560 ELSEIF(ISUB.EQ.213) THEN
7561 C...f + fbar -> ~nul + ~nulbar
7562 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7565 ELSEIF(ISUB.EQ.214) THEN
7566 C...f + fbar -> ~nutau + ~nutaubar
7567 MINT(21)=ISIGN(KSUSY1+16,KCS)
7571 ELSEIF(ISUB.LE.225) THEN
7572 IF(ISUB.EQ.216) THEN
7573 C...f + fbar -> ~chi01 + ~chi01
7577 ELSEIF(ISUB.EQ.217) THEN
7578 C...f + fbar -> ~chi02 + ~chi02
7582 ELSEIF(ISUB.EQ.218 ) THEN
7583 C...f + fbar -> ~chi03 + ~chi03
7587 ELSEIF(ISUB.EQ.219 ) THEN
7588 C...f + fbar -> ~chi04 + ~chi04
7592 ELSEIF(ISUB.EQ.220 ) THEN
7593 C...f + fbar -> ~chi01 + ~chi02
7594 IF(PYR(0).GT.0.5D0) JS=2
7595 MINT(20+JS)=KSUSY1+22
7596 MINT(23-JS)=KSUSY1+23
7598 ELSEIF(ISUB.EQ.221 ) THEN
7599 C...f + fbar -> ~chi01 + ~chi03
7600 IF(PYR(0).GT.0.5D0) JS=2
7601 MINT(20+JS)=KSUSY1+22
7602 MINT(23-JS)=KSUSY1+25
7604 ELSEIF(ISUB.EQ.222) THEN
7605 C...f + fbar -> ~chi01 + ~chi04
7606 IF(PYR(0).GT.0.5D0) JS=2
7607 MINT(20+JS)=KSUSY1+22
7608 MINT(23-JS)=KSUSY1+35
7610 ELSEIF(ISUB.EQ.223) THEN
7611 C...f + fbar -> ~chi02 + ~chi03
7612 IF(PYR(0).GT.0.5D0) JS=2
7613 MINT(20+JS)=KSUSY1+23
7614 MINT(23-JS)=KSUSY1+25
7616 ELSEIF(ISUB.EQ.224) THEN
7617 C...f + fbar -> ~chi02 + ~chi04
7618 IF(PYR(0).GT.0.5D0) JS=2
7619 MINT(20+JS)=KSUSY1+23
7620 MINT(23-JS)=KSUSY1+35
7622 ELSEIF(ISUB.EQ.225) THEN
7623 C...f + fbar -> ~chi03 + ~chi04
7624 IF(PYR(0).GT.0.5D0) JS=2
7625 MINT(20+JS)=KSUSY1+25
7626 MINT(23-JS)=KSUSY1+35
7629 ELSEIF(ISUB.LE.236) THEN
7630 IF(ISUB.EQ.226) THEN
7631 C...f + fbar -> ~chi+-1 + ~chi-+1
7632 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
7633 MINT(21)=ISIGN(KSUSY1+24,MINT(15))
7636 ELSEIF(ISUB.EQ.227) THEN
7637 C...f + fbar -> ~chi+-2 + ~chi-+2
7638 MINT(21)=ISIGN(KSUSY1+37,MINT(15))
7641 ELSEIF(ISUB.EQ.228) THEN
7642 C...f + fbar -> ~chi+-1 + ~chi-+2
7643 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
7644 C...js=1 if pyr<.5, js=2 if pyr>.5
7645 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
7646 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
7647 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
7648 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
7649 KCH1=ISIGN(1,MINT(15))
7651 IF(MINT(2).EQ.1) THEN
7652 MINT(22-KCH2)= -(KSUSY1+24)
7653 MINT(21+KCH2)= KSUSY1+37
7656 MINT(21+KCH2)= KSUSY1+24
7657 MINT(22-KCH2)= -(KSUSY1+37)
7661 ELSEIF(ISUB.EQ.229) THEN
7662 C...q + qbar' -> ~chi01 + ~chi+-1
7663 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
7664 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7665 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7667 IF(MOD(MINT(15),2).NE.0) JS=2
7668 MINT(20+JS)=KSUSY1+22
7669 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7671 ELSEIF(ISUB.EQ.230) THEN
7672 C...q + qbar' -> ~chi02 + ~chi+-1
7673 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7674 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7675 IF(MOD(MINT(15),2).NE.0) JS=2
7676 MINT(20+JS)=KSUSY1+23
7677 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7679 ELSEIF(ISUB.EQ.231) THEN
7680 C...q + qbar' -> ~chi03 + ~chi+-1
7681 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7682 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7683 IF(MOD(MINT(15),2).NE.0) JS=2
7684 MINT(20+JS)=KSUSY1+25
7685 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7687 ELSEIF(ISUB.EQ.232) THEN
7688 C...q + qbar' -> ~chi04 + ~chi+-1
7689 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7690 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7691 IF(MOD(MINT(15),2).NE.0) JS=2
7692 MINT(20+JS)=KSUSY1+35
7693 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7695 ELSEIF(ISUB.EQ.233) THEN
7696 C...q + qbar' -> ~chi01 + ~chi+-2
7697 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7698 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7699 IF(MOD(MINT(15),2).NE.0) JS=2
7700 MINT(20+JS)=KSUSY1+22
7701 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7703 ELSEIF(ISUB.EQ.234) THEN
7704 C...q + qbar' -> ~chi02 + ~chi+-2
7705 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7706 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7707 IF(MOD(MINT(15),2).NE.0) JS=2
7708 MINT(20+JS)=KSUSY1+23
7709 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7711 ELSEIF(ISUB.EQ.235) THEN
7712 C...q + qbar' -> ~chi03 + ~chi+-2
7713 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7714 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7715 IF(MOD(MINT(15),2).NE.0) JS=2
7716 MINT(20+JS)=KSUSY1+25
7717 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7719 ELSEIF(ISUB.EQ.236) THEN
7720 C...q + qbar' -> ~chi04 + ~chi+-2
7721 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7722 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7723 IF(MOD(MINT(15),2).NE.0) JS=2
7724 MINT(20+JS)=KSUSY1+35
7725 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7728 ELSEIF(ISUB.LE.245) THEN
7729 IF(ISUB.EQ.237) THEN
7730 C...q + qbar -> ~chi01 + ~g
7732 IF(PYR(0).GT.0.5D0) JS=2
7733 MINT(20+JS)=KSUSY1+21
7734 MINT(23-JS)=KSUSY1+22
7737 ELSEIF(ISUB.EQ.238) THEN
7738 C...q + qbar -> ~chi02 + ~g
7740 IF(PYR(0).GT.0.5D0) JS=2
7741 MINT(20+JS)=KSUSY1+21
7742 MINT(23-JS)=KSUSY1+23
7745 ELSEIF(ISUB.EQ.239) THEN
7746 C...q + qbar -> ~chi03 + ~g
7748 IF(PYR(0).GT.0.5D0) JS=2
7749 MINT(20+JS)=KSUSY1+21
7750 MINT(23-JS)=KSUSY1+25
7753 ELSEIF(ISUB.EQ.240) THEN
7754 C...q + qbar -> ~chi04 + ~g
7756 IF(PYR(0).GT.0.5D0) JS=2
7757 MINT(20+JS)=KSUSY1+21
7758 MINT(23-JS)=KSUSY1+35
7761 ELSEIF(ISUB.EQ.241) THEN
7762 C...q + qbar' -> ~chi+-1 + ~g
7763 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7764 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7765 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7766 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7767 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7768 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7769 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7771 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7772 MINT(20+JS)=KSUSY1+21
7773 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7776 ELSEIF(ISUB.EQ.242) THEN
7777 C...q + qbar' -> ~chi+-2 + ~g
7778 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7779 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7780 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7781 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7782 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7783 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7784 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7786 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7787 MINT(20+JS)=KSUSY1+21
7788 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7791 ELSEIF(ISUB.EQ.243) THEN
7792 C...q + qbar -> ~g + ~g ; th arbitrary
7797 ELSEIF(ISUB.EQ.244) THEN
7798 C...g + g -> ~g + ~g ; th arbitrary
7800 KCS=(-1)**INT(1.5D0+PYR(0))
7805 ELSEIF(ISUB.LE.260) THEN
7806 IF(ISUB.EQ.246) THEN
7807 C...qj + g -> ~qj_L + ~chi01
7808 IF(MINT(15).EQ.21) JS=2
7811 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7812 MINT(23-JS)=KSUSY1+22
7814 KCS=ISIGN(1,MINT(14+JS))
7816 ELSEIF(ISUB.EQ.247) THEN
7817 C...qj + g -> ~qj_R + ~chi01
7818 IF(MINT(15).EQ.21) JS=2
7821 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7822 MINT(23-JS)=KSUSY1+22
7824 KCS=ISIGN(1,MINT(14+JS))
7826 ELSEIF(ISUB.EQ.248) THEN
7827 C...qj + g -> ~qj_L + ~chi02
7828 IF(MINT(15).EQ.21) JS=2
7831 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7832 MINT(23-JS)=KSUSY1+23
7834 KCS=ISIGN(1,MINT(14+JS))
7836 ELSEIF(ISUB.EQ.249) THEN
7837 C...qj + g -> ~qj_R + ~chi02
7838 IF(MINT(15).EQ.21) JS=2
7841 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7842 MINT(23-JS)=KSUSY1+23
7844 KCS=ISIGN(1,MINT(14+JS))
7846 ELSEIF(ISUB.EQ.250) THEN
7847 C...qj + g -> ~qj_L + ~chi03
7848 IF(MINT(15).EQ.21) JS=2
7851 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7852 MINT(23-JS)=KSUSY1+25
7854 KCS=ISIGN(1,MINT(14+JS))
7856 ELSEIF(ISUB.EQ.251) THEN
7857 C...qj + g -> ~qj_R + ~chi03
7858 IF(MINT(15).EQ.21) JS=2
7861 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7862 MINT(23-JS)=KSUSY1+25
7864 KCS=ISIGN(1,MINT(14+JS))
7866 ELSEIF(ISUB.EQ.252) THEN
7867 C...qj + g -> ~qj_L + ~chi04
7868 IF(MINT(15).EQ.21) JS=2
7871 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7872 MINT(23-JS)=KSUSY1+35
7874 KCS=ISIGN(1,MINT(14+JS))
7876 ELSEIF(ISUB.EQ.253) THEN
7877 C...qj + g -> ~qj_R + ~chi04
7878 IF(MINT(15).EQ.21) JS=2
7881 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7882 MINT(23-JS)=KSUSY1+35
7884 KCS=ISIGN(1,MINT(14+JS))
7886 ELSEIF(ISUB.EQ.254) THEN
7887 C...qj + g -> ~qk_L + ~chi+-1
7888 IF(MINT(15).EQ.21) JS=2
7891 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7892 IB=-IA+INT((IA+1)/2)*4-1
7893 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7895 KCS=ISIGN(1,MINT(14+JS))
7897 ELSEIF(ISUB.EQ.255) THEN
7898 C...qj + g -> ~qk_L + ~chi+-1
7899 IF(MINT(15).EQ.21) JS=2
7902 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7903 IB=-IA+INT((IA+1)/2)*4-1
7904 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7906 KCS=ISIGN(1,MINT(14+JS))
7908 ELSEIF(ISUB.EQ.256) THEN
7909 C...qj + g -> ~qk_L + ~chi+-2
7910 IF(MINT(15).EQ.21) JS=2
7913 IB=-IA+INT((IA+1)/2)*4-1
7914 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7915 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7917 KCS=ISIGN(1,MINT(14+JS))
7919 ELSEIF(ISUB.EQ.257) THEN
7920 C...qj + g -> ~qk_R + ~chi+-2
7921 IF(MINT(15).EQ.21) JS=2
7924 IB=-IA+INT((IA+1)/2)*4-1
7925 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7926 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7928 KCS=ISIGN(1,MINT(14+JS))
7930 ELSEIF(ISUB.EQ.258) THEN
7931 C...qj + g -> ~qj_L + ~g
7932 IF(MINT(15).EQ.21) JS=2
7935 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7936 MINT(23-JS)=KSUSY1+21
7938 IF(JS.EQ.2) KCC=KCC+2
7941 ELSEIF(ISUB.EQ.259) THEN
7942 C...qj + g -> ~qj_R + ~g
7943 IF(MINT(15).EQ.21) JS=2
7946 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7947 MINT(23-JS)=KSUSY1+21
7949 IF(JS.EQ.2) KCC=KCC+2
7953 ELSEIF(ISUB.LE.270) THEN
7954 IF(ISUB.EQ.261) THEN
7955 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
7956 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7958 C...Correct color combination
7959 IF(MINT(43).EQ.4) KCC=4
7961 ELSEIF(ISUB.EQ.262) THEN
7962 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
7963 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7965 C...Correct color combination
7966 IF(MINT(43).EQ.4) KCC=4
7968 ELSEIF(ISUB.EQ.263) THEN
7969 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
7970 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
7971 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
7972 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7973 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
7976 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
7977 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
7979 C...Correct color combination
7980 IF(MINT(43).EQ.4) KCC=4
7982 ELSEIF(ISUB.EQ.264) THEN
7983 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
7984 KCS=(-1)**INT(1.5D0+PYR(0))
7985 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7989 ELSEIF(ISUB.EQ.265) THEN
7990 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
7991 KCS=(-1)**INT(1.5D0+PYR(0))
7992 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7997 ELSEIF(ISUB.LE.280) THEN
7998 IF(ISUB.EQ.271) THEN
7999 C...qi + qj -> ~qi_L + ~qj_L
8001 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8002 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8003 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8005 ELSEIF(ISUB.EQ.272) THEN
8006 C...qi + qj -> ~qi_R + ~qj_R
8008 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8009 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8010 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8012 ELSEIF(ISUB.EQ.273) THEN
8013 C...qi + qj -> ~qi_L + ~qj_R
8014 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8015 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8017 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8019 ELSEIF(ISUB.EQ.274) THEN
8020 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
8021 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8022 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8024 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8026 ELSEIF(ISUB.EQ.275) THEN
8027 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8028 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8029 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8031 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8033 ELSEIF(ISUB.EQ.276) THEN
8034 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8035 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8036 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8038 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8040 ELSEIF(ISUB.EQ.277) THEN
8041 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
8043 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8044 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8046 IF(MINT(43).EQ.4) KCC=4
8048 ELSEIF(ISUB.EQ.278) THEN
8049 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
8051 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8052 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8054 IF(MINT(43).EQ.4) KCC=4
8056 ELSEIF(ISUB.EQ.279) THEN
8057 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
8059 KCS=(-1)**INT(1.5D0+PYR(0))
8060 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8064 ELSEIF(ISUB.EQ.280) THEN
8065 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
8066 KCS=(-1)**INT(1.5D0+PYR(0))
8067 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8075 IF(ISET(ISUB).EQ.11) THEN
8076 C...Store documentation for user-defined processes
8077 BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4))
8083 IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN
8093 IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3))
8100 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
8103 C...Store final state partons for user-defined processes
8108 IF(KUP(IUP,1).NE.1) K(N,1)=11
8110 IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN
8113 K(N,3)=MINT(84)+KUP(IUP,3)
8121 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
8123 C...Arrange colour flow for user-defined processes
8127 IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480
8128 IF(K(N,1).EQ.1) K(N,1)=3
8129 IF(K(N,1).EQ.11) K(N,1)=14
8130 IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+
8132 IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+
8134 IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84)
8135 IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84)
8138 ELSEIF(IDOC.EQ.7) THEN
8139 C...Resonance not decaying; store kinematics
8154 C...Special cases: colour flow in coloured resonances
8156 IF(KCHG(KCRES,2).NE.0) THEN
8160 IF(KCS.EQ.-1) JC=3-J
8161 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8162 & MINT(84)+ICOL(KCC,1,JC)
8163 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8164 & MINT(84)+ICOL(KCC,2,JC)
8165 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8166 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8175 ELSEIF(IDOC.EQ.8) THEN
8176 C...2 -> 2 processes: store outgoing partons in their CM-frame
8179 KCA=PYCOMP(MINT(20+JT))
8181 IF(KCHG(KCA,2).NE.0) K(I,1)=3
8183 K(I,3)=MINT(83)+IDOC+JT-2
8185 IF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,1).NE.0) THEN
8186 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8187 ELSEIF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,2).NE.0) THEN
8188 P(I,5)=SQRT(VINT(64))
8190 P(I,5)=PYMASS(K(I,2))
8192 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
8193 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
8195 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
8198 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
8206 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
8207 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
8208 P(IPU4,4)=SHR-P(IPU3,4)
8209 P(IPU4,3)=-P(IPU3,3)
8214 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
8215 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
8217 ELSEIF(IDOC.EQ.9) THEN
8218 C...2 -> 3 processes: store outgoing partons in their CM frame
8221 KCA=PYCOMP(MINT(20+JT))
8223 IF(KCHG(KCA,2).NE.0) K(I,1)=3
8225 K(I,3)=MINT(83)+IDOC+JT-3
8226 IF(IABS(K(I,2)).LE.22) THEN
8227 P(I,5)=PYMASS(K(I,2))
8229 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8231 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
8232 P(I,1)=PT*COS(VINT(198+5*JT))
8233 P(I,2)=PT*SIN(VINT(198+5*JT))
8237 K(IPU5,3)=MINT(83)+IDOC
8239 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8240 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8241 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
8242 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
8243 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
8245 P(IPU5,3)=PMT3*SINH(VINT(211))
8246 P(IPU5,4)=PMT3*COSH(VINT(211))
8247 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
8248 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
8249 IF(SQL12.LE.0D0) THEN
8253 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
8254 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
8255 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
8256 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
8257 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
8263 ELSEIF(IDOC.EQ.11) THEN
8264 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
8265 PHI(1)=PARU(2)*PYR(0)
8270 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8272 K(I,3)=MINT(83)+IDOC+JT-2
8273 P(I,5)=PYMASS(K(I,2))
8274 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
8278 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8279 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8280 P(I,1)=PTABS*COS(PHI(JT))
8281 P(I,2)=PTABS*SIN(PHI(JT))
8282 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8283 P(I,4)=0.5D0*SHPR*Z(JT)
8287 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
8291 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8292 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8293 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8300 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8301 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8302 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
8303 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
8312 ELSEIF(IDOC.EQ.12) THEN
8313 C...Z0 and W+/- scattering: store bosons and outgoing partons
8314 PHI(1)=PARU(2)*PYR(0)
8316 JTRAN=INT(1.5D0+PYR(0))
8320 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8322 K(I,3)=MINT(83)+IDOC+JT-2
8323 P(I,5)=PYMASS(K(I,2))
8324 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
8325 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8326 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8327 P(I,1)=PTABS*COS(PHI(JT))
8328 P(I,2)=PTABS*SIN(PHI(JT))
8329 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8330 P(I,4)=0.5D0*SHPR*Z(JT)
8333 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
8336 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
8341 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8342 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8343 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8346 K(IPU,2)=KFPR(ISUB,JT)
8347 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
8348 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
8349 K(IPU,3)=MINT(83)+8+JT
8350 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
8351 P(IPU,5)=PYMASS(K(IPU,2))
8353 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8355 MINT(22+JT)=K(IPU,2)
8357 C...Find rotation and boost for hard scattering subsystem
8360 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
8361 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
8362 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
8363 GAMCM=(P(I1,4)+P(I2,4))/SHR
8364 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
8365 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
8366 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
8367 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
8368 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
8370 C...Store hard scattering subsystem. Rotate and boost it
8371 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
8373 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
8375 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
8376 PHIWZ=VINT(24)-PHICM
8377 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
8378 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
8379 P(IPU5,3)=PABS*CTHWZ
8380 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
8381 P(IPU6,1)=-P(IPU5,1)
8382 P(IPU6,2)=-P(IPU5,2)
8383 P(IPU6,3)=-P(IPU5,3)
8384 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
8385 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
8400 IF(ISET(ISUB).EQ.11) THEN
8401 ELSEIF(IDOC.GE.8) THEN
8402 C...Store colour connection indices
8405 IF(KCS.EQ.-1) JC=3-J
8406 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8407 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
8408 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8409 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
8410 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8411 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8412 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8413 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8416 C...Copy outgoing partons to documentation lines
8418 IF(IDOC.EQ.9) IMAX=3
8420 I1=MINT(83)+IDOC-IMAX+I
8424 IF(IDOC.LE.9) K(I1,3)=0
8425 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
8431 ELSEIF(IDOC.EQ.9) THEN
8432 C...Store colour connection indices
8435 IF(KCS.EQ.-1) JC=3-J
8436 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8437 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
8438 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
8439 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8440 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
8441 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
8442 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8443 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8444 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
8445 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8448 C...Copy outgoing partons to documentation lines
8450 I1=MINT(83)+IDOC-3+I
8461 C...Low-pT events: remove gluons used for string drawing purposes
8463 K(IPU3,1)=K(IPU3,1)+10
8464 K(IPU4,1)=K(IPU4,1)+10
8469 DO 650 I=MINT(83)+5,MINT(83)+8
8479 C*********************************************************************
8482 C...Generates spacelike parton showers.
8484 SUBROUTINE PYSSPA(IPU1,IPU2)
8486 C...Double precision and integer declarations.
8487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8488 INTEGER PYK,PYCHGE,PYCOMP
8490 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8492 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8493 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8494 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8495 COMMON/PYINT1/MINT(400),VINT(400)
8496 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8497 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8498 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8500 C...Local arrays and data.
8501 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
8502 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
8503 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
8504 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
8505 &THEFIS(2,2),ISFI(2)
8508 C...Read out basic information; set global Q^2 scale.
8513 IF(ISET(ISUB).EQ.2) Q2MX=PARP(67)*VINT(56)
8515 C...Initialize QCD evolution and check phase space.
8518 IF(MSTP(66).EQ.1.AND.MINT(107).EQ.3)
8519 &Q2MNCS(1)=MAX(Q2MNC,VINT(283))
8521 IF(MSTP(66).EQ.1.AND.MINT(108).EQ.3)
8522 &Q2MNCS(2)=MAX(Q2MNC,VINT(284))
8524 XEC0=2D0*PARP(65)/VINT(1)
8529 IF(MINT(47).GE.2.AND.(MINT(47).NE.5.OR.MSTP(12).GE.1)) THEN
8531 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
8532 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
8533 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
8534 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
8538 C...Initialize QED evolution and check phase space.
8545 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
8548 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
8550 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
8552 C...Initial values: flavours, momenta, virtualities.
8557 KFBEAM(JT)=MINT(10+JT)
8558 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
8559 KFLS(JT)=MINT(14+JT)
8562 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
8570 XFS(JT,KFL)=XSFX(JT,KFL)
8574 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
8576 C...Find if interference with final state partons.
8578 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
8582 KCA=PYCOMP(IABS(KFLS(I)))
8583 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
8585 IF(KCFI(I).NE.0) THEN
8586 IF(I.EQ.1) IPFS=IPUS1
8587 IF(I.EQ.2) IPFS=IPUS2
8589 ICSI=MOD(K(IPFS,3+J),MSTU(5))
8590 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
8591 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
8593 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
8595 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
8600 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
8603 C...Pick up leg with highest virtuality.
8606 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
8607 IF(MORE(JT).EQ.0) JT=3-JT
8611 XFB(KFL)=XFS(JT,KFL)
8616 C...Check if allowed to branch.
8618 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
8620 XEC=MAX(XEC0,XB*(1D0/(1D0-PARP(66))-1D0))
8621 IF(XB.GE.1D0-2D0*XEC) MCEV=0
8624 IF(MINT(44+JT).EQ.3) THEN
8626 IF(XB.GE.1D0-2D0*XEE) MEEV=0
8627 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
8629 C***Currently kill QED shower for resolved photoproduction.
8630 IF(MINT(18+JT).EQ.1) MEEV=0
8631 C***Currently kill shower for W inside electron.
8632 IF(IABS(KFLB).EQ.24) THEN
8637 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8642 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
8646 IF(MSTP(62).LE.1) THEN
8647 IF(ZS(JT).GT.0.99999D0) THEN
8650 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
8651 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
8652 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
8654 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8655 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8658 ALSDUM=PYALPS(FQ2C*Q2B)
8659 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
8661 B0=(33D0-2D0*MSTU(118))/6D0
8666 C...Select side for interference with final state partons.
8667 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
8670 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
8672 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
8673 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
8674 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
8676 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
8680 C...Calculate Altarelli-Parisi weights.
8687 IF(IABS(KFLB).LE.10) THEN
8688 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
8689 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
8690 C...f -> f, gamma -> f.
8691 ELSEIF(IABS(KFLB).LE.20) THEN
8692 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
8693 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
8694 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
8695 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
8697 ELSEIF(KFLB.EQ.21) THEN
8698 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
8699 DO 180 KFL=1,MSTP(58)
8703 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
8704 C...f -> gamma, W+, W-.
8705 ELSEIF(KFLB.EQ.22) THEN
8706 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
8709 ELSEIF(KFLB.EQ.24) THEN
8710 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8711 & (XEE*(XB+XEE)))/XB
8712 ELSEIF(KFLB.EQ.-24) THEN
8713 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8714 & (XEE*(XB+XEE)))/XB
8717 C...Calculate parton distribution weights and sum.
8720 IF(NTRY.GT.500) THEN
8726 XFBO=MAX(1D-10,XFB(KFLB))
8728 WTSF(KFL)=XFB(KFL)/XFBO
8729 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
8730 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
8732 WTSUMC=MAX(0.0001D0,WTSUMC)
8733 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
8735 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
8738 IF(NTRY2.GT.500) THEN
8743 IF(MSTP(64).LE.0) THEN
8744 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
8745 ELSEIF(MSTP(64).EQ.1) THEN
8746 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
8748 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
8752 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
8753 & (PARU(101)*FWTE*WTSUME*TEMX)))
8756 C...Translate t into Q2 scale; choose between QCD and QED evolution.
8757 220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
8758 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
8760 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8761 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
8762 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
8763 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
8764 IF(Q2EB.GT.Q2MNE) MCE=2
8765 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
8767 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
8768 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
8771 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
8772 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
8775 C...Evolution possibly ended. Update t values.
8779 ELSEIF(MCE.EQ.1) THEN
8782 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8786 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8789 C...Select flavour for branching parton.
8790 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
8791 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
8794 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
8795 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
8796 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 230
8802 C...Choose z value and corrective weight.
8805 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
8806 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
8807 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
8808 WTZ=0.5D0*(1D0+Z**2)
8810 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
8811 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
8812 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
8814 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
8815 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
8816 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
8817 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
8819 Z=XB+XB*(XEE/(1D0-XEE))*
8820 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8822 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
8824 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
8825 Z=XB+XB*(XEE/(1D0-XEE))*
8826 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8827 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
8829 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
8830 Z=XB+XB*(XEE/(1D0-XEE))*
8831 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8832 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
8833 & (Q2B/(Q2B+PMAS(24,1)**2))
8835 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
8836 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
8837 WTZ=1D0-2D0*Z*(1D0-Z)
8839 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
8840 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
8841 WTZ=(1D0-Z*(1D0-Z))**2
8842 C...gamma -> f + fbar.
8843 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
8844 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
8845 WTZ=1D0-2D0*Z*(1D0-Z)
8847 IF(MCE.EQ.2) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
8849 C...Option with resummation of soft gluon emission as effective z shift.
8851 IF(MSTP(65).GE.1) THEN
8853 IF(KFLB.NE.21) RSOFT=8D0/3D0
8854 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
8855 IF(Z.LE.XB) GOTO 210
8858 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
8859 IF(MSTP(64).GE.2) THEN
8860 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 210
8861 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
8862 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210
8863 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
8866 C...Impose angular constraint in first branching from interference
8867 C...with final state partons.
8868 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
8869 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
8870 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
8871 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 210
8872 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
8873 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210
8877 C...Option with angular ordering requirement.
8878 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
8879 THE2T=(4D0*Z**2*Q2B)/(VINT(2)*(1D0-Z)*XB**2)
8880 IF(THE2T.GT.THE2(JT)) GOTO 210
8884 C...Weighting with new parton distributions.
8885 MINT(105)=MINT(102+JT)
8886 MINT(109)=MINT(106+JT)
8887 IF(MSTP(57).LE.1) THEN
8888 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
8890 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
8893 IF(XFBN.LT.1D-20) THEN
8894 IF(KFLA.EQ.KFLB) THEN
8900 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
8901 TEVCB=0.5D0*(TEVCBS+TEVCB)
8903 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
8904 TEVEB=0.5D0*(TEVEBS+TEVEB)
8915 IF(MSTP(57).LE.1) THEN
8916 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
8918 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
8921 IF(XFAN.LT.1D-20) GOTO 190
8923 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190
8925 C...Define two hard scatterers in their CM-frame.
8926 250 IF(N.EQ.NS+2) THEN
8928 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
8931 IF(JR.EQ.1) IPO=IPUS1
8932 IF(JR.EQ.2) IPO=IPUS2
8942 P(I,3)=DPLCM*(-1)**(JR+1)
8943 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
8944 P(I,5)=-SQRT(DQ2(JR))
8947 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
8948 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
8951 C...Find maximum allowed mass of timelike parton.
8952 ELSEIF(N.GT.NS+2) THEN
8957 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
8958 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
8959 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
8960 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
8961 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
8963 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
8964 & 1D-10*DPD(1)) IKIN=1
8965 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
8966 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
8967 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
8968 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
8970 C...Generate timelike parton shower (if required).
8978 C...f -> f + g (gamma).
8979 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
8981 IF(IABS(KFLB).GE.11) K(IT,2)=22
8982 C...f -> g (gamma, W+-) + f.
8983 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
8985 IF(KFLS(JT+2).EQ.24) THEN
8987 ELSEIF(KFLS(JT+2).EQ.-24) THEN
8990 C...g (gamma) -> f + fbar, g + g.
8993 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
8995 P(IT,5)=PYMASS(K(IT,2))
8996 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
8997 IF(MSTP(63).GE.1.AND.MCE.EQ.1) THEN
9000 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
9001 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
9002 IF(MSTP(63).EQ.1) THEN
9004 ELSEIF(MSTP(63).EQ.2) THEN
9005 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
9009 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9010 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
9011 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
9012 PARJ(85)=SQRT(MAX(0D0,DPT2))*
9013 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
9015 CALL PYSHOW(IT,0,SQRT(Q2TIM))
9018 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
9021 C...Reconstruct kinematics of branching: timelike parton shower.
9023 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9024 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
9025 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
9026 & (4D0*DSH*DPC(3)**2)
9027 IF(DPT2.LT.0D0) GOTO 100
9028 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
9029 & DSHR)/DPC(3)-DPC(3)
9031 P(IT,3)=DPB(1)*(-1)**(JT+1)
9032 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
9034 DPB(1)=SQRT(DPB(1)**2+DPT2)
9035 DPB(2)=SQRT(DPB(1)**2+DMS)
9037 DPB(4)=SQRT(DPB(3)**2+DMS)
9038 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
9040 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
9041 THE=PYANGL(P(IT,3),P(IT,1))
9042 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
9045 C...Reconstruct kinematics of branching: spacelike parton.
9054 P(N+1,3)=P(IT,3)+P(IS(JT),3)
9055 P(N+1,4)=P(IT,4)+P(IS(JT),4)
9056 P(N+1,5)=-SQRT(DQ2(3))
9058 C...Define colour flow of branching.
9063 C...f -> f + gamma (Z, W).
9064 IF(IABS(K(IT,2)).GE.22) THEN
9068 C...f -> gamma (Z, W) + f.
9069 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
9072 C...gamma -> q + qbar, g + g.
9073 ELSEIF(K(N+1,2).EQ.22) THEN
9079 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
9083 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
9086 C...qbar -> qbar + g.
9087 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
9090 C...qbar -> g + qbar.
9091 ELSEIF(K(N+1,2).LT.0) THEN
9094 C...g -> g + g; g -> q + qbar.
9095 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
9102 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
9103 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
9104 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
9105 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
9107 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
9108 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
9112 C...Boost to new CM-frame.
9113 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
9114 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
9115 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
9116 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
9117 IR=N+(JT-1)*(IS(1)-N)
9118 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),PARU(2)*PYR(0),
9122 C...Update kinematics variables.
9125 IF(MSTP(62).GE.3) THE2(JT)=THE2T
9128 C...Save quantities; loop back.
9130 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
9131 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
9137 XFS(JT,KFL)=XFA(KFL)
9146 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
9147 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
9148 IF(MSTU(21).GE.1) N=NS
9149 IF(MSTU(21).GE.1) RETURN
9151 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
9153 C...Boost hard scattering partons to frame of shower initiators.
9155 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
9161 ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
9162 IF(ROBOT.GE.0.999999D0) THEN
9163 ROBOT=1.00001D0*SQRT(ROBOT)
9164 ROBO(3)=ROBO(3)/ROBOT
9165 ROBO(4)=ROBO(4)/ROBOT
9166 ROBO(5)=ROBO(5)/ROBOT
9168 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
9169 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
9170 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
9171 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
9174 C...Store user information. Reset Lambda value.
9175 K(IPU1,3)=MINT(83)+3
9176 K(IPU2,3)=MINT(83)+4
9178 MINT(12+JT)=KFLS(JT)
9180 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
9187 C*********************************************************************
9190 C...Allows resonances to decay (including parton showers for hadronic
9193 SUBROUTINE PYRESD(IRES)
9195 C...Double precision and integer declarations.
9196 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9197 INTEGER PYK,PYCHGE,PYCOMP
9198 C...Parameter statement to help give large particle numbers.
9199 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
9201 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
9202 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9203 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9204 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
9205 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9206 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9207 COMMON/PYINT1/MINT(400),VINT(400)
9208 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9209 COMMON/PYINT4/MWID(500),WIDS(500,5)
9210 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
9211 &/PYINT1/,/PYINT2/,/PYINT4/
9212 C...Local arrays and complex and character variables.
9213 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
9214 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
9215 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
9216 &PHI(3),WDTP(0:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5)
9217 COMPLEX FGK,HA(6,6),HC(6,6)
9219 CHARACTER CODE*9,MASS*9
9221 C...The F, Xi and Xj functions of Gunion and Kunszt
9222 C...(Phys. Rev. D33, 665, plus errata from the authors).
9223 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
9224 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
9225 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
9226 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
9227 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
9228 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
9229 &2D0*(D34/D56+D56/D34))
9231 C...Some general constants.
9234 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
9237 GMMZ=PMAS(23,1)*PMAS(23,2)
9239 GMMW=PMAS(24,1)*PMAS(24,2)
9242 C...Reset original resonance configuration.
9247 C...Define initial one, two or three objects for subprocess.
9250 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
9251 IREF(1,1)=MINT(84)+2+ISET(ISUB)
9252 IREF(1,4)=MINT(83)+6+ISET(ISUB)
9253 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
9254 IREF(1,1)=MINT(84)+1+ISET(ISUB)
9255 IREF(1,2)=MINT(84)+2+ISET(ISUB)
9256 IREF(1,4)=MINT(83)+5+ISET(ISUB)
9257 IREF(1,5)=MINT(83)+6+ISET(ISUB)
9258 ELSEIF(ISET(ISUB).EQ.5) THEN
9259 IREF(1,1)=MINT(84)+3
9260 IREF(1,2)=MINT(84)+4
9261 IREF(1,3)=MINT(84)+5
9262 IREF(1,4)=MINT(83)+7
9263 IREF(1,5)=MINT(83)+8
9264 IREF(1,6)=MINT(83)+9
9267 C...Define original resonance for odd cases.
9273 C...Check if initial resonance has been moved (in resonance + jet).
9275 IF(IREF(1,JT).GT.0) THEN
9276 IF(K(IREF(1,JT),1).GT.10) THEN
9277 KFA=IABS(K(IREF(1,JT),2))
9278 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
9279 DO 110 I=IREF(1,JT)+1,N
9280 IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2))
9284 KDA=MOD(K(IREF(1,JT),4),MSTU(4))
9285 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
9291 C...Loop over decay history.
9297 IF(IREF(IP,2).EQ.0) JTMAX=1
9298 IF(IREF(IP,3).NE.0) JTMAX=3
9302 C...Start treatment of one, two or three resonances in parallel.
9313 C...Check whether particle can/is allowed to decay.
9314 IF(ID.EQ.0) GOTO 210
9317 IF(MWID(KCA).EQ.0) GOTO 210
9318 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 210
9319 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
9320 & KFA.EQ.18) IT4=IT4+1
9321 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
9322 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
9324 C...Info for selection of decay channel: sign, pairings.
9325 IF(KCHG(KCA,3).EQ.0) THEN
9328 IPM=(5-ISIGN(1,K(ID,2)))/2
9332 KFB=IABS(K(IREF(IP,3-JT),2))
9333 ELSEIF(JTMAX.EQ.3) THEN
9335 KFB=IABS(K(IREF(IP,JT2),2))
9337 JT2=JT+2-3*((JT+1)/3)
9338 KFB=IABS(K(IREF(IP,JT2),2))
9342 C...Select decay channel.
9343 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
9344 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
9345 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
9346 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
9347 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
9348 IF(WDTE0S.LE.0D0) GOTO 210
9352 IDC=IDL+MDCY(KCA,2)-1
9353 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
9354 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
9355 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 150
9357 C...Read out flavours and colour charges of decay channel chosen.
9358 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
9359 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
9360 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
9361 KFC1A=PYCOMP(IABS(KFL1(JT)))
9362 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
9363 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
9364 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
9365 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
9366 KFC2A=PYCOMP(IABS(KFL2(JT)))
9367 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
9368 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
9369 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
9370 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
9371 IF(KFL3(JT).NE.0) THEN
9372 KFC3A=PYCOMP(IABS(KFL3(JT)))
9373 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
9374 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
9375 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
9378 C...Set/save further info on channel.
9380 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
9386 C...Select masses; to begin with assume resonances narrow.
9397 IF(KFL3(JT).EQ.0) GOTO 170
9401 P(N+I,5)=PMAS(KCW,1)
9403 C...This prevents SUSY/t particles from becoming too light.
9404 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9406 DO 160 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9407 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9408 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9409 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9410 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9411 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9412 PMMN(I)=MIN(PMMN(I),PMSUM)
9416 ELSEIF(KFLW.EQ.6) THEN
9417 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9421 C...Check which two out of three are widest.
9426 KFLW1=IABS(KFL1(JT))
9427 KFLW2=IABS(KFL2(JT))
9428 IF(KFL3(JT).NE.0) THEN
9430 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
9433 KFLW1=IABS(KFL3(JT))
9434 ELSEIF(PWID3.GT.PWID2) THEN
9437 KFLW2=IABS(KFL3(JT))
9441 C...If all narrow then only check that masses consistent.
9442 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
9443 & PWID2.LT.PARP(41))) THEN
9445 C....Handle near degeneracy cases.
9446 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
9447 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
9448 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
9449 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
9453 IF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
9454 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
9459 C...For three wide resonances select narrower of three
9460 C...according to BW decoupled from rest.
9463 IF(KFL3(JT).NE.0) THEN
9465 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
9469 P(N+IWID3,5)=PYMASS(KFLW3)
9470 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 180
9471 PMTOT=PMTOT-P(N+IWID3,5)
9473 C...Select other two correlated within remaining phase space.
9477 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
9478 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
9479 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9484 CKIN(49)=PMMN(IWID1)
9485 CKIN(50)=PMMN(IWID2)
9486 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9491 IF(MINT(51).EQ.1) RETURN
9494 C...Begin fill decay products, with colour flow for coloured objects.
9500 C...1) Three-body decays of SUSY particles (plus special case top).
9501 IF(KFL3(JT).NE.0) THEN
9520 C...Set colour flow for t -> W + b + Z.
9524 IF(KCQM(JT).EQ.-1) ISID=5
9526 K(ID,ISID)=K(ID,ISID)+IDAU
9527 K(IDAU,ISID)=MSTU(5)*ID
9529 C...Set colour flow in three-body decays - programmed as special cases.
9530 ELSEIF(KFC2A.LE.6) THEN
9534 IF(KFL2(JT).LT.0) ISID=5
9535 K(N+2,ISID)=MSTU(5)*(N+3)
9536 K(N+3,9-ISID)=MSTU(5)*(N+2)
9538 IF(KFL1(JT).EQ.KSUSY1+21) THEN
9543 IF(KFL2(JT).LT.0) ISID=5
9544 K(N+1,ISID)=MSTU(5)*(N+2)
9545 K(N+1,9-ISID)=MSTU(5)*(N+3)
9546 K(N+2,ISID)=MSTU(5)*(N+1)
9547 K(N+3,9-ISID)=MSTU(5)*(N+1)
9549 IF(KFA.EQ.KSUSY1+21) THEN
9553 IF(KFL2(JT).LT.0) ISID=5
9554 K(ID,ISID)=K(ID,ISID)+(N+2)
9555 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
9556 K(N+2,ISID)=MSTU(5)*ID
9557 K(N+3,9-ISID)=MSTU(5)*ID
9562 C...2) Everything else two-body decay.
9564 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
9565 C...First set colour flow as if mother colour singlet.
9566 IF(KCQ1(JT).NE.0) THEN
9568 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
9569 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
9571 IF(KCQ2(JT).NE.0) THEN
9573 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
9574 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
9576 C...Then redirect colour flow if mother (anti)triplet.
9577 IF(KCQM(JT).EQ.0) THEN
9578 ELSEIF(KCQM(JT).NE.2) THEN
9580 IF(KCQM(JT).EQ.-1) ISID=5
9582 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
9583 K(ID,ISID)=K(ID,ISID)+IDAU
9584 K(IDAU,ISID)=MSTU(5)*ID
9585 C...Then redirect colour flow if mother octet.
9586 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
9588 IF(KCQ1(JT).EQ.0) IDAU=N
9589 K(ID,4)=K(ID,4)+IDAU
9590 K(ID,5)=K(ID,5)+IDAU
9591 K(IDAU,4)=MSTU(5)*ID
9592 K(IDAU,5)=MSTU(5)*ID
9595 IF(KCQ1(JT).EQ.-1) ISID=5
9596 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
9597 K(ID,ISID)=K(ID,ISID)+(N-1)
9598 K(ID,9-ISID)=K(ID,9-ISID)+N
9599 K(N-1,ISID)=MSTU(5)*ID
9600 K(N,9-ISID)=MSTU(5)*ID
9604 C...End loop over resonances for daughter flavour and mass selection.
9606 210 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
9608 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.KFL1(JT).EQ.0) THEN
9609 WRITE(CODE,'(I9)') K(ID,2)
9610 WRITE(MASS,'(F9.3)') P(ID,5)
9611 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
9612 & CODE//' with mass'//MASS)
9618 C...Check for allowed combinations. Skip if no decays.
9620 IF(KDCY(1).EQ.0) GOTO 560
9621 ELSEIF(JTMAX.EQ.2) THEN
9622 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 560
9623 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9624 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9625 ELSEIF(JTMAX.EQ.3) THEN
9626 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 560
9627 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9628 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9629 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9630 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9631 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9632 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9635 C...Special case: matrix element option for Z0 decay to quarks.
9636 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
9637 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
9639 C...Check consistency of MSTJ options set.
9640 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
9642 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
9645 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
9647 & '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
9651 C...Select alpha_strong behaviour.
9655 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9658 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9660 C...Find axial fraction in total cross section for scalar gluon model.
9662 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
9663 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
9664 POLL=1D0-PARJ(131)*PARJ(132)
9665 SFF=1D0/(16D0*XW*XW1)
9666 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
9667 & (PARJ(123)*PARJ(124))**2)
9668 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
9670 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
9671 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
9672 & (PARJ(132)-PARJ(131)))
9677 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
9678 & 1D0-(2D0*PMQ/P(ID,5))**2))
9679 VF=SIGN(1D0,QF)-4D0*QF*XW
9680 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
9681 & VF**2*HF1W)+VQ**3*HF1W
9682 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
9685 C...Choice of jet configuration.
9686 CALL PYXJET(P(ID,5),NJET,CUT)
9690 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
9691 ELSEIF(NJET.EQ.3) THEN
9692 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
9697 C...Fill jet configuration; return if incorrect kinematics.
9699 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
9700 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
9701 ELSEIF(NJET.EQ.2) THEN
9702 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
9703 ELSEIF(NJET.EQ.3) THEN
9704 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
9705 ELSEIF(KFLN.EQ.21) THEN
9706 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9709 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9712 IF(MSTU(24).NE.0) THEN
9719 C...Angular orientation according to matrix element.
9720 IF(MSTJ(106).EQ.1) THEN
9721 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHI,THE,PHI)
9722 IF(MINT(11).LT.0) THE=PARU(1)-THE
9724 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
9725 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
9728 C...Boost partons to Z0 rest frame.
9729 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
9730 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9732 C...Mark decayed resonance and add documentation lines,
9734 IDOC=MINT(83)+MINT(4)
9736 I1=MINT(83)+MINT(4)+1
9738 IF(MSTP(128).GE.1) K(I,3)=ID
9739 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
9750 C...Generate parton shower.
9751 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
9753 C... End special case for Z0: skip ahead.
9759 C...Order incoming partons and outgoing resonances.
9760 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9762 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
9763 IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
9764 ILIN(2)=2*MINT(84)+3-ILIN(1)
9766 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
9770 IF(K(IREF(IP,1),2).EQ.23) IORD=2
9771 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
9772 IAKIPD=IABS(K(IREF(IP,IORD),2))
9773 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
9774 IF(KDCY(IORD).EQ.0) IORD=3-IORD
9776 C...Order decay products of resonances.
9777 DO 250 JT=IORD,3-IORD,3-2*IORD
9778 IF(KDCY(JT).EQ.0) THEN
9779 ILIN(IMAX+1)=NSD(JT)
9781 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
9782 ILIN(IMAX+1)=N+2*JT-1
9785 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9786 K(N+2*JT,2)=K(NSD(JT)+2,2)
9789 ILIN(IMAX+2)=N+2*JT-1
9791 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9792 K(N+2*JT,2)=K(NSD(JT)+2,2)
9796 C...Find charge, isospin, left- and righthanded couplings.
9801 KFA=IABS(K(ILIN(I),2))
9802 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 270
9803 COUP(I,1)=KCHG(KFA,1)/3D0
9804 COUP(I,2)=(-1)**MOD(KFA,2)
9805 COUP(I,4)=-2D0*COUP(I,1)*XWV
9806 COUP(I,3)=COUP(I,2)+COUP(I,4)
9809 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
9813 IF(I.EQ.5) I1=3-IORD
9816 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
9817 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
9818 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
9823 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
9824 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
9825 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
9826 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
9827 IF(COWT12.LT.PYR(0)*COMX12) GOTO 140
9831 C...Select angular orientation type - Z'/W' only.
9833 IF(ISUB.EQ.141) THEN
9834 IF(PYR(0).LT.PARU(130)) MZPWP=1
9836 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
9837 IAKIR=IABS(K(IREF(2,2),2))
9838 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9841 ELSEIF(ISUB.EQ.142) THEN
9842 IF(PYR(0).LT.PARU(136)) MZPWP=1
9844 IAKIR=IABS(K(IREF(2,2),2))
9845 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9850 C...Select random angles (begin of weighting procedure).
9851 310 DO 320 JT=1,JTMAX
9852 IF(KDCY(JT).EQ.0) GOTO 320
9853 IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
9854 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
9855 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
9858 CTHE(JT)=2D0*PYR(0)-1D0
9859 PHI(JT)=PARU(2)*PYR(0)
9863 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9864 C...Construct massless four-vectors.
9873 IF(KDCY(JT).EQ.0) GOTO 350
9875 P(N+2*JT-1,3)=0.5D0*P(ID,5)
9876 P(N+2*JT-1,4)=0.5D0*P(ID,5)
9877 P(N+2*JT,3)=-0.5D0*P(ID,5)
9878 P(N+2*JT,4)=0.5D0*P(ID,5)
9879 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
9880 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9883 C...Store incoming and outgoing momenta, with random rotation to
9884 C...avoid accidental zeroes in HA expressions.
9887 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
9888 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
9889 P(N+4+I,5)=P(ILIN(I),5)
9891 P(N+4+I,J)=P(ILIN(I),J)
9894 380 THERR=ACOS(2D0*PYR(0)-1D0)
9895 PHIRR=PARU(2)*PYR(0)
9896 CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
9898 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2) GOTO 380
9904 C...Calculate internal products.
9905 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
9907 DO 420 I1=IMIN,IMAX-1
9909 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
9910 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
9911 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
9912 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
9913 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
9914 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
9915 HC(I1,I2)=CONJG(HA(I1,I2))
9916 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
9917 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
9918 HA(I2,I1)=-HA(I1,I2)
9919 HC(I2,I1)=-HC(I1,I2)
9928 DO 460 I1=IMIN,IMAX-1
9930 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
9931 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
9932 PKK(I2,I1)=PKK(I1,I2)
9937 KFAGM=IABS(IREF(IP,7))
9938 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
9939 C...Isotropic decay selected by user.
9943 ELSEIF(JTMAX.EQ.3) THEN
9944 C...Isotropic decay when three mother particles.
9948 ELSEIF(IT4.GE.1) THEN
9949 C... Isotropic decay t -> b + W etc for 4th generation q and l.
9953 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
9954 & IREF(IP,7).EQ.36) THEN
9955 C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
9956 IF(IP.EQ.1) WTMAX=SH**2
9957 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
9958 KFA=IABS(K(IREF(IP,1),2))
9960 KFLF1A=IABS(KFL1(1))
9961 EF1=KCHG(KFLF1A,1)/3D0
9962 AF1=SIGN(1D0,EF1+0.1D0)
9964 KFLF2A=IABS(KFL1(2))
9965 EF2=KCHG(KFLF2A,1)/3D0
9966 AF2=SIGN(1D0,EF2+0.1D0)
9968 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
9969 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
9970 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
9971 ELSEIF(KFA.EQ.24) THEN
9972 WT=16D0*PKK(3,5)*PKK(4,6)
9977 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
9978 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
9980 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
9982 IF(MOD(KFAGM,2).EQ.0) THEN
9990 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
9991 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
9992 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
9993 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
9995 ELSEIF(ISUB.EQ.1) THEN
9996 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
9997 EI=KCHG(IABS(MINT(15)),1)/3D0
9998 AI=SIGN(1D0,EI+0.1D0)
10000 EF=KCHG(IABS(KFL1(1)),1)/3D0
10001 AF=SIGN(1D0,EF+0.1D0)
10003 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
10004 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10005 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
10006 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10007 & (VI**2+AI**2)*VINT(114)*VF**2)
10008 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
10009 & 4D0*VI*AI*VINT(114)*VF*AF)
10010 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
10011 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
10012 WTMAX=2D0*(WT1+ABS(WT3))
10014 ELSEIF(ISUB.EQ.2) THEN
10015 C...Angular weight for W+/- -> 2 quarks/leptons.
10016 WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2
10019 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
10020 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
10021 C...-> gluon/gamma + 2 quarks/leptons.
10022 CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10023 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10024 & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10025 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10026 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10027 & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10028 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10029 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10030 & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10031 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10032 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10033 & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10034 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
10035 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
10036 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10037 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
10039 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
10040 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
10041 C...-> gluon/gamma + 2 quarks/leptons.
10042 WT=PKK(1,3)**2+PKK(2,4)**2
10043 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
10045 ELSEIF(ISUB.EQ.22) THEN
10046 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
10047 S34=P(IREF(IP,IORD),5)**2
10048 S56=P(IREF(IP,3-IORD),5)**2
10049 TI=PKK(1,3)+PKK(1,4)+S34
10050 UI=PKK(1,5)+PKK(1,6)+S56
10053 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
10054 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
10055 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
10056 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
10057 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
10058 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
10059 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
10060 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
10062 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
10063 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
10064 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
10065 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
10066 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
10067 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
10068 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
10071 ELSEIF(ISUB.EQ.23) THEN
10072 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
10073 D34=P(IREF(IP,IORD),5)**2
10074 D56=P(IREF(IP,3-IORD),5)**2
10075 DT=PKK(1,3)+PKK(1,4)+D34
10076 DU=PKK(1,5)+PKK(1,6)+D56
10077 FACBW=1D0/((SH-SQMW)**2+SQMW*PMAS(24,2)**2)
10078 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10079 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10080 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
10081 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
10082 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
10083 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
10084 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10085 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
10086 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
10088 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
10089 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
10090 C...(or H0, or A0).
10091 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10092 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
10093 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
10094 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10095 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10097 ELSEIF(ISUB.EQ.25) THEN
10098 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
10099 D34=P(IREF(IP,IORD),5)**2
10100 D56=P(IREF(IP,3-IORD),5)**2
10101 DT=PKK(1,3)+PKK(1,4)+D34
10102 DU=PKK(1,5)+PKK(1,6)+D56
10103 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
10104 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
10105 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
10106 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
10107 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
10108 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
10109 & REAL(CBWW)*FGK(1,2,5,6,3,4))
10110 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10111 WT=FGK135**2+(CCWW*FGK253)**2
10112 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
10113 & CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
10115 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
10116 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
10117 C...(or H0, or A0).
10118 WT=PKK(1,3)*PKK(2,4)
10119 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10121 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
10122 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
10123 C...-> f + 2 quarks/leptons.
10124 CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10125 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10126 & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10127 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10128 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10129 & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10130 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10131 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10132 & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10133 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10134 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10135 & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10136 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
10137 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
10138 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
10139 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
10140 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10141 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
10143 ELSEIF(ISUB.EQ.31) THEN
10144 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons.
10145 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
10146 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
10147 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
10149 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
10151 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
10152 WT=16D0*PKK(3,5)*PKK(4,6)
10155 ELSEIF(ISUB.EQ.110) THEN
10156 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
10160 ELSEIF(ISUB.EQ.141) THEN
10161 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10162 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
10163 C...Couplings of incoming flavour.
10164 KFAI=IABS(MINT(15))
10165 EI=KCHG(KFAI,1)/3D0
10166 AI=SIGN(1D0,EI+0.1D0)
10169 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
10170 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
10171 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
10172 VPI=PARU(119+2*KFAIC)
10173 API=PARU(120+2*KFAIC)
10174 C...Couplings of final flavour.
10176 EF=KCHG(KFAF,1)/3D0
10177 AF=SIGN(1D0,EF+0.1D0)
10180 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
10181 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
10182 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
10183 VPF=PARU(119+2*KFAFC)
10184 APF=PARU(120+2*KFAFC)
10185 C...Asymmetry and weight.
10186 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
10187 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
10188 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
10189 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10190 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
10191 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
10192 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
10193 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10194 WTMAX=2D0+ABS(ASYM)
10195 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
10196 C...Angular weight for f + fbar -> Z' -> W+ + W-.
10197 RM1=P(NSD(1)+1,5)**2/SH
10198 RM2=P(NSD(1)+2,5)**2/SH
10199 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10200 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10201 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10203 WT=CFLAT+CCOS2*CTHE(1)**2
10204 WTMAX=CFLAT+MAX(0D0,CCOS2)
10205 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
10206 & IABS(KFL1(1)).EQ.37)) THEN
10207 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
10210 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10211 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
10212 RM1=P(NSD(1)+1,5)**2/SH
10213 RM2=P(NSD(1)+2,5)**2/SH
10214 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10215 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10216 WTMAX=1D0+FLAM2/(8D0*RM1)
10217 ELSEIF(MZPWP.EQ.0) THEN
10218 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10219 C...(W:s like if intermediate Z).
10220 D34=P(IREF(IP,IORD),5)**2
10221 D56=P(IREF(IP,3-IORD),5)**2
10222 DT=PKK(1,3)+PKK(1,4)+D34
10223 DU=PKK(1,5)+PKK(1,6)+D56
10224 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10225 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10226 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
10227 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
10228 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10229 ELSEIF(MZPWP.EQ.1) THEN
10230 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10231 C...(W:s approximately longitudinal, like if intermediate H).
10232 WT=16D0*PKK(3,5)*PKK(4,6)
10235 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
10236 C...H0 + A0 -> 4 quarks/leptons.
10241 ELSEIF(ISUB.EQ.142) THEN
10242 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10243 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
10244 KFAI=IABS(MINT(15))
10246 IF(KFAI.GT.10) KFAIC=2
10247 VI=PARU(129+2*KFAIC)
10248 AI=PARU(130+2*KFAIC)
10251 IF(KFAF.GT.10) KFAFC=2
10252 VF=PARU(129+2*KFAFC)
10253 AF=PARU(130+2*KFAFC)
10254 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
10255 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10256 WTMAX=2D0+ABS(ASYM)
10257 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
10258 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
10259 RM1=P(NSD(1)+1,5)**2/SH
10260 RM2=P(NSD(1)+2,5)**2/SH
10261 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10262 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10263 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10265 WT=CFLAT+CCOS2*CTHE(1)**2
10266 WTMAX=CFLAT+MAX(0D0,CCOS2)
10267 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10268 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
10269 RM1=P(NSD(1)+1,5)**2/SH
10270 RM2=P(NSD(1)+2,5)**2/SH
10271 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10272 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10273 WTMAX=1D0+FLAM2/(8D0*RM1)
10274 ELSEIF(MZPWP.EQ.0) THEN
10275 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10276 C...(W/Z like if intermediate W).
10277 D34=P(IREF(IP,IORD),5)**2
10278 D56=P(IREF(IP,3-IORD),5)**2
10279 DT=PKK(1,3)+PKK(1,4)+D34
10280 DU=PKK(1,5)+PKK(1,6)+D56
10281 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10282 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
10283 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10284 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
10285 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10286 ELSEIF(MZPWP.EQ.1) THEN
10287 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10288 C...(W/Z approximately longitudinal, like if intermediate H).
10289 WT=16D0*PKK(3,5)*PKK(4,6)
10292 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever.
10297 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
10299 C...Isotropic decay of leptoquarks (assumed spin 0).
10303 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
10304 C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-).
10306 IF(MINT(16).EQ.21) SIDE=-1D0
10307 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
10308 WT=1D0+SIDE*CTHE(1)
10310 ELSEIF(IP.EQ.1) THEN
10311 RM1=P(NSD(1)+1,5)**2/SH
10312 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10313 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10315 C...W/Z decay assumed isotropic, since not known.
10320 ELSEIF(ISUB.EQ.149) THEN
10321 C...Isotropic decay of techni-eta.
10325 ELSEIF(ISUB.EQ.191) THEN
10326 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10327 C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
10328 C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
10331 ELSEIF(IP.EQ.1) THEN
10332 C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
10333 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10334 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
10335 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10336 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10337 KFAI=IABS(MINT(15))
10338 EI=KCHG(KFAI,1)/3D0
10339 AI=SIGN(1D0,EI+0.1D0)
10343 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
10344 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
10346 EF=KCHG(KFAF,1)/3D0
10347 AF=SIGN(1D0,EF+0.1D0)
10351 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
10352 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
10353 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
10354 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
10355 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
10356 WTMAX=4D0*MAX(ASAME,AFLIP)
10358 C...Isotropic decay of W/pi_tech produced in rho_tech decay.
10363 ELSEIF(ISUB.EQ.192) THEN
10364 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10365 C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
10366 C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
10369 ELSEIF(IP.EQ.1) THEN
10370 C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
10371 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10375 C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
10380 ELSEIF(ISUB.EQ.193) THEN
10381 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10382 C...Angular weight for f + fbar -> omega_tech0 ->
10383 C...gamma pi_tech0 or Z0 pi_tech0.
10386 ELSEIF(IP.EQ.1) THEN
10387 C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
10388 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10389 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10390 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10391 KFAI=IABS(MINT(15))
10392 EI=KCHG(KFAI,1)/3D0
10393 AI=SIGN(1D0,EI+0.1D0)
10397 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
10398 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
10400 EF=KCHG(KFAF,1)/3D0
10401 AF=SIGN(1D0,EF+0.1D0)
10405 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
10406 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
10407 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
10408 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
10409 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
10410 WTMAX=4D0*MAX(BSAME,BFLIP)
10412 C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
10417 C...Obtain correct angular distribution by rejection techniques.
10422 IF(WT.LT.PYR(0)*WTMAX) GOTO 310
10424 C...Construct massive four-vectors using angles chosen.
10425 470 DO 540 JT=1,JTMAX
10426 IF(KDCY(JT).EQ.0) GOTO 540
10431 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
10433 IF(KFL3(JT).EQ.0) THEN
10434 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
10435 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10437 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
10438 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10442 C...Mark decayed resonances; trace history.
10446 IF(KCQM(JT).NE.0) THEN
10447 C...Do not kill colour flow through coloured resonance!
10451 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
10454 C...Add documentation lines.
10456 IDOC=MINT(83)+MINT(4)
10459 IF(KFL3(JT).NE.0) IHI=IHI+1
10460 DO 500 I=NSD(JT)+1,IHI
10462 I1=MINT(83)+MINT(4)+1
10464 IF(MSTP(128).GE.1) K(I,3)=ID
10465 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
10469 K(I1,3)=IREF(IP,JT+3)
10478 IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
10481 C...Do showering if any of the two/three products can shower.
10483 IF(MSTP(71).GE.1) THEN
10485 KFL1A=IABS(KFL1(JT))
10486 IF(KFL1A.LE.22) ISHOW1=1
10488 KFL2A=IABS(KFL2(JT))
10489 IF(KFL2A.LE.22) ISHOW2=1
10491 IF(KFL3(JT).NE.0) THEN
10492 KFL3A=IABS(KFL3(JT))
10493 IF(KFL3A.LE.22) ISHOW3=1
10495 IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN
10496 ELSEIF(KFL3(JT).EQ.0) THEN
10497 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
10501 IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN
10503 ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN
10506 PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2-
10507 & (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2-
10508 & (P(NSD1,3)+P(NSD2,3))**2))
10509 CALL PYSHOW(NSD1,NSD2,PMSHOW)
10513 IF(JT.EQ.1) NAFT1=N
10515 C...Check if decay products moved by shower.
10519 IF(NSHAFT.GT.NSHBEF) THEN
10520 IF(K(NSD1,1).GT.10) THEN
10521 DO 510 I=NSHBEF+1,NSHAFT
10522 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
10525 IF(K(NSD2,1).GT.10) THEN
10526 DO 520 I=NSHBEF+1,NSHAFT
10527 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
10528 & I.NE.NSD1) NSD2=I
10531 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
10532 DO 530 I=NSHBEF+1,NSHAFT
10533 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
10534 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
10539 C...Store decay products for further treatment.
10544 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
10548 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
10549 IREF(NP,7)=K(IREF(IP,JT),2)
10550 IREF(NP,8)=IREF(IP,JT)
10553 C...Fill information for 2 -> 1 -> 2.
10554 550 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
10555 MINT(7)=MINT(83)+6+2*ISET(ISUB)
10556 MINT(8)=MINT(83)+7+2*ISET(ISUB)
10562 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
10563 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
10564 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
10565 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
10566 VINT(47)=SQRT(VINT(48))
10569 C...Possibility of colour rearrangement in W+W- events.
10570 IF(ISUB.EQ.25.AND.MSTP(115).GE.1) THEN
10571 IAKF1=IABS(KFL1(1))
10572 IAKF2=IABS(KFL1(2))
10573 IAKF3=IABS(KFL2(1))
10574 IAKF4=IABS(KFL2(2))
10575 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
10576 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
10577 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
10580 C...Loop back if needed.
10581 560 IF(IP.LT.NP) GOTO 130
10586 C*********************************************************************
10589 C...Initializes treatment of multiple interactions, selects kinematics
10590 C...of hardest interaction if low-pT physics included in run, and
10591 C...generates all non-hardest interactions.
10593 SUBROUTINE PYMULT(MMUL)
10595 C...Double precision and integer declarations.
10596 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10597 INTEGER PYK,PYCHGE,PYCOMP
10599 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10600 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10601 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10602 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10603 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10604 COMMON/PYINT1/MINT(400),VINT(400)
10605 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10606 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10607 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10608 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
10609 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10610 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
10611 C...Local arrays and saved variables.
10612 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
10613 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
10615 C...Initialization of multiple interaction treatment.
10617 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
10625 C...Loop over phase space points: xT2 choice in 20 bins.
10628 NMUL(IXT2)=MSTP(83)
10630 DO 110 ITRY=1,MSTP(83)
10631 RSCA=0.05D0*((21-IXT2)-PYR(0))
10632 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
10633 XT2=MAX(0.01D0*VINT(149),XT2)
10636 C...Choose tau and y*. Calculate cos(theta-hat).
10637 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10638 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10639 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10641 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10647 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10648 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10649 CALL PYKMAP(2,MYST,PYR(0))
10650 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10652 C...Calculate differential cross-section.
10653 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10654 CALL PYSIGH(NCHN,SIGS)
10655 SIGM(IXT2)=SIGM(IXT2)+SIGS
10657 SIGSUM=SIGSUM+SIGM(IXT2)
10659 SIGSUM=SIGSUM/(20D0*MSTP(83))
10661 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
10662 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
10663 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) PARP(82),SIGSUM
10664 PARP(82)=0.9D0*PARP(82)
10665 VINT(149)=4D0*PARP(82)**2/VINT(2)
10668 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) PARP(82), SIGSUM
10670 C...Start iteration to find k factor.
10671 YKE=SIGSUM/SIGT(0,0,5)
10679 130 IF(IIT.EQ.0) THEN
10681 ELSEIF(IIT.EQ.1) THEN
10684 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
10687 C...Evaluate overlap integrals.
10688 IF(MSTP(82).EQ.2) THEN
10689 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
10692 IF(MSTP(82).EQ.3) DELTAB=0.02D0
10693 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
10698 IF(MSTP(82).EQ.3) THEN
10699 OV=EXP(-B**2)/PARU(2)
10702 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
10703 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
10704 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
10705 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
10707 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
10708 SP=SP+PARU(2)*B*DELTAB*PACC
10709 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
10710 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
10712 YK=PARU(1)*XK*SO/SP
10714 C...Continue iteration until convergence.
10724 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
10726 C...Store some results for subsequent use.
10731 C...Initialize iteration in xT2 for hardest interaction.
10732 ELSEIF(MMUL.EQ.2) THEN
10733 IF(MSTP(82).LE.0) THEN
10734 ELSEIF(MSTP(82).EQ.1) THEN
10736 XT2FAC=XSEC(96,1)/SIGT(0,0,5)*VINT(149)/(1D0-VINT(149))
10737 ELSEIF(MSTP(82).EQ.2) THEN
10739 XT2FAC=VINT(146)*XSEC(96,1)/SIGT(0,0,5)*VINT(149)*
10742 XC2=4D0*CKIN(3)**2/VINT(2)
10743 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
10746 ELSEIF(MMUL.EQ.3) THEN
10747 C...Low-pT or multiple interactions (first semihard interaction):
10748 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
10749 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
10751 IF(MSTP(82).LE.0) THEN
10753 ELSEIF(MSTP(82).EQ.1) THEN
10754 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10755 ELSEIF(MSTP(82).EQ.2) THEN
10756 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
10757 & VINT(149)))).GT.PYR(0)) XT2=1D0
10758 IF(XT2.GE.1D0) THEN
10759 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
10760 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
10763 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
10764 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
10767 XT2=MAX(0.01D0*VINT(149),XT2)
10769 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
10770 & PYR(0)*(1D0-XC2))-VINT(149)
10771 XT2=MAX(0.01D0*VINT(149),XT2)
10775 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
10776 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
10777 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
10778 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
10781 VINT(21)=0.01D0*VINT(149)
10784 VINT(25)=0.01D0*VINT(149)
10787 C...Multiple interactions (first semihard interaction).
10788 C...Choose tau and y*. Calculate cos(theta-hat).
10789 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10790 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10791 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10793 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10799 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10800 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10801 CALL PYKMAP(2,MYST,PYR(0))
10802 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10804 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
10806 C...Store results of cross-section calculation.
10807 ELSEIF(MMUL.EQ.4) THEN
10810 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
10811 IF(ISET(ISUB).EQ.2)
10812 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10813 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
10814 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
10815 & (XTS+VINT(149))))
10816 IRBIN=INT(1D0+20D0*RBIN)
10817 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
10818 NMUL(IRBIN)=NMUL(IRBIN)+1
10819 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
10822 C...Choose impact parameter.
10823 ELSEIF(MMUL.EQ.5) THEN
10824 IF(MSTP(82).EQ.3) THEN
10825 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
10829 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
10831 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
10832 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
10834 B2=-CQ2*LOG(PYR(0))
10836 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
10837 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
10838 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
10841 C...Multiple interactions (variable impact parameter) : reject with
10842 C...probability exp(-overlap*cross-section above pT/normalization).
10843 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
10844 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
10845 DO 150 IBIN=IRBIN+1,20
10846 RNCOR=RNCOR+NMUL(IBIN)
10847 SIGCOR=SIGCOR+SIGM(IBIN)
10849 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
10850 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
10851 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
10852 & SIGABV/SIGT(0,0,5)))
10854 C...Generate additional multiple semihard interactions.
10855 ELSEIF(MMUL.EQ.6) THEN
10863 C...Reconstruct strings in hard scattering.
10865 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
10866 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
10868 DO 180 I=MINT(84)+1,NMAX
10869 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
10870 IF(KCS.EQ.0) GOTO 180
10873 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170
10874 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170
10876 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
10878 IST=MOD(K(I,J+1),MSTU(5))
10880 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 170
10881 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170
10883 IF(J.EQ.1.OR.J.EQ.4) THEN
10893 C...Set up starting values for iteration in xT2.
10895 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
10896 IF(ISET(ISUBSV).EQ.2)
10897 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10898 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
10899 IF(MSTP(82).LE.1) THEN
10900 XT2FAC=XSEC(ISUB,1)*VINT(149)/((1D0-VINT(149))*SIGT(0,0,5))
10902 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/SIGT(0,0,5)*
10903 & VINT(149)*(1D0+VINT(149))
10907 VINT(143)=1D0-VINT(141)
10908 VINT(144)=1D0-VINT(142)
10910 C...Iterate downwards in xT2.
10911 190 IF(MSTP(82).LE.1) THEN
10912 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10913 IF(XT2.LT.VINT(149)) GOTO 240
10915 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240
10916 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
10917 & LOG(PYR(0)))-VINT(149)
10918 IF(XT2.LE.0D0) GOTO 240
10919 XT2=MAX(0.01D0*VINT(149),XT2)
10923 C...Choose tau and y*. Calculate cos(theta-hat).
10924 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10925 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10926 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10928 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10934 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10935 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10936 CALL PYKMAP(2,MYST,PYR(0))
10937 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10939 C...Check that x not used up. Accept or reject kinematical variables.
10940 X1M=SQRT(TAU)*EXP(VINT(22))
10941 X2M=SQRT(TAU)*EXP(-VINT(22))
10942 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 190
10943 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10944 CALL PYSIGH(NCHN,SIGS)
10945 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190
10947 C...Reset K, P and V vectors. Select some variables.
10956 PT=0.5D0*VINT(1)*SQRT(XT2)
10960 C...Add first parton to event record.
10963 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
10964 & 1+INT((2D0+PARJ(2))*PYR(0))
10965 P(N+1,1)=PT*COS(PHI)
10966 P(N+1,2)=PT*SIN(PHI)
10967 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
10968 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
10971 C...Add second parton to event record.
10974 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
10977 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
10978 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
10981 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
10982 C....Choose relevant string pieces to place gluons on.
10988 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
10989 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
10990 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
10991 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
10992 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
11000 C....Colour flow adjustments, new string pieces.
11001 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
11002 & MOD(K(IST1,4),MSTU(5))
11003 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
11004 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
11005 K(I,5)=MSTU(5)*IST1
11006 K(I,4)=MSTU(5)*IST2
11007 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
11008 & MOD(K(IST2,5),MSTU(5))
11009 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
11010 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
11013 KSTR(NSTR+1,2)=IST2
11017 C...String drawing and colour flow for gluon loop.
11018 ELSEIF(K(N+1,2).EQ.21) THEN
11019 K(N+1,4)=MSTU(5)*(N+2)
11020 K(N+1,5)=MSTU(5)*(N+2)
11021 K(N+2,4)=MSTU(5)*(N+1)
11022 K(N+2,5)=MSTU(5)*(N+1)
11029 C...String drawing and colour flow for qqbar pair.
11031 K(N+1,4)=MSTU(5)*(N+2)
11032 K(N+2,5)=MSTU(5)*(N+1)
11038 C...Update remaining energy; iterate.
11040 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11041 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
11042 IF(MSTU(21).GE.1) RETURN
11044 MINT(31)=MINT(31)+1
11045 VINT(151)=VINT(151)+VINT(41)
11046 VINT(152)=VINT(152)+VINT(42)
11047 VINT(143)=VINT(143)-VINT(41)
11048 VINT(144)=VINT(144)-VINT(42)
11049 IF(MINT(31).LT.240) GOTO 190
11057 C...Format statements for printout.
11058 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
11059 &'actions for MSTP(82) =',I2,' ******')
11060 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11061 &D9.2,' mb: rejected')
11062 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11063 &D9.2,' mb: accepted')
11068 C*********************************************************************
11071 C...Adds on target remnants (one or two from each side) and
11072 C...includes primordial kT for hadron beams.
11074 SUBROUTINE PYREMN(IPU1,IPU2)
11076 C...Double precision and integer declarations.
11077 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11078 INTEGER PYK,PYCHGE,PYCOMP
11080 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11082 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11083 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11084 COMMON/PYINT1/MINT(400),VINT(400)
11085 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
11087 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
11088 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
11090 C...Find event type and remaining energy.
11093 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
11094 VINT(143)=1D0-VINT(141)
11095 VINT(144)=1D0-VINT(142)
11098 C...Define initial partons.
11103 IF(JT.EQ.1) IPU=IPU1
11104 IF(JT.EQ.2) IPU=IPU2
11111 IF(MINT(47).EQ.1) THEN
11115 ELSEIF(ISUB.EQ.95) THEN
11120 C...No primordial kT, or chosen according to truncated Gaussian or
11121 C...exponential, or (for photon) predetermined or power law.
11122 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
11123 IF(MSTP(91).LE.0) THEN
11125 ELSEIF(MSTP(91).EQ.1) THEN
11126 PT=PARP(91)*SQRT(-LOG(PYR(0)))
11130 PT=-PARP(92)*LOG(RPT1*RPT2)
11132 IF(PT.GT.PARP(93)) GOTO 120
11133 ELSEIF(MINT(106+JT).EQ.3) THEN
11134 PT=SQRT(VINT(282+JT))
11135 PT=PT*0.8D0**MINT(57)
11136 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
11137 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
11138 IF(MSTP(93).LE.0) THEN
11140 ELSEIF(MSTP(93).EQ.1) THEN
11141 PT=PARP(99)*SQRT(-LOG(PYR(0)))
11142 ELSEIF(MSTP(93).EQ.2) THEN
11145 PT=-PARP(99)*LOG(RPT1*RPT2)
11146 ELSEIF(MSTP(93).EQ.3) THEN
11149 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
11153 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
11154 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
11156 IF(PT.GT.PARP(100)) GOTO 120
11164 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11167 IF(MINT(47).EQ.1) RETURN
11169 C...Kinematics construction for initial partons.
11172 IF(ISUB.EQ.95) THEN
11176 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
11177 & (P(I1,2)+P(I2,2))**2
11178 SHR=SQRT(MAX(0D0,SHS))
11179 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
11180 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
11181 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
11182 P(I2,4)=SHR-P(I1,4)
11185 C...Transform partons to overall CM-frame.
11186 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
11187 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
11188 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
11189 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
11190 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
11191 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
11192 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
11193 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
11194 ROBO(5)=MAX(-0.999999D0,MIN(0.999999D0,(VINT(141)-VINT(142))/
11195 & (VINT(141)+VINT(142))))
11196 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
11199 C...Optionally fix up x and Q2 definitions for leptoproduction.
11201 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
11202 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
11203 IF(IDISXQ.EQ.1) THEN
11205 C...Find where incoming and outgoing leptons/partons are sitting.
11207 IF(MINT(42).EQ.1) LESD=2
11208 LPIN=MINT(83)+3-LESD
11210 LQIN=MINT(84)+3-LESD
11211 LEOUT=MINT(84)+2+LESD
11212 LQOUT=MINT(84)+5-LESD
11213 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
11214 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
11216 DO 140 I=MINT(84)+5,N
11217 IF(K(I,2).EQ.94) THEN
11224 IF(LESD.EQ.1) LQBG=IPU2
11226 C...Calculate actual and wanted momentum transfer.
11229 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
11230 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
11231 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
11232 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
11233 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
11234 P(N+1,1)=FAC*P(LEOUT,1)
11235 P(N+1,2)=FAC*P(LEOUT,2)
11236 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
11237 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
11238 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
11241 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
11242 QNEW(J)=P(LEIN,J)-P(N+1,J)
11245 C...Boost outgoing electron and daughters.
11246 IF(LSCMS.EQ.0) THEN
11248 P(LEOUT,J)=P(N+1,J)
11252 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
11254 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
11256 DBE(J)=PINV*P(N+2,J)
11260 190 IORIG=K(IORIG,3)
11261 IF(IORIG.GT.LEOUT) GOTO 190
11262 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
11263 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
11267 C...Copy shower initiator and all outgoing partons.
11271 P(NCOP,J)=P(LQBG,J)
11273 DO 240 I=MINT(84)+1,N
11275 IF(K(I,1).GT.10) GOTO 240
11276 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
11280 220 IORIG=K(IORIG,3)
11281 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
11283 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
11296 C...Calculate relative rescaling factors.
11300 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
11303 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
11306 C...Transfer extra three-momentum of current.
11309 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
11311 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11314 C...Iterate change of initiator momentum to get energy right.
11317 PEEX=-P(N+1,4)-QNEW(4)
11318 PEMV=-P(N+1,3)/P(N+1,4)
11321 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
11323 IF(ABS(PEMV).LT.1D-10) THEN
11325 MINT(57)=MINT(57)+1
11329 P(N+1,3)=P(N+1,3)+PZCH
11330 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)
11332 P(I,3)=P(I,3)+V(I,1)*PZCH
11333 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11335 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
11337 C...Modify momenta in event record.
11338 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
11339 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
11340 IF(ABS(HBE).GT.0.999999D0) THEN
11342 MINT(57)=MINT(57)+1
11346 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
11355 C...Check minimum invariant mass of remnant system(s).
11356 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
11357 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
11358 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11359 PMIN(0)=SQRT(PMS(0))
11361 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
11362 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
11364 IF(MINT(44+JT).EQ.1) GOTO 340
11365 MINT(105)=MINT(102+JT)
11366 MINT(109)=MINT(106+JT)
11367 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
11368 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
11369 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
11370 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
11371 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
11372 & P(MINT(83)+JT+2,2)**2)
11374 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
11375 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
11378 MINT(57)=MINT(57)+1
11382 C...Loop over two remnants; skip if none there.
11386 IF(MINT(44+JT).EQ.1) GOTO 410
11387 IF(JT.EQ.1) IPU=IPU1
11388 IF(JT.EQ.2) IPU=IPU2
11390 C...Store first remnant parton.
11402 P(I,5)=PYMASS(K(I,2))
11404 C...First parton colour connections and kinematics.
11405 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
11408 K(I,4)=MSTU(5)*IPU+IPU
11409 K(I,5)=MSTU(5)*IPU+IPU
11410 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11411 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11412 ELSEIF(KCOL.NE.0) THEN
11414 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
11416 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11418 IF(KFLCH(JT).EQ.0) THEN
11419 P(I,1)=-P(MINT(83)+JT+2,1)
11420 P(I,2)=-P(MINT(83)+JT+2,2)
11421 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11422 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11426 C...When extra remnant parton or hadron: store extra remnant.
11438 P(I,5)=PYMASS(K(I,2))
11440 C...Find parton colour connections of extra remnant.
11441 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
11444 K(I,4)=MSTU(5)*IPU+IPU
11445 K(I,5)=MSTU(5)*IPU+IPU
11446 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11447 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11448 ELSEIF(KCOL.NE.0) THEN
11450 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
11452 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11455 C...Relative transverse momentum when two remnants.
11458 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
11459 IF(IABS(MINT(10+JT)).LT.20) THEN
11463 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
11464 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
11465 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
11466 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11468 C...Meson or baryon; photon as meson. For splitup below.
11470 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
11472 C***Relative distribution for electron into two electrons. Temporary!
11473 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
11477 C...Relative distribution of electron energy into electron plus parton.
11478 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
11481 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
11483 C...Relative distribution of energy for particle into two jets.
11484 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
11485 CHIK=PARP(92+2*IMB)
11486 IF(MSTP(92).LE.1) THEN
11487 IF(IMB.EQ.1) CHI(JT)=PYR(0)
11488 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11489 ELSEIF(MSTP(92).EQ.2) THEN
11490 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
11491 ELSEIF(MSTP(92).EQ.3) THEN
11492 CUT=2D0*0.3D0/VINT(1)
11493 380 CHI(JT)=PYR(0)**2
11494 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
11495 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
11496 ELSEIF(MSTP(92).EQ.4) THEN
11497 CUT=2D0*0.3D0/VINT(1)
11498 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11499 390 CHIR=CUT*CUTR**PYR(0)
11500 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
11501 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
11503 CUT=2D0*0.3D0/VINT(1)
11504 CUTA=CUT**(1D0-PARP(98))
11505 CUTB=(1D0+CUT)**(1D0-PARP(98))
11506 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11507 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
11508 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
11511 C...Relative distribution of energy for particle into jet plus particle.
11513 IF(MSTP(94).LE.1) THEN
11514 IF(IMB.EQ.1) CHI(JT)=PYR(0)
11515 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11516 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11517 ELSEIF(MSTP(94).EQ.2) THEN
11518 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
11519 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11520 ELSEIF(MSTP(94).EQ.3) THEN
11521 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
11524 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
11529 C...Construct total transverse mass; reject if too large.
11530 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
11531 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
11532 IF(LOOP.LT.10) THEN
11536 MINT(57)=MINT(57)+1
11540 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11541 VINT(158+JT)=CHI(JT)
11543 C...Subdivide longitudinal momentum according to value selected above.
11544 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
11545 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
11546 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
11547 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
11548 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
11553 C...Check if longitudinal boosts needed - if so pick two systems.
11554 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
11555 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
11556 IF(PDEV.LE.1D-6*VINT(1)) RETURN
11557 IF(ISN(1).EQ.0) THEN
11560 ELSEIF(ISN(2).EQ.0) THEN
11563 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
11566 ELSEIF(VINT(143).GT.0.2D0) THEN
11569 ELSEIF(VINT(144).GT.0.2D0) THEN
11572 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
11581 C...E+-pL wanted for system to be modified.
11582 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
11586 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
11587 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
11590 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
11591 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
11595 SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL))
11596 SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11597 RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3))
11599 RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3))
11601 BER=(RKR**2-1D0)/(RKR**2+1D0)
11602 BEL=-(RKL**2-1D0)/(RKL**2+1D0)
11603 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
11604 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
11608 DO 450 I=MINT(84)+1,NS
11609 IF(K(I,1).GT.10) GOTO 450
11612 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11614 IF(IORIG.GT.LPIN) GOTO 430
11615 IF(INCL.EQ.0) GOTO 450
11617 PSYS(0,J)=PSYS(0,J)+P(I,J)
11620 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11621 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
11622 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
11625 C...Construct longitudinal boosts.
11629 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
11630 IF(DSQLAM.LE.1D-6*DPMTB) THEN
11632 MINT(57)=MINT(57)+1
11635 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11636 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
11637 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
11638 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
11639 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
11640 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
11641 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
11643 C...Perform longitudinal boosts.
11644 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
11646 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
11647 ELSEIF(IR.EQ.1) THEN
11648 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
11649 ELSEIF(IDISXQ.EQ.1) THEN
11653 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11655 IF(IORIG.GT.LPIN) GOTO 460
11656 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
11659 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
11661 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
11663 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
11664 ELSEIF(IL.EQ.2) THEN
11665 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
11666 ELSEIF(IDISXQ.EQ.1) THEN
11670 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11672 IF(IORIG.GT.LPIN) GOTO 480
11673 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
11676 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
11679 C...Final check that energy-momentum conservation worked.
11682 DO 500 I=MINT(84)+1,N
11683 IF(K(I,1).GT.10) GOTO 500
11687 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
11688 IF(PDEV.GT.1D-4*VINT(1)) THEN
11690 MINT(57)=MINT(57)+1
11694 C...Calculate rotation and boost from overall CM frame to
11695 C...hadronic CM frame in leptoproduction.
11697 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
11700 IF(MINT(42).EQ.1) LESD=2
11701 LPIN=MINT(83)+3-LESD
11703 C...Sum upp momenta of everything not lepton or photon to define boost.
11708 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
11709 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
11710 IF(K(I,2).EQ.22) GOTO 530
11712 PSUM(J)=PSUM(J)+P(I,J)
11715 VINT(223)=-PSUM(1)/PSUM(4)
11716 VINT(224)=-PSUM(2)/PSUM(4)
11717 VINT(225)=-PSUM(3)/PSUM(4)
11719 C...Boost incoming hadron to hadronic CM frame to determine rotations.
11725 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
11726 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
11727 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
11729 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
11731 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
11738 C*********************************************************************
11741 C...Handles diffractive and elastic scattering.
11745 C...Double precision and integer declarations.
11746 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11747 INTEGER PYK,PYCHGE,PYCOMP
11749 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11750 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11751 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11752 COMMON/PYINT1/MINT(400),VINT(400)
11753 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
11755 C...Reset K, P and V vectors. Store incoming particles.
11756 DO 110 JT=1,MSTP(126)+10
11776 P(I,J)=VINT(285+5*JT+J)
11781 C...Subprocess; kinematics.
11782 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
11783 PZ=SQRT(SQLAM)/(2D0*VINT(1))
11786 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
11789 C...Elastically scattered particle.
11790 IF(MINT(16+JT).LE.0) THEN
11795 P(N,3)=PZ*(-1)**(JT+1)
11797 P(N,5)=SQRT(VINT(62+JT))
11799 C...Decay rho from elastic scattering of gamma with sin**2(theta)
11800 C...distribution of decay products (in rho rest frame).
11801 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
11803 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
11807 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
11808 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
11809 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
11810 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
11811 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
11812 140 CTHE=2D0*PYR(0)-1D0
11813 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
11814 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
11816 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
11819 C...Diffracted particle: low-mass system to two particles.
11820 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
11826 PMMAS=SQRT(VINT(62+JT))
11829 IF(NTRY.LT.20) THEN
11830 MINT(105)=MINT(102+JT)
11831 MINT(109)=MINT(106+JT)
11832 CALL PYSPLI(KFH,21,KFL1,KFL2)
11833 CALL PYKFDI(KFL1,0,KFL3,KF1)
11834 IF(KF1.EQ.0) GOTO 150
11835 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
11836 IF(KF2.EQ.0) GOTO 150
11843 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
11848 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
11849 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
11852 P(N-1,4)=SQRT(PM1**2+PZP**2)
11853 P(N,4)=SQRT(PM2**2+PZP**2)
11854 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
11856 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
11857 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
11859 C...Diffracted particle: valence quark kicked out.
11860 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
11867 MINT(105)=MINT(102+JT)
11868 MINT(109)=MINT(106+JT)
11869 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
11870 P(N-1,5)=PYMASS(K(N-1,2))
11871 P(N,5)=PYMASS(K(N,2))
11872 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
11873 & 4D0*P(N-1,5)**2*P(N,5)**2
11874 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
11875 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
11876 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
11877 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
11878 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11880 C...Diffracted particle: gluon kicked out.
11889 MINT(105)=MINT(102+JT)
11890 MINT(109)=MINT(106+JT)
11891 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
11893 P(N-2,5)=PYMASS(K(N-2,2))
11895 P(N,5)=PYMASS(K(N,2))
11896 C...Energy distribution for particle into two jets.
11898 IF(MOD(KFH/1000,10).NE.0) IMB=2
11899 CHIK=PARP(92+2*IMB)
11900 IF(MSTP(92).LE.1) THEN
11901 IF(IMB.EQ.1) CHI=PYR(0)
11902 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
11903 ELSEIF(MSTP(92).EQ.2) THEN
11904 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
11905 ELSEIF(MSTP(92).EQ.3) THEN
11906 CUT=2D0*0.3D0/VINT(1)
11908 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
11910 ELSEIF(MSTP(92).EQ.4) THEN
11911 CUT=2D0*0.3D0/VINT(1)
11912 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11913 180 CHIR=CUT*CUTR**PYR(0)
11914 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
11915 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
11917 CUT=2D0*0.3D0/VINT(1)
11918 CUTA=CUT**(1D0-PARP(98))
11919 CUTB=(1D0+CUT)**(1D0-PARP(98))
11920 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11921 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
11922 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
11924 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
11925 & VINT(62+JT)) GOTO 160
11926 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
11927 IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 160
11928 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
11929 & (2D0*VINT(62+JT))
11930 PEI=SQRT(PZI**2+SQM)
11931 PQQP=(1D0-CHI)*(PEI+PZI)
11932 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
11933 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
11934 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
11935 P(N-1,3)=P(N-1,4)*(-1)**JT
11936 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
11937 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11940 C...Documentation lines.
11942 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
11943 IF(MINT(16+JT).NE.0) K(I+2,2)=10*(KFH/10)
11945 P(I+2,3)=PZ*(-1)**(JT+1)
11947 P(I+2,5)=SQRT(VINT(62+JT))
11950 C...Rotate outgoing partons/particles using cos(theta).
11951 IF(VINT(23).LT.0.9D0) THEN
11952 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
11954 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
11960 C*********************************************************************
11963 C...Handles the documentation of the process in MSTI and PARI,
11964 C...and also computes cross-sections based on accumulated statistics.
11968 C...Double precision and integer declarations.
11969 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11970 INTEGER PYK,PYCHGE,PYCOMP
11972 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11973 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11974 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11975 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
11976 COMMON/PYINT1/MINT(400),VINT(400)
11977 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11978 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
11979 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
11982 C...Calculate Monte Carlo estimates of cross-sections.
11984 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
11985 NGEN(0,3)=NGEN(0,3)+1
11988 IF(I.EQ.96.OR.I.EQ.97) THEN
11990 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
11991 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
11992 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
11993 & DBLE(NGEN(96,2)))
11994 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
11996 ELSEIF(NGEN(I,2).EQ.0) THEN
11997 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
12000 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
12003 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
12006 C...Rescale to known low-pT cross-section for standard QCD processes.
12007 IF(MSUB(95).EQ.1) THEN
12008 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
12009 & XSEC(68,3)+XSEC(95,3)
12010 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
12011 IF(XSECH.GT.1D-10.AND.XSECW.GT.1D-10) THEN
12013 XSEC(11,3)=FAC*XSEC(11,3)
12014 XSEC(12,3)=FAC*XSEC(12,3)
12015 XSEC(13,3)=FAC*XSEC(13,3)
12016 XSEC(28,3)=FAC*XSEC(28,3)
12017 XSEC(53,3)=FAC*XSEC(53,3)
12018 XSEC(68,3)=FAC*XSEC(68,3)
12019 XSEC(95,3)=FAC*XSEC(95,3)
12020 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
12024 C...Save information for gamma-p and gamma-gamma.
12025 IF(MINT(121).GT.1) THEN
12031 C...Reset information on hard interaction.
12037 C...Copy integer valued information from MINT into MSTI.
12041 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
12043 C...Store cross-section variables in PARI.
12045 PARI(2)=XSEC(0,3)/MINT(5)
12048 VINT(98)=VINT(98)+VINT(100)
12049 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
12051 C...Store kinematics variables in PARI.
12054 IF(ISUB.NE.95) THEN
12062 PARI(35)=PARI(33)-PARI(34)
12069 PARI(42)=2D0*VINT(47)/VINT(1)
12072 C...Store information on scattered partons in PARI.
12073 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
12076 PARI(36+IS)=P(I,3)/VINT(1)
12077 PARI(38+IS)=P(I,4)/VINT(1)
12078 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
12079 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12080 & SQRT(PR),1D20)),P(I,3))
12081 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
12082 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12083 & SQRT(PR),1D20)),P(I,3))
12084 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
12085 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
12086 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
12090 C...Store sum up transverse and longitudinal momenta.
12091 PARI(65)=2D0*PARI(17)
12092 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
12093 DO 150 I=MSTP(126)+1,N
12094 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
12095 PT=SQRT(P(I,1)**2+P(I,2)**2)
12096 PARI(69)=PARI(69)+PT
12097 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
12098 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
12110 C...Store various other pieces of information into PARI.
12118 C...Set information for PYTABU.
12119 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12122 ELSEIF(ISET(ISUB).EQ.5) THEN
12133 C*********************************************************************
12136 C...Performs transformations between different coordinate frames.
12138 SUBROUTINE PYFRAM(IFRAME)
12140 C...Double precision and integer declarations.
12141 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12142 INTEGER PYK,PYCHGE,PYCOMP
12144 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12145 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12146 COMMON/PYINT1/MINT(400),VINT(400)
12147 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
12149 C...Check that transformation can and should be done.
12150 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
12151 &MINT(91).EQ.1)) THEN
12152 IF(IFRAME.EQ.MINT(6)) RETURN
12154 WRITE(MSTU(11),5000) IFRAME,MINT(6)
12158 IF(MINT(6).EQ.1) THEN
12159 C...Transform from fixed target or user specified frame to
12160 C...overall CM frame.
12161 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
12162 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
12163 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
12164 ELSEIF(MINT(6).EQ.3) THEN
12165 C...Transform from hadronic CM frame in DIS to overall CM frame.
12166 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
12170 IF(IFRAME.EQ.1) THEN
12171 C...Transform from overall CM frame to fixed target or user specified
12173 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
12174 ELSEIF(IFRAME.EQ.3) THEN
12175 C...Transform from overall CM frame to hadronic CM frame in DIS.
12176 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
12177 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
12178 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
12181 C...Set information about new frame.
12185 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
12186 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
12192 C*********************************************************************
12195 C...Calculates full and partial widths of resonances.
12197 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
12199 C...Double precision and integer declarations.
12200 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12201 INTEGER PYK,PYCHGE,PYCOMP
12202 C...Parameter statement to help give large particle numbers.
12203 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
12205 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12206 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12207 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
12208 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12209 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12210 COMMON/PYINT1/MINT(400),VINT(400)
12211 COMMON/PYINT4/MWID(500),WIDS(500,5)
12212 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
12213 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
12215 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
12216 &/PYINT4/,/PYMSSM/,/PYSSMT/
12217 C...Local arrays and saved variables.
12218 DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
12220 SAVE MOFSV,WIDWSV,WID2SV
12221 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
12223 C...Compressed code and sign; mass.
12230 C...Reset width information.
12238 C...Not to be treated as a resonance: return.
12239 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
12248 C...Treatment as a resonance based on tabulated branching ratios.
12249 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
12250 C...Loop over possible decay channels; skip irrelevant ones.
12251 DO 120 I=1,MDCY(KC,3)
12253 IF(MDME(IDC,1).LT.0) GOTO 120
12255 C...Read out decay products and nominal masses.
12258 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
12262 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
12268 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
12272 C...Naive partial width and alternative threshold factors.
12273 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
12274 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
12275 & PM1+PM2+PM3.GE.SHR) THEN
12277 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
12278 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
12279 & 4D0*PM1**2*PM2**2))/SH
12280 ELSEIF(MDME(IDC,2).EQ.52) THEN
12281 PMA=MAX(PM1,PM2,PM3)
12282 PMC=MIN(PM1,PM2,PM3)
12283 PMB=PM1+PM2+PM3-PMA-PMC
12284 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
12289 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
12290 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12291 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12292 & ((SHR-PMA)**2-(PMB+PMC)**2)*
12293 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12294 & ((1D0-PMBCN)*PMBCN*SH)
12295 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
12296 WDTP(I)=WDTP(I)*SQRT(
12297 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
12298 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
12299 ELSEIF(MDME(IDC,2).EQ.53) THEN
12300 PMA=MAX(PM1,PM2,PM3)
12301 PMC=MIN(PM1,PM2,PM3)
12302 PMB=PM1+PM2+PM3-PMA-PMC
12303 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
12308 FACACT=SQRT(MAX(0D0,
12309 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12310 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12311 & ((SHR-PMA)**2-(PMB+PMC)**2)*
12312 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12313 & ((1D0-PMBCN)*PMBCN*SH)
12314 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
12318 PMBCN=PMBC**2/PMR**2
12319 FACNOM=SQRT(MAX(0D0,
12320 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12321 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12322 & ((PMR-PMA)**2-(PMB+PMC)**2)*
12323 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
12324 & ((1D0-PMBCN)*PMBCN*PMR**2)
12325 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
12327 WDTP(0)=WDTP(0)+WDTP(I)
12329 C...Calculate secondary width (at most two identical/opposite).
12330 IF(MDME(IDC,1).GT.0) THEN
12331 IF(KFD2.EQ.KFD1) THEN
12332 IF(KCHG(KFC1,3).EQ.0) THEN
12334 ELSEIF(KFD1.GT.0) THEN
12340 WID2=WID2*WIDS(KFC3,2)
12341 ELSEIF(KFD3.LT.0) THEN
12342 WID2=WID2*WIDS(KFC3,3)
12344 ELSEIF(KFD2.EQ.-KFD1) THEN
12347 WID2=WID2*WIDS(KFC3,2)
12348 ELSEIF(KFD3.LT.0) THEN
12349 WID2=WID2*WIDS(KFC3,3)
12351 ELSEIF(KFD3.EQ.KFD1) THEN
12352 IF(KCHG(KFC1,3).EQ.0) THEN
12354 ELSEIF(KFD1.GT.0) THEN
12360 WID2=WID2*WIDS(KFC2,2)
12361 ELSEIF(KFD2.LT.0) THEN
12362 WID2=WID2*WIDS(KFC2,3)
12364 ELSEIF(KFD3.EQ.-KFD1) THEN
12367 WID2=WID2*WIDS(KFC2,2)
12368 ELSEIF(KFD2.LT.0) THEN
12369 WID2=WID2*WIDS(KFC2,3)
12371 ELSEIF(KFD3.EQ.KFD2) THEN
12372 IF(KCHG(KFC2,3).EQ.0) THEN
12374 ELSEIF(KFD2.GT.0) THEN
12380 WID2=WID2*WIDS(KFC1,2)
12381 ELSEIF(KFD1.LT.0) THEN
12382 WID2=WID2*WIDS(KFC1,3)
12384 ELSEIF(KFD3.EQ.-KFD2) THEN
12387 WID2=WID2*WIDS(KFC1,2)
12388 ELSEIF(KFD1.LT.0) THEN
12389 WID2=WID2*WIDS(KFC1,3)
12398 WID2=WID2*WIDS(KFC2,2)
12400 WID2=WID2*WIDS(KFC2,3)
12403 WID2=WID2*WIDS(KFC3,2)
12404 ELSEIF(KFD3.LT.0) THEN
12405 WID2=WID2*WIDS(KFC3,3)
12409 C...Store effective widths according to case.
12410 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12411 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12412 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12413 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12423 C...Here begins detailed dynamical calculation of resonance widths.
12424 C...Shared treatment of Higgs states.
12427 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12432 C...Common electroweak and strong constants.
12435 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12438 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
12440 RADC=1D0+AS/PARU(1)
12444 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12445 RADCT=1D0-2.5D0*AS/PARU(1)
12446 DO 130 I=1,MDCY(KC,3)
12448 IF(MDME(IDC,1).LT.0) GOTO 130
12449 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12450 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12451 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
12452 IF(I.GE.4.AND.I.LE.7) THEN
12453 C...t -> W + q; including approximate QCD correction factor.
12454 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
12455 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12456 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12459 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12462 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12464 ELSEIF(I.EQ.9) THEN
12466 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12467 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12469 IF(KFLR.LT.0) WID2=WIDS(37,3)
12471 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
12472 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
12475 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
12478 KFC1=PYCOMP(KFDP(IDC,1))
12479 KFC2=PYCOMP(KFDP(IDC,2))
12480 PMNCHI=PMAS(KFC1,1)
12481 PMSTOP=PMAS(KFC2,1)
12482 IF(SHR.GT.PMNCHI+PMSTOP) THEN
12484 AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB)
12485 AR=-ET*ZMIX(IZ,1)*TANW
12486 BL=T3L*(ZMIX(IZ,2)-ZMIX(IZ,1)*TANW)-AR
12488 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
12489 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
12490 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
12491 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
12492 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*((FL**2+FR**2)*
12493 & (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH
12495 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
12497 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
12502 WDTP(0)=WDTP(0)+WDTP(I)
12503 IF(MDME(IDC,1).GT.0) THEN
12504 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12505 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12506 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12507 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12511 ELSEIF(KFLA.EQ.7) THEN
12513 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12514 DO 140 I=1,MDCY(KC,3)
12516 IF(MDME(IDC,1).LT.0) GOTO 140
12517 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12518 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12519 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
12520 IF(I.GE.4.AND.I.LE.7) THEN
12522 WDTP(I)=FAC*VCKM(I-3,4)*
12523 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12524 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12527 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
12528 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
12531 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
12532 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
12535 IF(KFLR.LT.0) WID2=WIDS(24,2)
12536 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12538 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12539 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12542 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
12545 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
12548 WDTP(0)=WDTP(0)+WDTP(I)
12549 IF(MDME(IDC,1).GT.0) THEN
12550 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12551 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12552 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12553 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12557 ELSEIF(KFLA.EQ.8) THEN
12559 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12560 DO 150 I=1,MDCY(KC,3)
12562 IF(MDME(IDC,1).LT.0) GOTO 150
12563 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12564 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12565 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
12566 IF(I.GE.4.AND.I.LE.7) THEN
12568 WDTP(I)=FAC*VCKM(4,I-3)*
12569 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12570 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12573 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12576 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12578 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12580 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12581 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12584 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
12587 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
12590 WDTP(0)=WDTP(0)+WDTP(I)
12591 IF(MDME(IDC,1).GT.0) THEN
12592 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12593 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12594 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12595 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12599 ELSEIF(KFLA.EQ.17) THEN
12601 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12602 DO 160 I=1,MDCY(KC,3)
12604 IF(MDME(IDC,1).LT.0) GOTO 160
12605 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12606 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12607 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
12609 C...tau' -> W + nu'_tau.
12610 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12611 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12614 WID2=WID2*WIDS(18,2)
12617 WID2=WID2*WIDS(18,3)
12619 ELSEIF(I.EQ.5) THEN
12620 C...tau' -> H + nu'_tau.
12621 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12622 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12625 WID2=WID2*WIDS(18,2)
12628 WID2=WID2*WIDS(18,3)
12631 WDTP(0)=WDTP(0)+WDTP(I)
12632 IF(MDME(IDC,1).GT.0) THEN
12633 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12634 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12635 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12636 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12640 ELSEIF(KFLA.EQ.18) THEN
12641 C...nu'_tau neutrino.
12642 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12643 DO 170 I=1,MDCY(KC,3)
12645 IF(MDME(IDC,1).LT.0) GOTO 170
12646 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12647 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12648 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
12650 C...nu'_tau -> W + tau'.
12651 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12652 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12655 WID2=WID2*WIDS(17,2)
12658 WID2=WID2*WIDS(17,3)
12660 ELSEIF(I.EQ.3) THEN
12661 C...nu'_tau -> H + tau'.
12662 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12663 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12666 WID2=WID2*WIDS(17,2)
12669 WID2=WID2*WIDS(17,3)
12672 WDTP(0)=WDTP(0)+WDTP(I)
12673 IF(MDME(IDC,1).GT.0) THEN
12674 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12675 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12676 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12677 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12681 ELSEIF(KFLA.EQ.21) THEN
12683 C***Note that widths are not given in dimensional quantities here.
12684 DO 180 I=1,MDCY(KC,3)
12686 IF(MDME(IDC,1).LT.0) GOTO 180
12687 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12688 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12689 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
12692 C...QCD -> q + qbar
12693 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12694 IF(I.EQ.6) WID2=WIDS(6,1)
12695 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12697 WDTP(0)=WDTP(0)+WDTP(I)
12698 IF(MDME(IDC,1).GT.0) THEN
12699 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12700 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12701 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12702 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12706 ELSEIF(KFLA.EQ.22) THEN
12708 C***Note that widths are not given in dimensional quantities here.
12709 DO 190 I=1,MDCY(KC,3)
12711 IF(MDME(IDC,1).LT.0) GOTO 190
12712 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12713 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12714 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
12717 C...QED -> q + qbar.
12720 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12721 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12722 IF(I.EQ.6) WID2=WIDS(6,1)
12723 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12724 ELSEIF(I.LE.12) THEN
12725 C...QED -> l+ + l-.
12726 EF=KCHG(9+2*(I-8),1)/3D0
12727 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12728 IF(I.EQ.12) WID2=WIDS(17,1)
12730 WDTP(0)=WDTP(0)+WDTP(I)
12731 IF(MDME(IDC,1).GT.0) THEN
12732 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12733 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12734 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12735 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12739 ELSEIF(KFLA.EQ.23) THEN
12742 XWC=1D0/(16D0*XW*XW1)
12743 FAC=(AEM*XWC/3D0)*SHR
12745 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
12750 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12752 IF(KFI.GT.20) KFI=IABS(MINT(16))
12758 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
12759 IF(MSTP(43).EQ.3) VINT(112)=
12760 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
12761 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12762 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
12764 DO 210 I=1,MDCY(KC,3)
12766 IF(MDME(IDC,1).LT.0) GOTO 210
12767 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12768 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12769 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
12774 AF=SIGN(1D0,EF+0.1D0)
12777 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12778 IF(I.EQ.6) WID2=WIDS(6,1)
12779 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12780 ELSEIF(I.LE.16) THEN
12781 C...Z0 -> l+ + l-, nu + nubar
12783 AF=SIGN(1D0,EF+0.1D0)
12786 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
12788 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
12789 IF(ICASE.EQ.1) THEN
12790 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
12792 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12793 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
12794 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
12795 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
12796 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12797 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
12798 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
12799 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
12801 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
12802 IF(MDME(IDC,1).GT.0) THEN
12803 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
12804 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
12805 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12806 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
12807 & WDTE(I,MDME(IDC,1))
12808 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12809 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12811 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12812 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
12813 & VINT(111)+FGGF*WID2
12814 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
12815 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12816 & VINT(114)+FZZF*WID2
12820 IF(MINT(61).GE.1) ICASE=3-ICASE
12821 IF(ICASE.EQ.2) GOTO 200
12823 ELSEIF(KFLA.EQ.24) THEN
12825 FAC=(AEM/(24D0*XW))*SHR
12826 DO 220 I=1,MDCY(KC,3)
12828 IF(MDME(IDC,1).LT.0) GOTO 220
12829 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12830 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12831 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
12834 C...W+/- -> q + qbar'
12835 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
12837 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
12838 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
12839 IF(I.GE.13) WID2=WID2*WIDS(7,3)
12841 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
12842 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
12843 IF(I.GE.13) WID2=WID2*WIDS(7,2)
12845 ELSEIF(I.LE.20) THEN
12846 C...W+/- -> l+/- + nu
12849 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
12851 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
12854 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
12855 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
12856 WDTP(0)=WDTP(0)+WDTP(I)
12857 IF(MDME(IDC,1).GT.0) THEN
12858 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12859 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12860 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12861 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12865 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12866 C...h0 (or H0, or A0):
12867 IF(MSTP(49).EQ.0) THEN
12868 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
12870 FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR
12872 DO 260 I=1,MDCY(KFHIGG,3)
12873 IDC=I+MDCY(KFHIGG,2)-1
12874 IF(MDME(IDC,1).LT.0) GOTO 260
12875 KFC1=PYCOMP(KFDP(IDC,1))
12876 KFC2=PYCOMP(KFDP(IDC,2))
12877 RM1=PMAS(KFC1,1)**2/SH
12878 RM2=PMAS(KFC2,1)**2/SH
12879 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
12885 WDTP(I)=FAC*3D0*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,
12886 & 1D0-4D0*RM1))*RADC
12887 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) WDTP(I)=WDTP(I)*
12888 & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
12889 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
12890 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12891 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
12892 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
12894 IF(I.EQ.6) WID2=WIDS(6,1)
12895 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12897 ELSEIF(I.LE.12) THEN
12899 WDTP(I)=FAC*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12900 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
12901 & PARU(153+10*IHIGG)**2
12902 IF(I.EQ.12) WID2=WIDS(17,1)
12904 ELSEIF(I.EQ.13) THEN
12905 C...h0 -> g + g; quark loop contribution only
12908 DO 230 J=1,2*MSTP(1)
12909 EPS=(2D0*PMAS(J,1))**2/SH
12910 C...Loop integral; function of eps=4m^2/shat; different for A0.
12911 IF(EPS.LE.1D0) THEN
12912 IF(EPS.GT.1.D-4) THEN
12914 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
12916 RLN=LOG(4D0/EPS-2D0)
12918 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
12919 PHIIM=0.5D0*PARU(1)*RLN
12921 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
12924 IF(IHIGG.LE.2) THEN
12925 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
12926 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
12928 ETAREJ=-0.5D0*EPS*PHIRE
12929 ETAIMJ=-0.5D0*EPS*PHIIM
12931 C...Couplings (=1 for standard model Higgs).
12932 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12933 IF(MOD(J,2).EQ.1) THEN
12934 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
12935 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
12937 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
12938 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
12944 ETA2=ETARE**2+ETAIM**2
12945 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
12947 ELSEIF(I.EQ.14) THEN
12948 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
12952 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
12954 IF(J.LE.2*MSTP(1)) THEN
12956 EPS=(2D0*PMAS(J,1))**2/SH
12957 ELSEIF(J.LE.3*MSTP(1)) THEN
12958 JL=2*(J-2*MSTP(1))-1
12959 EJ=KCHG(10+JL,1)/3D0
12960 EPS=(2D0*PMAS(10+JL,1))**2/SH
12961 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
12962 EPS=(2D0*PMAS(24,1))**2/SH
12964 EPS=(2D0*PMAS(37,1))**2/SH
12966 C...Loop integral; function of eps=4m^2/shat.
12967 IF(EPS.LE.1D0) THEN
12968 IF(EPS.GT.1.D-4) THEN
12970 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
12972 RLN=LOG(4D0/EPS-2D0)
12974 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
12975 PHIIM=0.5D0*PARU(1)*RLN
12977 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
12980 IF(J.LE.3*MSTP(1)) THEN
12981 C...Fermion loops: loop integral different for A0; charges.
12982 IF(IHIGG.LE.2) THEN
12983 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
12984 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
12986 PHIPRE=-0.5D0*EPS*PHIRE
12987 PHIPIM=-0.5D0*EPS*PHIIM
12989 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
12991 EJH=PARU(151+10*IHIGG)
12992 ELSEIF(J.LE.2*MSTP(1)) THEN
12994 EJH=PARU(152+10*IHIGG)
12997 EJH=PARU(153+10*IHIGG)
12999 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13000 ETAREJ=EJC*EJH*PHIPRE
13001 ETAIMJ=EJC*EJH*PHIPIM
13002 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13003 C...W loops: loop integral and charges.
13004 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
13005 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
13006 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13007 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13008 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13011 C...Charged H loops: loop integral and charges.
13012 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
13013 & PARU(158+10*IHIGG+2*(IHIGG/3))
13014 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
13015 ETAIMJ=-EPS**2*PHIIM*FACHHH
13020 ETA2=ETARE**2+ETAIM**2
13021 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
13023 ELSEIF(I.EQ.15) THEN
13024 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
13028 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
13030 IF(J.LE.2*MSTP(1)) THEN
13032 AJ=SIGN(1D0,EJ+0.1D0)
13034 EPS=(2D0*PMAS(J,1))**2/SH
13035 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
13036 ELSEIF(J.LE.3*MSTP(1)) THEN
13037 JL=2*(J-2*MSTP(1))-1
13038 EJ=KCHG(10+JL,1)/3D0
13039 AJ=SIGN(1D0,EJ+0.1D0)
13041 EPS=(2D0*PMAS(10+JL,1))**2/SH
13042 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
13044 EPS=(2D0*PMAS(24,1))**2/SH
13045 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
13047 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
13048 IF(EPS.LE.1D0) THEN
13050 IF(EPS.GT.1.D-4) THEN
13051 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13053 RLN=LOG(4D0/EPS-2D0)
13055 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
13056 PHIIM=0.5D0*PARU(1)*RLN
13057 PSIRE=0.5D0*ROOT*RLN
13058 PSIIM=-0.5D0*ROOT*PARU(1)
13060 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
13062 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
13065 IF(EPSP.LE.1D0) THEN
13066 ROOT=SQRT(1D0-EPSP)
13067 IF(EPSP.GT.1.D-4) THEN
13068 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13070 RLN=LOG(4D0/EPSP-2D0)
13072 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
13073 PHIIMP=0.5D0*PARU(1)*RLN
13074 PSIREP=0.5D0*ROOT*RLN
13075 PSIIMP=-0.5D0*ROOT*PARU(1)
13077 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
13079 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
13082 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
13083 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
13084 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
13085 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
13086 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
13087 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
13088 IF(J.LE.3*MSTP(1)) THEN
13089 C...Fermion loops: loop integral different for A0; charges.
13090 IF(IHIGG.EQ.3) FXYRE=0D0
13091 IF(IHIGG.EQ.3) FXYIM=0D0
13092 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
13094 EJH=PARU(151+10*IHIGG)
13095 ELSEIF(J.LE.2*MSTP(1)) THEN
13097 EJH=PARU(152+10*IHIGG)
13100 EJH=PARU(153+10*IHIGG)
13102 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13103 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
13104 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
13105 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13106 C...W loops: loop integral and charges.
13107 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
13108 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
13109 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
13110 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13111 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13112 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13115 C...Charged H loops: loop integral and charges.
13116 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
13117 & PARU(158+10*IHIGG+2*(IHIGG/3))
13118 ETAREJ=FACHHH*FXYRE
13119 ETAIMJ=FACHHH*FXYIM
13124 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
13125 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
13128 ELSEIF(I.LE.17) THEN
13129 C...h0 -> Z0 + Z0, W+ + W-
13130 PM1=PMAS(IABS(KFDP(IDC,1)),1)
13131 PG1=PMAS(IABS(KFDP(IDC,1)),2)
13132 IF(MINT(62).GE.1) THEN
13133 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
13134 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
13135 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
13136 MOFSV(IHIGG,I-15)=0
13137 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13141 MOFSV(IHIGG,I-15)=1
13142 RMAS=SQRT(MAX(0D0,SH))
13143 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
13145 WIDWSV(IHIGG,I-15)=WIDW
13146 WID2SV(IHIGG,I-15)=WID2
13149 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
13150 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13154 WIDW=WIDWSV(IHIGG,I-15)
13155 WID2=WID2SV(IHIGG,I-15)
13158 WDTP(I)=FAC*WIDW/(2D0*(18-I))
13159 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
13160 & PARU(138+I+10*IHIGG)**2
13161 WID2=WID2*WIDS(7+I,1)
13163 ELSEIF(I.EQ.18.AND.KFLA.EQ.35) THEN
13164 C***H0 -> Z0 + h0 (not yet implemented).
13166 ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN
13168 WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2*
13169 & SQRT(MAX(0D0,1D0-4D0*RM1))
13172 ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN
13174 WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2*
13175 & SQRT(MAX(0D0,1D0-4D0*RM1))
13178 ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN
13180 WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0,
13181 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13182 WID2=WIDS(23,2)*WIDS(25,2)
13186 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13189 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13190 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13191 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13196 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13198 IF(KFC2.EQ.KFC1) THEN
13202 IF(KFDP(IDC,1).LT.0) KSGN1=3
13204 IF(KFDP(IDC,2).LT.0) KSGN2=3
13205 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13208 WDTP(0)=WDTP(0)+WDTP(I)
13209 IF(MDME(IDC,1).GT.0) THEN
13210 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13211 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13212 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13213 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13217 ELSEIF(KFLA.EQ.32) THEN
13220 XWC=1D0/(16D0*XW*XW1)
13221 FAC=(AEM*XWC/3D0)*SHR
13224 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
13232 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13233 KFAI=IABS(MINT(15))
13234 EI=KCHG(KFAI,1)/3D0
13235 AI=SIGN(1D0,EI+0.1D0)
13238 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13239 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13240 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13241 VPI=PARU(119+2*KFAIC)
13242 API=PARU(120+2*KFAIC)
13244 HZ=SHR*FAC*VINT(117)
13245 SQMZP=PMAS(32,1)**2
13246 HZP=SHR*FAC*WDTP(0)
13247 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13248 & MSTP(44).EQ.7) VINT(111)=1D0
13249 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
13250 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
13251 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
13252 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
13253 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13254 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
13255 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
13256 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
13257 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
13258 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13259 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
13261 DO 280 I=1,MDCY(KC,3)
13263 IF(MDME(IDC,1).LT.0) GOTO 280
13264 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13265 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13266 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 280
13270 C...Z'0 -> q + qbar
13272 AF=SIGN(1D0,EF+0.1D0)
13274 VPF=PARU(123-2*MOD(I,2))
13275 APF=PARU(124-2*MOD(I,2))
13277 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
13278 & PYHFTH(SH,SH*RM1,1D0)
13279 IF(I.EQ.6) WID2=WIDS(6,1)
13280 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
13281 ELSEIF(I.LE.16) THEN
13282 C...Z'0 -> l+ + l-, nu + nubar
13284 AF=SIGN(1D0,EF+0.1D0)
13286 VPF=PARU(127-2*MOD(I,2))
13287 APF=PARU(128-2*MOD(I,2))
13289 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
13291 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
13292 IF(ICASE.EQ.1) THEN
13293 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13294 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
13295 & APF**2*(1D0-4D0*RM1))*BE34
13296 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13297 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
13298 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13299 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
13300 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
13301 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
13302 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
13303 ELSEIF(MINT(61).EQ.2) THEN
13304 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
13305 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
13306 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
13307 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13308 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
13310 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
13313 ELSEIF(I.EQ.17) THEN
13315 WDTPZP=PARU(129)**2*XW1**2*
13316 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13317 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13318 IF(ICASE.EQ.1) THEN
13321 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13322 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13323 ELSEIF(MINT(61).EQ.2) THEN
13332 ELSEIF(I.EQ.18) THEN
13334 CZC=2D0*(1D0-2D0*XW)
13335 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
13336 IF(ICASE.EQ.1) THEN
13337 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
13338 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
13339 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13340 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
13341 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
13342 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
13343 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
13344 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
13345 ELSEIF(MINT(61).EQ.2) THEN
13347 FGZF=0.25D0*PARU(142)*CZC*BE34C
13348 FGZPF=0.25D0*PARU(143)*CZC*BE34C
13349 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
13350 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
13351 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
13354 ELSEIF(I.EQ.19) THEN
13355 C...Z'0 -> Z0 + gamma.
13356 ELSEIF(I.EQ.20) THEN
13358 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13359 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
13360 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
13361 IF(ICASE.EQ.1) THEN
13364 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13365 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13366 ELSEIF(MINT(61).EQ.2) THEN
13374 WID2=WIDS(23,2)*WIDS(25,2)
13375 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
13376 C...Z' -> h0 + A0 or H0 + A0.
13377 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13385 IF(ICASE.EQ.1) THEN
13386 WDTPZ=CZAH**2*BE34C
13387 WDTP(I)=FAC*CZPAH**2*BE34C
13388 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13389 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
13390 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
13392 ELSEIF(MINT(61).EQ.2) THEN
13397 FZZPF=CZAH*CZPAH*BE34C
13398 FZPZPF=CZPAH**2*BE34C
13400 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
13401 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
13403 IF(ICASE.EQ.1) THEN
13404 VINT(117)=VINT(117)+WDTPZ
13405 WDTP(0)=WDTP(0)+WDTP(I)
13407 IF(MDME(IDC,1).GT.0) THEN
13408 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
13409 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
13410 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13411 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
13412 & WDTE(I,MDME(IDC,1))
13413 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13414 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13416 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
13417 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13418 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
13419 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
13421 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
13423 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13424 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
13425 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
13427 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13428 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
13432 IF(MINT(61).GE.1) ICASE=3-ICASE
13433 IF(ICASE.EQ.2) GOTO 270
13435 ELSEIF(KFLA.EQ.34) THEN
13437 FAC=(AEM/(24D0*XW))*SHR
13438 DO 290 I=1,MDCY(KC,3)
13440 IF(MDME(IDC,1).LT.0) GOTO 290
13441 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13442 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13443 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 290
13447 C...W'+/- -> q + qbar'
13448 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
13449 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
13451 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
13452 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
13453 IF(I.GE.13) WID2=WID2*WIDS(7,3)
13455 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
13456 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
13457 IF(I.GE.13) WID2=WID2*WIDS(7,2)
13459 ELSEIF(I.LE.20) THEN
13460 C...W'+/- -> l+/- + nu
13461 FCOF=PARU(133)**2+PARU(134)**2
13463 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13465 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13468 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13469 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13470 ELSEIF(I.EQ.21) THEN
13471 C...W'+/- -> W+/- + Z0
13472 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
13473 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13474 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13475 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
13476 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
13477 ELSEIF(I.EQ.23) THEN
13478 C...W'+/- -> W+/- + h0
13479 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13480 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
13481 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13482 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13484 WDTP(0)=WDTP(0)+WDTP(I)
13485 IF(MDME(IDC,1).GT.0) THEN
13486 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13487 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13488 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13489 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13493 ELSEIF(KFLA.EQ.37) THEN
13495 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
13496 DO 300 I=1,MDCY(KC,3)
13498 IF(MDME(IDC,1).LT.0) GOTO 300
13499 KFC1=PYCOMP(KFDP(IDC,1))
13500 KFC2=PYCOMP(KFDP(IDC,2))
13501 RM1=PMAS(KFC1,1)**2/SH
13502 RM2=PMAS(KFC2,1)**2/SH
13503 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
13506 C...H+/- -> q + qbar'
13508 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) RM1R=RM1*
13509 & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
13510 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
13511 WDTP(I)=FAC*3D0*RADC*((RM1R*PARU(141)**2+RM2/PARU(141)**2)*
13512 & (1D0-RM1R-RM2)-4D0*RM1R*RM2)*
13513 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13515 IF(I.EQ.3) WID2=WIDS(6,2)
13516 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
13518 IF(I.EQ.3) WID2=WIDS(6,3)
13519 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
13521 ELSEIF(I.LE.8) THEN
13522 C...H+/- -> l+/- + nu
13523 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
13524 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-
13527 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
13529 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
13531 ELSEIF(I.EQ.9) THEN
13532 C...H+/- -> W+/- + h0.
13533 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
13534 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13535 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13536 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13540 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13543 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13544 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13545 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13550 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13553 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
13555 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
13556 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13558 WDTP(0)=WDTP(0)+WDTP(I)
13559 IF(MDME(IDC,1).GT.0) THEN
13560 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13561 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13562 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13563 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13567 ELSEIF(KFLA.EQ.38) THEN
13569 FAC=(SH/PARP(46)**2)*SHR
13570 DO 310 I=1,MDCY(KC,3)
13572 IF(MDME(IDC,1).LT.0) GOTO 310
13573 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13574 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13575 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
13578 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
13579 IF(I.EQ.2) WID2=WIDS(6,1)
13581 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
13583 WDTP(0)=WDTP(0)+WDTP(I)
13584 IF(MDME(IDC,1).GT.0) THEN
13585 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13586 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13587 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13588 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13592 ELSEIF(KFLA.EQ.39) THEN
13593 C...LQ (leptoquark).
13594 FAC=(AEM/4D0)*PARU(151)*SHR
13595 DO 320 I=1,MDCY(KC,3)
13597 IF(MDME(IDC,1).LT.0) GOTO 320
13598 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13599 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13600 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
13601 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13603 WDTP(0)=WDTP(0)+WDTP(I)
13604 IF(MDME(IDC,1).GT.0) THEN
13605 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13606 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13607 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13608 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13612 ELSEIF(KFLA.EQ.40) THEN
13614 FAC=(AEM/(12D0*XW))*SHR
13615 DO 330 I=1,MDCY(KC,3)
13617 IF(MDME(IDC,1).LT.0) GOTO 330
13618 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13619 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13620 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
13625 ELSEIF(I.LE.9) THEN
13629 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
13630 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13632 IF(I.EQ.4) WID2=WIDS(6,3)
13633 IF(I.EQ.5) WID2=WIDS(7,3)
13634 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
13635 IF(I.EQ.9) WID2=WIDS(17,3)
13637 IF(I.EQ.4) WID2=WIDS(6,2)
13638 IF(I.EQ.5) WID2=WIDS(7,2)
13639 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
13640 IF(I.EQ.9) WID2=WIDS(17,2)
13642 WDTP(0)=WDTP(0)+WDTP(I)
13643 IF(MDME(IDC,1).GT.0) THEN
13644 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13645 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13646 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13647 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13651 ELSEIF(KFLA.EQ.51.OR.KFLA.EQ.52) THEN
13652 C...Techni-pi0 and techni-pi+-:
13653 FAC=(3D0/(32D0*PARU(1)*PARP(142)**2))*SHR
13654 DO 340 I=1,MDCY(KC,3)
13656 IF(MDME(IDC,1).LT.0) GOTO 340
13657 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
13658 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
13661 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
13663 C...pi_tech -> f + f'.
13665 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
13666 WDTP(I)=FAC*FCOF*(PM1+PM2)**2*
13667 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13668 WDTP(0)=WDTP(0)+WDTP(I)
13669 IF(MDME(IDC,1).GT.0) THEN
13670 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13671 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13672 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13673 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13677 ELSEIF(KFLA.EQ.53) THEN
13678 C...Techni-pi'0 not yet implemented.
13680 ELSEIF(KFLA.EQ.54) THEN
13682 ALPRHT=2.91D0*(3D0/PARP(144))
13683 FAC=(ALPRHT/12D0)*SHR
13684 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)
13686 GMMZ=PMAS(23,1)*PMAS(23,2)
13687 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13688 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13689 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13690 DO 350 I=1,MDCY(KC,3)
13692 IF(MDME(IDC,1).LT.0) GOTO 350
13693 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13694 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13695 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 350
13697 C...rho_tech0 -> W+ + W-.
13698 WDTP(I)=FAC*PARP(141)**4*
13699 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13701 ELSEIF(I.EQ.2) THEN
13702 C...rho_tech0 -> W+ + pi_tech-.
13703 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13704 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13705 WID2=WIDS(24,2)*WIDS(52,3)
13706 ELSEIF(I.EQ.3) THEN
13707 C...rho_tech0 -> pi_tech+ + W-.
13708 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13709 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13710 WID2=WIDS(52,2)*WIDS(24,3)
13711 ELSEIF(I.EQ.4) THEN
13712 C...rho_tech0 -> pi_tech+ + pi_tech-.
13713 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13714 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13717 C...rho_tech0 -> f + fbar.
13722 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13726 IF(IA.GE.17) WID2=WIDS(IA,1)
13729 AI=SIGN(1D0,EI+0.1D0)
13733 WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13734 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
13735 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
13737 WDTP(0)=WDTP(0)+WDTP(I)
13738 IF(MDME(IDC,1).GT.0) THEN
13739 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13740 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13741 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13742 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13746 ELSEIF(KFLA.EQ.55) THEN
13748 ALPRHT=2.91D0*(3D0/PARP(144))
13749 FAC=(ALPRHT/12D0)*SHR
13751 GMMW=PMAS(24,1)*PMAS(24,2)
13752 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13753 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
13754 DO 360 I=1,MDCY(KC,3)
13756 IF(MDME(IDC,1).LT.0) GOTO 360
13757 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13758 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13759 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
13761 C...rho_tech+ -> W+ + Z0.
13762 WDTP(I)=FAC*PARP(141)**4*
13763 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13765 WID2=WIDS(24,2)*WIDS(23,2)
13767 WID2=WIDS(24,3)*WIDS(23,2)
13769 ELSEIF(I.EQ.2) THEN
13770 C...rho_tech+ -> W+ + pi_tech0.
13771 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13772 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13774 WID2=WIDS(24,2)*WIDS(51,2)
13776 WID2=WIDS(24,3)*WIDS(51,2)
13778 ELSEIF(I.EQ.3) THEN
13779 C...rho_tech+ -> pi_tech+ + Z0.
13780 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13781 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13783 WID2=WIDS(52,2)*WIDS(23,2)
13785 WID2=WIDS(52,3)*WIDS(23,2)
13787 ELSEIF(I.EQ.4) THEN
13788 C...rho_tech+ -> pi_tech+ + pi_tech0.
13789 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13790 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13792 WID2=WIDS(52,2)*WIDS(51,2)
13794 WID2=WIDS(52,3)*WIDS(51,2)
13797 C...rho_tech+ -> f + fbar'.
13801 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
13803 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
13804 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
13805 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
13807 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
13808 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
13809 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
13814 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13816 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13819 WDTP(I)=FACF*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13820 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13822 WDTP(0)=WDTP(0)+WDTP(I)
13823 IF(MDME(IDC,1).GT.0) THEN
13824 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13825 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13826 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13827 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13831 ELSEIF(KFLA.EQ.56) THEN
13833 ALPRHT=2.91D0*(3D0/PARP(144))
13834 FAC=(AEM/24D0)*(SHR**3/PARP(145)**2)
13835 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13836 & (2D0*PARP(143)-1D0)**2
13838 GMMZ=PMAS(23,1)*PMAS(23,2)
13839 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13840 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13841 DO 370 I=1,MDCY(KC,3)
13843 IF(MDME(IDC,1).LT.0) GOTO 370
13844 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13845 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13846 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
13848 C...omega_tech0 -> gamma + pi_tech0.
13850 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13852 ELSEIF(I.EQ.2) THEN
13853 C...omega_tech0 -> Z0 + pi_tech0 not known.
13855 WID2=WIDS(23,2)*WIDS(51,2)
13857 C...omega_tech0 -> f + fbar.
13862 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13866 IF(IA.GE.17) WID2=WIDS(IA,1)
13869 AI=SIGN(1D0,EI+0.1D0)
13873 WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13874 & ((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
13875 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
13877 WDTP(0)=WDTP(0)+WDTP(I)
13878 IF(MDME(IDC,1).GT.0) THEN
13879 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13880 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13881 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13882 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13886 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
13887 C...d* excited quark.
13888 FAC=(SH/PARU(155)**2)*SHR
13889 DO 380 I=1,MDCY(KC,3)
13891 IF(MDME(IDC,1).LT.0) GOTO 380
13892 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13893 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13894 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
13897 WDTP(I)=FAC*AS*PARU(159)**2/3D0
13899 ELSEIF(I.EQ.2) THEN
13900 C...d* -> gamma + d.
13901 QF=-PARU(157)/2D0+PARU(158)/6D0
13902 WDTP(I)=FAC*AEM*QF**2/4D0
13904 ELSEIF(I.EQ.3) THEN
13906 QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13907 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13908 & (1D0-RM1)**2*(2D0+RM1)
13910 ELSEIF(I.EQ.4) THEN
13912 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13913 & (1D0-RM1)**2*(2D0+RM1)
13914 IF(KFLR.GT.0) WID2=WIDS(24,3)
13915 IF(KFLR.LT.0) WID2=WIDS(24,2)
13917 WDTP(0)=WDTP(0)+WDTP(I)
13918 IF(MDME(IDC,1).GT.0) THEN
13919 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13920 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13921 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13922 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13926 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
13927 C...u* excited quark.
13928 FAC=(SH/PARU(155)**2)*SHR
13929 DO 390 I=1,MDCY(KC,3)
13931 IF(MDME(IDC,1).LT.0) GOTO 390
13932 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13933 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13934 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
13937 WDTP(I)=FAC*AS*PARU(159)**2/3D0
13939 ELSEIF(I.EQ.2) THEN
13940 C...u* -> gamma + u.
13941 QF=PARU(157)/2D0+PARU(158)/6D0
13942 WDTP(I)=FAC*AEM*QF**2/4D0
13944 ELSEIF(I.EQ.3) THEN
13946 QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13947 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13948 & (1D0-RM1)**2*(2D0+RM1)
13950 ELSEIF(I.EQ.4) THEN
13952 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13953 & (1D0-RM1)**2*(2D0+RM1)
13954 IF(KFLR.GT.0) WID2=WIDS(24,2)
13955 IF(KFLR.LT.0) WID2=WIDS(24,3)
13957 WDTP(0)=WDTP(0)+WDTP(I)
13958 IF(MDME(IDC,1).GT.0) THEN
13959 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13960 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13961 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13962 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13966 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
13967 C...e* excited lepton.
13968 FAC=(SH/PARU(155)**2)*SHR
13969 DO 400 I=1,MDCY(KC,3)
13971 IF(MDME(IDC,1).LT.0) GOTO 400
13972 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13973 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13974 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 400
13976 C...e* -> gamma + e.
13977 QF=-PARU(157)/2D0-PARU(158)/2D0
13978 WDTP(I)=FAC*AEM*QF**2/4D0
13980 ELSEIF(I.EQ.2) THEN
13982 QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
13983 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13984 & (1D0-RM1)**2*(2D0+RM1)
13986 ELSEIF(I.EQ.3) THEN
13988 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13989 & (1D0-RM1)**2*(2D0+RM1)
13990 IF(KFLR.GT.0) WID2=WIDS(24,3)
13991 IF(KFLR.LT.0) WID2=WIDS(24,2)
13993 WDTP(0)=WDTP(0)+WDTP(I)
13994 IF(MDME(IDC,1).GT.0) THEN
13995 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13996 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13997 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13998 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14002 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
14003 C...nu*_e excited neutrino.
14004 FAC=(SH/PARU(155)**2)*SHR
14005 DO 410 I=1,MDCY(KC,3)
14007 IF(MDME(IDC,1).LT.0) GOTO 410
14008 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14009 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14010 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
14012 C...nu*_e -> Z0 + nu*_e.
14013 QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
14014 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
14015 & (1D0-RM1)**2*(2D0+RM1)
14017 ELSEIF(I.EQ.2) THEN
14018 C...nu*_e -> W+ + e.
14019 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14020 & (1D0-RM1)**2*(2D0+RM1)
14021 IF(KFLR.GT.0) WID2=WIDS(24,2)
14022 IF(KFLR.LT.0) WID2=WIDS(24,3)
14024 WDTP(0)=WDTP(0)+WDTP(I)
14025 IF(MDME(IDC,1).GT.0) THEN
14026 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14027 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14028 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14029 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14041 C***********************************************************************
14044 C...Calculates partial width and differential cross-section maxima
14045 C...of channels/processes not allowed on mass-shell, and selects
14046 C...masses in such channels/processes.
14048 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
14050 C...Double precision and integer declarations.
14051 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14052 INTEGER PYK,PYCHGE,PYCOMP
14054 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14055 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14056 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
14057 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14058 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14059 COMMON/PYINT1/MINT(400),VINT(400)
14060 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14061 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14062 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
14065 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
14066 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
14067 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:200),
14070 C...Find if particles equal, maximum mass, matrix elements, etc.
14076 IF(KFD(1).EQ.KFD(2)) MEQL=1
14078 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
14079 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
14085 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
14088 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
14089 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
14090 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
14091 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
14092 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
14093 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
14096 C...Find where Breit-Wigners are required, else select discrete masses.
14098 KFCA=PYCOMP(KFD(I))
14100 PMD(I)=PMAS(KFCA,1)
14101 PGD(I)=PMAS(KFCA,2)
14106 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
14109 RMG(I)=(PMG(I)/PMMX)**2
14115 C...Find allowed mass range and Breit-Wigner parameters.
14117 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
14119 PMU(I)=PMMX-PARP(42)
14120 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14121 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14122 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
14124 IF(MLM.EQ.2) ILM=3-I
14125 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
14126 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
14127 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=MIN(PMU(I),
14128 & CKIN(NOFF+2*ILM))
14129 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14130 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14131 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14132 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14133 IF(MBW(I).EQ.1) THEN
14134 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14135 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14136 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14139 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
14141 IF(MLM.EQ.2) ILM=3-I
14142 PML(I)=MAX(CKIN(48+I),PARP(42))
14143 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
14144 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14145 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14146 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14147 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14148 IF(MBW(I).EQ.1) THEN
14149 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14150 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14151 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14156 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
14158 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
14163 C...Calculation of partial width of resonance.
14164 IF(MOFSH.EQ.1) THEN
14166 C..If only one integration, pick that to be the inner.
14167 IF(MBW(1).EQ.0) THEN
14173 ELSEIF(MBW(2).EQ.0) THEN
14177 C...Start outer loop of integration.
14178 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14179 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14180 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14186 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14187 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
14188 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
14192 C...Start inner loop of integration.
14194 PMU1=MIN(PMU(1),PMMX-PM2)
14195 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
14196 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14197 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14198 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
14206 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
14207 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
14210 C...Evaluate function value - inner loop.
14211 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
14212 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
14213 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
14214 & RM2**2+10D0*RM1*RM2)
14215 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
14218 C...Go to next position in inner loop.
14224 ELSEIF(NPT1.LE.8) THEN
14226 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
14228 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14229 INX1(NPT1)=INX1(ISH1)
14232 ELSEIF(NPT1.LT.100) THEN
14235 IF(ISH1.GT.NPT1) ISH1=2
14236 IF(ISH1.EQ.ISN1) GOTO 160
14237 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
14238 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
14240 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14241 INX1(NPT1)=INX1(ISH1)
14246 C...Calculate integral over inner loop.
14249 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
14250 & (XPT1(INX1(IPT1))-XPT1(IPT1))
14252 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
14253 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14254 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
14257 C...Go to next position in outer loop.
14263 ELSEIF(NPT2.LE.8) THEN
14265 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
14267 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14268 INX2(NPT2)=INX2(ISH2)
14271 ELSEIF(NPT2.LT.100) THEN
14274 IF(ISH2.GT.NPT2) ISH2=2
14275 IF(ISH2.EQ.ISN2) GOTO 200
14276 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
14277 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
14279 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14280 INX2(NPT2)=INX2(ISH2)
14285 C...Calculate integral over outer loop.
14288 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
14289 & (XPT2(INX2(IPT2))-XPT2(IPT2))
14291 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
14292 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
14297 C...Save result; second integration for user-selected mass range.
14298 IF(LOOP.EQ.1) WIDW=FSUM2
14300 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
14301 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
14308 C...Select two decay product masses of a resonance.
14309 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
14311 IF(MBW(I).EQ.0) GOTO 230
14312 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
14314 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
14315 RMG(I)=(PMG(I)/PMMX)**2
14317 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14318 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
14320 C...Weight with matrix element (if none known, use beta factor).
14321 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
14323 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
14324 ELSEIF(MMED.EQ.2) THEN
14325 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
14326 & RMG(2)**2+10D0*RMG(1)*RMG(2))
14327 ELSEIF(MMED.EQ.3) THEN
14328 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
14332 IF(WTBE.LT.PYR(0)) GOTO 220
14336 C...Find suitable set of masses for initialization of 2 -> 2 processes.
14337 ELSEIF(MOFSH.EQ.3) THEN
14338 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
14339 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
14341 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
14343 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
14347 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
14348 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
14349 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
14354 C...Evaluate importance of excluded tails of Breit-Wigners.
14355 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14356 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14360 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
14364 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
14365 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
14367 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
14368 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
14369 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
14370 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14372 C...Pick one particle to be the lighter (if improves efficiency).
14373 ELSEIF(MOFSH.EQ.4) THEN
14374 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14375 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14376 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
14378 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
14380 IF(MBW(I).EQ.0) GOTO 270
14382 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14384 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14386 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14387 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
14388 IF(RBR.LT.0.8D0) THEN
14389 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
14390 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
14391 ELSEIF(RBR.LT.0.9D0) THEN
14392 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
14393 ELSEIF(RBR.LT.1.5D0) THEN
14394 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
14396 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
14397 & (PMV**2-PML(I)**2))))
14400 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14401 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
14402 IF(MINT(48).EQ.1) THEN
14403 NGEN(0,1)=NGEN(0,1)+1
14404 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
14414 C...Give weight for selected mass distribution.
14417 IF(MBW(I).EQ.0) GOTO 280
14419 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14421 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14422 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
14423 & (PMD(I)*PGD(I))**2)/PARU(1)
14427 FI0=(ATV-ATL(I))/PARU(1)
14428 FI1=PMV**2-PML(I)**2
14429 FI2=2D0*LOG(PMV/PML(I))
14430 FI3=1D0/PML(I)**2-1D0/PMV**2
14431 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14432 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
14433 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
14436 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
14438 VINT(80)=VINT(80)*FI0
14440 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14446 C***********************************************************************
14449 C...Handles the possibility of colour reconnection in W+W- events,
14450 C...Based on the main scenarios of the Sjostrand and Khoze study:
14451 C...I, II, II', intermediate and instantaneous; plus one model
14452 C...along the lines of the Gustafson and Hakkinen: GH.
14454 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
14456 C...Double precision and integer declarations.
14457 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14458 INTEGER PYK,PYCHGE,PYCOMP
14459 C...Parameter value; number of points in MC integration.
14460 PARAMETER (NPT=100)
14462 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14463 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14464 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14465 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14466 COMMON/PYINT1/MINT(400),VINT(400)
14467 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14469 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
14470 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
14471 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
14472 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
14473 &TMC(20),IJOIN(100)
14475 C...Functions to give four-product and to do determinants.
14476 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)
14477 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
14478 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
14479 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
14481 C...Only allow fraction of recoupling for GH, intermediate and
14483 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14484 IF(PYR(0).GT.PARP(120)) RETURN
14487 C...Common part for scenarios I, II, II', and GH.
14488 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
14489 &MSTP(115).EQ.5) THEN
14491 C...Read out frequently-used parameters.
14502 C...Find range of decay products of the W's.
14503 C...Background: the W's are stored in IW1 and IW2.
14504 C...Their direct decay products in NSD1+1 through NSD1+4.
14505 C...Products after shower (if any) in NSD1+5 through NAFT1
14506 C...for first W and in NAFT1+1 through N for the second.
14507 IF(K(IW1,2).GT.0) THEN
14513 IF(NAFT1.GT.NSD1+4) THEN
14520 IF(N.GT.NAFT1) THEN
14528 C...Rearrange parton shower products along strings.
14530 CALL PYPREP(NSD1+1)
14532 C...Find partons pointing back to W+ and W-; store them with quark
14533 C...end of string first.
14539 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
14540 IF(IABS(K(I,2)).GE.22) GOTO 120
14541 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
14542 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
14552 IF(K(I,1).EQ.1) ISGP=0
14553 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
14554 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
14564 IF(K(I,1).EQ.1) ISGM=0
14568 C...Boost to W+W- rest frame (not strictly needed).
14570 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
14572 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14573 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14574 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14576 C...Select decay vertices of W+ and W-.
14577 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
14578 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
14579 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
14580 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
14583 XP(J)=TP*P(IW1,J)/P(IW1,4)
14584 XM(J)=TM*P(IW2,J)/P(IW2,4)
14587 C...Begin scenario I specifics.
14588 IF(MSTP(115).EQ.1) THEN
14590 C...Reconstruct velocity and direction of W+ string pieces.
14592 IF(K(INP(IIP),2).LT.0) GOTO 170
14595 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14596 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14600 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
14601 DIRP(IIP,J)=V1(J)-V2(J)
14603 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
14605 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
14607 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
14611 C...Reconstruct velocity and direction of W- string pieces.
14613 IF(K(INM(IIM),2).LT.0) GOTO 200
14616 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14617 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14621 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
14622 DIRM(IIM,J)=V1(J)-V2(J)
14624 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
14626 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
14628 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
14632 C...Loop over number of space-time points.
14637 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
14638 R=SQRT(-LOG(PYR(0)))
14640 X=BLOWR*RHAD*R*COS(PHI)
14641 Y=BLOWR*RHAD*R*SIN(PHI)
14642 R=SQRT(-LOG(PYR(0)))
14644 Z=BLOWR*RHAD*R*COS(PHI)
14645 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
14647 C...Weight for sample distribution.
14648 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
14649 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
14651 C...Loop over W+ string pieces and find one with largest weight.
14659 IF(K(INP(IIP),2).LT.0) GOTO 220
14660 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
14661 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
14663 XB(J)=XD(J)+BEDG*BETP(IIP,J)
14665 XB(4)=BETP(IIP,4)*(XD(4)-BED)
14666 SR2=XB(1)**2+XB(2)**2+XB(3)**2
14667 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
14668 & DIRP(IIP,3)*XB(3))**2
14669 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14671 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
14672 IF(WTP.GT.WTMAXP) THEN
14678 C...Loop over W- string pieces and find one with largest weight.
14686 IF(K(INM(IIM),2).LT.0) GOTO 240
14687 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
14688 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
14690 XB(J)=XD(J)+BEDG*BETM(IIM,J)
14692 XB(4)=BETM(IIM,4)*(XD(4)-BED)
14693 SR2=XB(1)**2+XB(2)**2+XB(3)**2
14694 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
14695 & DIRM(IIM,3)*XB(3))**2
14696 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14698 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
14699 IF(WTM.GT.WTMAXM) THEN
14705 C...Result of integration.
14707 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
14708 WT=WTMAXP*WTMAXM/WTSMP
14716 RES=BLOWR**3*BLOWT*SUM/NPT
14718 C...Decide whether to reconnect and, if so, where.
14720 PREC=1D0-EXP(-FACT*RES)
14721 IF(PREC.GT.PYR(0)) THEN
14726 IF(RSUM.LE.0D0) GOTO 270
14732 C...Begin scenario II and II' specifics.
14733 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
14735 C...Loop through all string pieces, one from W+ and one from W-.
14739 IF(K(INP(IIP),2).LT.0) GOTO 340
14743 IF(K(INM(IIM),2).LT.0) GOTO 330
14747 C...Find endpoint velocity vectors.
14749 V1P(J)=P(I1P,J)/P(I1P,4)
14750 V2P(J)=P(I2P,J)/P(I2P,4)
14751 V1M(J)=P(I1M,J)/P(I1M,4)
14752 V2M(J)=P(I2M,J)/P(I2M,4)
14755 C...Define q matrix and find t.
14757 Q(1,J)=V2P(J)-V1P(J)
14758 Q(2,J)=-(V2M(J)-V1M(J))
14759 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
14760 Q(4,J)=V1P(J)-V1M(J)
14762 T=-DETER(1,2,3)/DETER(1,2,4)
14764 C...Find alpha and beta; i.e. coordinates of crossing point.
14767 S13=Q(3,1)+Q(4,1)*T
14770 S23=Q(3,2)+Q(4,2)*T
14771 DEN=S11*S22-S12*S21
14772 ALP=(S12*S23-S22*S13)/DEN
14773 BET=(S21*S13-S11*S23)/DEN
14775 C...Check if solution acceptable.
14777 IF(T.LT.GTMAX) IANSW=0
14778 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
14779 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
14781 C...Find point of crossing and check that not inconsistent.
14783 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
14784 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
14786 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
14787 & (XPP(3)-XMM(3))**2
14788 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
14789 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
14790 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
14792 C...Find string eigentimes at crossing.
14793 IF(IANSW.EQ.1) THEN
14794 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
14795 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
14796 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
14797 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
14803 C...Order crossings by time. End loop over crossings.
14804 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
14806 DO 310 I1=NCROSS,1,-1
14807 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
14827 C...Loop over crossings; find first (if any) acceptable one.
14829 IF(NCROSS.GE.1) THEN
14831 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
14832 IF(PNFRAG.GT.PYR(0)) THEN
14833 C...Scenario II: only compare with fragmentation time.
14834 IF(MSTP(115).EQ.2) THEN
14839 C...Scenario II': also require that string length decreases.
14847 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14848 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14849 IF(ELNEW.LT.ELOLD) THEN
14861 C...Begin scenario GH specifics.
14862 ELSEIF(MSTP(115).EQ.5) THEN
14864 C...Loop through all string pieces, one from W+ and one from W-.
14868 IF(K(INP(IIP),2).LT.0) GOTO 380
14872 IF(K(INM(IIM),2).LT.0) GOTO 370
14876 C...Look for largest decrease of (exponent of) Lambda measure.
14877 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14878 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14879 ELDIF=ELNEW/MAX(1D-10,ELOLD)
14880 IF(ELDIF.LT.ELMIN) THEN
14892 C...Common for scenarios I, II, II' and GH: reconnect strings.
14896 DO 390 IS=1,NNP+NNM
14900 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
14902 ELSEIF(IS.LE.IIP+NNM) THEN
14903 I=INM(IS-IIP-NNM+IIM)
14908 IF(K(I,2).LT.0) THEN
14909 CALL PYJOIN(NJOIN,IJOIN)
14914 C...Restore original event record if no reconnection.
14916 DO 400 I=NSD1+1,NOLD
14917 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
14918 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14919 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14928 C...Boost back system.
14929 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14930 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14931 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
14932 & BEWW(1),BEWW(2),BEWW(3))
14934 C...Common part for intermediate and instantaneous scenarios.
14935 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14938 C...Remove old shower products and reset showering ones.
14940 DO 420 I=NSD1+1,NSD1+4
14942 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14943 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14946 C...Identify quark-antiquark pairs.
14950 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
14953 C...Reconnect strings.
14956 CALL PYJOIN(2,IJOIN)
14959 CALL PYJOIN(2,IJOIN)
14961 C...Do new parton showers in intermediate scenario.
14962 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
14965 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
14966 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
14969 C...Do new parton showers in instantaneous scenario.
14970 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
14971 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
14972 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
14973 PPM=SQRT(MAX(0D0,PPM2))
14974 CALL PYSHOW(IQ1,IQ4,PPM)
14975 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
14976 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
14977 PPM=SQRT(MAX(0D0,PPM2))
14978 CALL PYSHOW(IQ3,IQ2,PPM)
14985 C***********************************************************************
14988 C...Checks generated variables against pre-set kinematical limits;
14989 C...also calculates limits on variables used in generation.
14991 SUBROUTINE PYKLIM(ILIM)
14993 C...Double precision and integer declarations.
14994 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14995 INTEGER PYK,PYCHGE,PYCOMP
14997 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14998 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14999 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15000 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15001 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15002 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15003 COMMON/PYINT1/MINT(400),VINT(400)
15004 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15005 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15008 C...Common kinematical expressions.
15012 IF(ISUB.EQ.96) GOTO 100
15016 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
15017 CKIN09=MAX(CKIN(9),CKIN(13))
15018 CKIN10=MIN(CKIN(10),CKIN(14))
15019 CKIN11=MAX(CKIN(11),CKIN(15))
15020 CKIN12=MIN(CKIN(12),CKIN(16))
15022 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
15023 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
15024 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
15025 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
15030 RM3=SQM3/(TAU*VINT(2))
15031 RM4=SQM4/(TAU*VINT(2))
15032 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
15035 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
15036 &PTHMIN=MAX(CKIN(3),CKIN(5))
15039 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
15040 C...pre-set kinematical limits.
15045 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
15046 X1=SQRT(TAUE)*EXP(YST)
15047 X2=SQRT(TAUE)*EXP(-YST)
15049 IF(MINT(47).NE.1) THEN
15050 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
15051 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
15052 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
15053 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
15055 IF(MINT(45).NE.1) THEN
15056 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
15058 IF(MINT(46).NE.1) THEN
15059 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
15061 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
15062 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
15063 EXPY3=MAX(1.D-10,(1D0+RM3-RM4+BE34*CTH)/
15064 & MAX(1.D-10,(1D0+RM3-RM4-BE34*CTH)))
15065 EXPY4=MAX(1.D-10,(1D0-RM3+RM4-BE34*CTH)/
15066 & MAX(1.D-10,(1D0-RM3+RM4+BE34*CTH)))
15067 Y3=YST+0.5D0*LOG(EXPY3)
15068 Y4=YST+0.5D0*LOG(EXPY4)
15073 STH=SQRT(MAX(0D0,1D0-CTH**2))
15074 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
15075 & CTH)**2-4D0*RM3))
15076 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
15077 & CTH)**2-4D0*RM4))
15078 IF(STH.GE.1.D-6) THEN
15079 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
15081 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
15083 ETA3=LOG(MIN(1.D10,MAX(1.D-10,EXPET3)))
15084 ETA4=LOG(MIN(1.D10,MAX(1.D-10,EXPET4)))
15085 ETALAR=MAX(ETA3,ETA4)
15086 ETASMA=MIN(ETA3,ETA4)
15088 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
15089 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
15090 CTSLAR=MIN(1D0,MAX(CTS3,CTS4))
15091 CTSSMA=MAX(-1D0,MIN(CTS3,CTS4))
15093 RPTS=4D0*VINT(71)**2/SH
15094 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
15095 RM34=MAX(1D-20,2D0*RM3*RM4)
15096 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15097 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15098 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
15099 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
15100 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
15101 IF(PTH.LT.PTHMIN) MINT(51)=1
15102 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
15103 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
15104 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
15105 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
15106 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
15107 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
15108 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
15109 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
15110 IF(THA.LT.CKIN(35)) MINT(51)=1
15111 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
15112 IF(UHA.LT.CKIN(37)) MINT(51)=1
15113 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
15115 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
15116 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
15117 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
15120 C...Additional cuts on W2 (approximately) in DIS.
15121 IF(ISUB.EQ.10) THEN
15123 IF(IABS(MINT(12)).LT.20) XBJ=X1
15125 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
15126 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
15127 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
15130 ELSEIF(ILIM.EQ.1) THEN
15131 C...Calculate limits on tau
15132 C...0) due to definition
15135 C...1) due to limits on subsystem mass
15136 TAUMN1=CKIN(1)**2/VINT(2)
15138 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
15139 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15140 TM3=SQRT(SQM3+PTHMIN**2)
15141 TM4=SQRT(SQM4+PTHMIN**2)
15143 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
15144 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
15146 C...3) due to limits on pT-hat and cos(theta-hat)
15147 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
15148 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
15150 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
15151 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
15152 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
15154 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
15155 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
15156 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
15157 C...4) due to limits on x1 and x2
15158 TAUMN4=CKIN(21)*CKIN(23)
15159 TAUMX4=CKIN(22)*CKIN(24)
15160 C...5) due to limits on xF
15162 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
15163 C...6) due to limits on that and uhat
15164 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
15166 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
15167 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
15169 C...Net effect of all separate limits.
15170 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
15171 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
15172 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15175 ELSEIF(MINT(47).EQ.5) THEN
15176 VINT(31)=MIN(VINT(31),0.999998D0)
15178 IF(VINT(31).LE.VINT(11)) MINT(51)=1
15180 ELSEIF(ILIM.EQ.2) THEN
15181 C...Calculate limits on y*
15183 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15185 C...0) due to kinematics
15188 C...1) due to explicit limits
15191 C...2) due to limits on x1
15192 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
15193 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
15194 C...3) due to limits on x2
15195 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
15196 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
15197 C...4) due to limits on xF
15198 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
15199 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
15200 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
15201 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
15202 C...5) due to simultaneous limits on y-large and y-small
15203 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
15204 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
15205 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
15206 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
15207 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
15208 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
15209 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15211 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
15212 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
15213 RZMX=BE34*MIN(CKIN(28),CTHLIM)
15214 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
15215 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
15216 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
15217 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
15218 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
15219 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
15221 C...Net effect of all separate limits.
15222 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
15223 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
15224 IF(MINT(47).EQ.1) THEN
15225 VINT(12)=-0.00001D0
15227 ELSEIF(MINT(47).EQ.2) THEN
15228 VINT(12)=0.99999D0*YSTMX0
15229 VINT(32)=1.00001D0*YSTMX0
15230 ELSEIF(MINT(47).EQ.3) THEN
15231 VINT(12)=-1.00001D0*YSTMX0
15232 VINT(32)=-0.99999D0*YSTMX0
15233 ELSEIF(MINT(47).EQ.5) THEN
15234 YSTEE=LOG(0.999999D0/TAURT)
15235 VINT(12)=MAX(VINT(12),-YSTEE)
15236 VINT(32)=MIN(VINT(32),YSTEE)
15238 IF(VINT(32).LE.VINT(12)) MINT(51)=1
15240 ELSEIF(ILIM.EQ.3) THEN
15241 C...Calculate limits on cos(theta-hat)
15243 C...0) due to definition
15248 C...1) due to explicit limits
15249 CTNMN1=MIN(0D0,CKIN(27))
15250 CTNMX1=MIN(0D0,CKIN(28))
15251 CTPMN1=MAX(0D0,CKIN(27))
15252 CTPMX1=MAX(0D0,CKIN(28))
15253 C...2) due to limits on pT-hat
15254 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
15258 IF(CKIN(4).GE.0D0) THEN
15259 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
15260 & (BE34**2*TAU*VINT(2))))
15263 C...3) due to limits on y-large and y-small
15264 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
15265 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
15266 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
15267 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
15268 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
15269 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
15270 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
15271 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
15272 C...4) due to limits on that
15278 IF(CKIN(35).GT.0D0) THEN
15279 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
15280 IF(CTLIM.GT.0D0) THEN
15287 IF(CKIN(36).GT.0D0) THEN
15288 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
15289 IF(CTLIM.LT.0D0) THEN
15296 C...5) due to limits on uhat
15301 IF(CKIN(37).GT.0D0) THEN
15302 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
15303 IF(CTLIM.LT.0D0) THEN
15310 IF(CKIN(38).GT.0D0) THEN
15311 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
15312 IF(CTLIM.GT.0D0) THEN
15320 C...Net effect of all separate limits.
15321 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
15322 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
15323 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
15324 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
15325 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
15327 ELSEIF(ILIM.EQ.4) THEN
15328 C...Calculate limits on tau'
15329 C...0) due to kinematics
15331 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
15332 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
15333 TAPMN0=(SQRT(TAU)+PQRAT)**2
15336 C...1) due to explicit limits
15337 TAPMN1=CKIN(31)**2/VINT(2)
15339 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
15341 C...Net effect of all separate limits.
15342 VINT(16)=MAX(TAPMN0,TAPMN1)
15343 VINT(36)=MIN(TAPMX0,TAPMX1)
15344 IF(MINT(47).EQ.1) THEN
15348 IF(VINT(36).LE.VINT(16)) MINT(51)=1
15353 C...Special case for low-pT and multiple interactions:
15354 C...effective kinematical limits for tau, y*, cos(theta-hat).
15355 100 IF(ILIM.EQ.0) THEN
15356 ELSEIF(ILIM.EQ.1) THEN
15357 IF(MSTP(82).LE.1) VINT(11)=4D0*PARP(81)**2/VINT(2)
15358 IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
15360 ELSEIF(ILIM.EQ.2) THEN
15361 VINT(12)=0.5D0*LOG(VINT(21))
15363 ELSEIF(ILIM.EQ.3) THEN
15364 IF(MSTP(82).LE.1) ST2EFF=4D0*PARP(81)**2/(VINT(21)*VINT(2))
15365 IF(MSTP(82).GE.2) ST2EFF=0.01D0*PARP(82)**2/(VINT(21)*VINT(2))
15366 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
15375 C*********************************************************************
15378 C...Maps a uniform distribution into a distribution of a kinematical
15379 C...variable according to one of the possibilities allowed. It is
15380 C...assumed that kinematical limits have been set by a PYKLIM call.
15382 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
15384 C...Double precision and integer declarations.
15385 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15386 INTEGER PYK,PYCHGE,PYCOMP
15388 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15389 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15390 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15391 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15392 COMMON/PYINT1/MINT(400),VINT(400)
15393 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15394 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
15396 C...Convert VVAR to tau variable.
15402 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
15405 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
15409 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15411 ELSEIF(MVAR.EQ.1) THEN
15412 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
15413 ELSEIF(MVAR.EQ.2) THEN
15414 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
15415 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
15416 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
15417 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
15418 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
15419 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
15420 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
15421 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
15423 AUPP=LOG(MAX(2D-6,1D0-TAUMAX))
15424 ALOW=LOG(MAX(2D-6,1D0-TAUMIN))
15425 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15427 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
15429 C...Convert VVAR to y* variable.
15430 ELSEIF(IVAR.EQ.2) THEN
15434 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15435 IF(MINT(47).EQ.1) THEN
15437 ELSEIF(MINT(47).EQ.2) THEN
15438 YST=-0.5D0*LOG(TAUE)
15439 ELSEIF(MINT(47).EQ.3) THEN
15440 YST=0.5D0*LOG(TAUE)
15441 ELSEIF(MVAR.EQ.1) THEN
15442 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
15443 ELSEIF(MVAR.EQ.2) THEN
15444 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
15445 ELSEIF(MVAR.EQ.3) THEN
15446 AUPP=ATAN(EXP(YSTMAX))
15447 ALOW=ATAN(EXP(YSTMIN))
15448 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
15449 ELSEIF(MVAR.EQ.4) THEN
15450 YST0=-0.5D0*LOG(TAUE)
15451 AUPP=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0))
15452 ALOW=LOG(MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
15453 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
15455 YST0=-0.5D0*LOG(TAUE)
15456 AUPP=LOG(MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
15457 ALOW=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0))
15458 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
15460 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
15462 C...Convert VVAR to cos(theta-hat) variable.
15463 ELSEIF(IVAR.EQ.3) THEN
15464 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
15466 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15467 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15475 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15476 VCTN=VVAR*(ANEG+APOS)/ANEG
15477 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
15479 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15480 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
15482 ELSEIF(MVAR.EQ.2) THEN
15483 RMNMIN=MAX(RM34,RSQM-CTNMIN)
15484 RMNMAX=MAX(RM34,RSQM-CTNMAX)
15485 RMPMIN=MAX(RM34,RSQM-CTPMIN)
15486 RMPMAX=MAX(RM34,RSQM-CTPMAX)
15487 ANEG=LOG(RMNMIN/RMNMAX)
15488 APOS=LOG(RMPMIN/RMPMAX)
15489 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15490 VCTN=VVAR*(ANEG+APOS)/ANEG
15491 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
15493 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15494 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
15496 ELSEIF(MVAR.EQ.3) THEN
15497 RMNMIN=MAX(RM34,RSQM+CTNMIN)
15498 RMNMAX=MAX(RM34,RSQM+CTNMAX)
15499 RMPMIN=MAX(RM34,RSQM+CTPMIN)
15500 RMPMAX=MAX(RM34,RSQM+CTPMAX)
15501 ANEG=LOG(RMNMAX/RMNMIN)
15502 APOS=LOG(RMPMAX/RMPMIN)
15503 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15504 VCTN=VVAR*(ANEG+APOS)/ANEG
15505 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
15507 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15508 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
15510 ELSEIF(MVAR.EQ.4) THEN
15511 RMNMIN=MAX(RM34,RSQM-CTNMIN)
15512 RMNMAX=MAX(RM34,RSQM-CTNMAX)
15513 RMPMIN=MAX(RM34,RSQM-CTPMIN)
15514 RMPMAX=MAX(RM34,RSQM-CTPMAX)
15515 ANEG=1D0/RMNMAX-1D0/RMNMIN
15516 APOS=1D0/RMPMAX-1D0/RMPMIN
15517 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15518 VCTN=VVAR*(ANEG+APOS)/ANEG
15519 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
15521 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15522 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
15524 ELSEIF(MVAR.EQ.5) THEN
15525 RMNMIN=MAX(RM34,RSQM+CTNMIN)
15526 RMNMAX=MAX(RM34,RSQM+CTNMAX)
15527 RMPMIN=MAX(RM34,RSQM+CTPMIN)
15528 RMPMAX=MAX(RM34,RSQM+CTPMAX)
15529 ANEG=1D0/RMNMIN-1D0/RMNMAX
15530 APOS=1D0/RMPMIN-1D0/RMPMAX
15531 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15532 VCTN=VVAR*(ANEG+APOS)/ANEG
15533 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
15535 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15536 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
15539 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
15540 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
15543 C...Convert VVAR to tau' variable.
15544 ELSEIF(IVAR.EQ.4) THEN
15548 IF(MINT(47).EQ.1) THEN
15550 ELSEIF(MVAR.EQ.1) THEN
15551 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
15552 ELSEIF(MVAR.EQ.2) THEN
15553 AUPP=(1D0-TAU/TAUPMX)**4
15554 ALOW=(1D0-TAU/TAUPMN)**4
15555 TAUP=TAU/MAX(1D-7,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
15557 AUPP=LOG(MAX(2D-6,1D0-TAUPMX))
15558 ALOW=LOG(MAX(2D-6,1D0-TAUPMN))
15559 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15561 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
15563 C...Selection of extra variables needed in 2 -> 3 process:
15564 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
15565 C...Since no options are available, the functions of PYKLIM
15566 C...and PYKMAP are joint for these choices.
15567 ELSEIF(IVAR.EQ.5) THEN
15569 C...Read out total energy and particle masses.
15572 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
15573 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179) MPTPK=2
15574 SHP=VINT(26)*VINT(2)
15578 PM3=SQRT(VINT(21))*VINT(1)
15579 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
15586 C...Specify coefficients of pT choice; upper and lower limits.
15587 IF(MPTPK.EQ.1) THEN
15595 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
15597 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
15599 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
15601 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
15604 C...Select transverse momenta according to
15605 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
15608 IF(HMX.LT.1.0001D0*HMN) THEN
15614 IF(RPT.LT.HWT1) THEN
15615 PTS1=PTSMN1+PYR(0)*HDE
15616 ELSEIF(RPT.LT.HWT1+HWT2) THEN
15617 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
15619 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
15621 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
15622 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
15625 IF(HMX.LT.1.0001D0*HMN) THEN
15631 IF(RPT.LT.HWT1) THEN
15632 PTS2=PTSMN2+PYR(0)*HDE
15633 ELSEIF(RPT.LT.HWT1+HWT2) THEN
15634 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
15636 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
15638 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
15639 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
15641 C...Select azimuthal angles and check pT choice.
15642 PHI1=PARU(2)*PYR(0)
15643 PHI2=PARU(2)*PYR(0)
15645 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
15646 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
15647 & CKIN(56)**2)) THEN
15652 C...Calculate transverse masses and check phase space not closed.
15659 PM12=(PMT1+PMT2)**2
15660 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
15665 C...Select rapidity for particle 3 and check phase space not closed.
15666 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
15667 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
15668 IF(Y3MAX.LT.1D-6) THEN
15672 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
15676 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
15679 PMS12=PE12**2-PZ12**2
15680 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
15681 IF(SQL12.LT.1D-6*SHP) THEN
15685 PMM1=PMS12+PMS1-PMS2
15686 PMM2=PMS12+PMS2-PMS1
15687 TFAC=-SHPR/(2D0*PMS12)
15688 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
15689 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
15690 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
15691 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
15693 C...Construct relative mirror weights and make choice.
15694 IF(MPTPK.EQ.1) THEN
15698 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
15699 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
15701 WTP=WTPU/(WTPU+WTNU)
15702 WTN=WTNU/(WTPU+WTNU)
15704 IF(WTN.GT.PYR(0)) EPS=-1D0
15706 C...Store result of variable choice and associated weights.
15716 IF(EPS.GT.0D0) THEN
15725 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
15726 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
15727 VINT(219)=0.5D0*(PMS12-PTS3)
15734 C***********************************************************************
15737 C...Differential matrix elements for all included subprocesses
15738 C...Note that what is coded is (disregarding the COMFAC factor)
15739 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
15740 C...when d(sigma-hat) is given in the zero-width limit, the delta
15741 C...function in tau is replaced by a (modified) Breit-Wigner:
15742 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
15743 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
15744 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
15745 C...i.e., dimensionless quantities
15746 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
15747 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
15748 C...(2pi)^4 delta^4(P - sum p_i)
15749 C...COMFAC contains the factor pi/s (or equivalent) and
15750 C...the conversion factor from GeV^-2 to mb
15752 SUBROUTINE PYSIGH(NCHN,SIGS)
15754 C...Double precision and integer declarations
15755 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15756 INTEGER PYK,PYCHGE,PYCOMP
15757 C...Parameter statement to help give large particle numbers.
15758 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
15760 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15761 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15762 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15763 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15764 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15765 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15766 COMMON/PYINT1/MINT(400),VINT(400)
15767 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15768 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15769 COMMON/PYINT4/MWID(500),WIDS(500,5)
15770 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15771 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15772 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
15774 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15775 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
15777 C...Local arrays and complex variables
15778 DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200),
15779 &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
15780 COMPLEX A004,A204,A114,A00U,A20U,A11U
15781 COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
15782 &COULCK,COULCP,COULCD,COULCR,COULCS
15783 REAL A00L,A11L,A20L,COULXX
15785 C...Reset number of channels and cross-section
15789 C...Convert H or A process into equivalent h one
15794 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
15795 &ISUB.LE.190)) THEN
15797 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
15799 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
15800 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
15801 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
15802 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
15803 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
15804 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
15805 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
15806 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
15807 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
15811 C...Convert almost equivalent SUSY processes into each other
15812 C...Extract differences in flavours and couplings
15813 IF(ISUB.GE.200.AND.ISUB.LE.280) THEN
15815 C...Sleptons and sneutrinos
15816 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
15817 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15820 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
15821 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15824 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
15825 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15827 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
15828 IF(ISUB.EQ.210) THEN
15830 ELSEIF(ISUB.EQ.211) THEN
15832 ELSEIF(ISUB.EQ.212) THEN
15836 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
15837 IF(ISUB.EQ.213) THEN
15838 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15840 ELSEIF(ISUB.EQ.214) THEN
15847 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
15848 IF(ISUB.EQ.216) THEN
15851 ELSEIF(ISUB.EQ.217) THEN
15854 ELSEIF(ISUB.EQ.218) THEN
15857 ELSEIF(ISUB.EQ.219) THEN
15860 ELSEIF(ISUB.EQ.220) THEN
15863 ELSEIF(ISUB.EQ.221) THEN
15866 ELSEIF(ISUB.EQ.222) THEN
15869 ELSEIF(ISUB.EQ.223) THEN
15872 ELSEIF(ISUB.EQ.224) THEN
15875 ELSEIF(ISUB.EQ.225) THEN
15882 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
15883 IF(ISUB.EQ.226) THEN
15886 ELSEIF(ISUB.EQ.227) THEN
15889 ELSEIF(ISUB.EQ.228) THEN
15895 C...Neutralino + chargino
15896 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
15897 IF(ISUB.EQ.229) THEN
15900 ELSEIF(ISUB.EQ.230) THEN
15903 ELSEIF(ISUB.EQ.231) THEN
15906 ELSEIF(ISUB.EQ.232) THEN
15909 ELSEIF(ISUB.EQ.233) THEN
15912 ELSEIF(ISUB.EQ.234) THEN
15915 ELSEIF(ISUB.EQ.235) THEN
15918 ELSEIF(ISUB.EQ.236) THEN
15924 C...Gluino + neutralino
15925 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
15926 IF(ISUB.EQ.237) THEN
15928 ELSEIF(ISUB.EQ.238) THEN
15930 ELSEIF(ISUB.EQ.239) THEN
15932 ELSEIF(ISUB.EQ.240) THEN
15937 C...Gluino + chargino
15938 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
15939 IF(ISUB.EQ.241) THEN
15941 ELSEIF(ISUB.EQ.242) THEN
15946 C...Squark + neutralino
15947 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
15949 IF(MOD(ISUB,2).NE.0) ILR=1
15950 IF(ISUB.LE.247) THEN
15952 ELSEIF(ISUB.LE.249) THEN
15954 ELSEIF(ISUB.LE.251) THEN
15956 ELSEIF(ISUB.LE.253) THEN
15962 C...Squark + chargino
15963 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
15964 IF(ISUB.LE.255) THEN
15966 ELSEIF(ISUB.LE.257) THEN
15969 IF(MOD(ISUB,2).EQ.0) THEN
15977 C...Squark + gluino
15978 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
15983 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
15985 IF(ISUB.EQ.262) ILR=1
15987 ELSEIF(ISUB.EQ.265) THEN
15991 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
15993 IF(ISUB.LE.273) THEN
15994 IF(ISUB.EQ.273) ILR=1
15997 ELSEIF(ISUB.LE.276) THEN
15998 IF(ISUB.EQ.276) ILR=1
16001 ELSEIF(ISUB.LE.278) THEN
16002 IF(ISUB.EQ.278) ILR=1
16006 IF(ISUB.EQ.280) ILR=1
16014 C...Read kinematical variables and limits
16032 C...Derive kinematical quantities
16034 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
16035 X(1)=SQRT(TAUE)*EXP(YST)
16036 X(2)=SQRT(TAUE)*EXP(-YST)
16037 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
16038 IF(X(1).GT.0.9999D0) RETURN
16039 ELSEIF(MINT(45).EQ.3) THEN
16040 X(1)=MIN(0.9999989D0,X(1))
16042 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
16043 IF(X(2).GT.0.9999D0) RETURN
16044 ELSEIF(MINT(46).EQ.3) THEN
16045 X(2)=MIN(0.9999989D0,X(2))
16052 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
16053 RPTS=4D0*VINT(71)**2/SH
16054 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
16055 RM34=MAX(1D-20,2D0*RM3*RM4)
16057 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) RM34=MAX(RM34,
16058 &2D0*VINT(71)**2/(VINT(21)*VINT(2)))
16059 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
16060 IF(ISTSB.EQ.0) THEN
16062 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16063 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
16065 TH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
16066 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16067 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
16074 C...Choice of Q2 scale: hard, parton distributions, parton showers
16075 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
16077 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
16078 IF(MSTP(32).EQ.1) THEN
16079 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
16080 ELSEIF(MSTP(32).EQ.2) THEN
16081 Q2=SQPTH+0.5D0*(SQM3+SQM4)
16082 ELSEIF(MSTP(32).EQ.3) THEN
16084 ELSEIF(MSTP(32).EQ.4) THEN
16086 ELSEIF(MSTP(32).EQ.5) THEN
16089 IF(ISTSB.EQ.9) Q2=SQPTH
16090 IF((ISTSB.EQ.9.AND.MSTP(82).GE.2).OR.(ISTSB.NE.9.AND.
16091 & MSTP(85).EQ.1)) Q2=Q2+PARP(82)**2
16094 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16096 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124)
16097 & Q2SF=PMAS(24,1)**2
16098 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
16099 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
16100 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
16101 IF(MSTP(39).EQ.3) Q2SF=SH
16102 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
16107 IF(MSTP(68).GE.2.AND.MINT(47).EQ.5) Q2SF=VINT(2)
16108 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
16109 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
16111 IF(MINT(43).EQ.3) XBJ=X(1)
16112 IF(MSTP(22).EQ.1) THEN
16114 ELSEIF(MSTP(22).EQ.2) THEN
16115 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
16116 ELSEIF(MSTP(22).EQ.3) THEN
16117 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
16119 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
16122 IF(MSTP(68).GE.1.AND.MINT(47).EQ.5) Q2PS=VINT(2)
16124 C...Store derived kinematical quantities
16132 VINT(47)=SQRT(SQPTH)
16133 VINT(50)=TAUP*VINT(2)
16134 VINT(49)=SQRT(MAX(0D0,VINT(50)))
16138 VINT(53)=SQRT(Q2SF)
16140 VINT(55)=SQRT(Q2PS)
16142 C...Calculate parton distributions
16143 IF(ISTSB.LE.0) GOTO 170
16144 IF(MINT(47).GE.2) THEN
16145 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
16147 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
16148 MINT(105)=MINT(102+I)
16149 MINT(109)=MINT(106+I)
16150 IF(MSTP(57).LE.1) THEN
16151 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
16153 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
16156 XSFX(I,KFL)=XPQ(KFL)
16161 C...Calculate alpha_em, alpha_strong and K-factor
16164 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
16165 &1D0-(PMAS(24,1)/PMAS(23,1))**2
16167 XWC=1D0/(16D0*XW*XW1)
16169 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16170 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
16173 IF(MSTP(33).EQ.1) THEN
16175 ELSEIF(MSTP(33).EQ.2) THEN
16177 FACA=PARP(32)/PARP(31)
16178 ELSEIF(MSTP(33).EQ.3) THEN
16180 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
16181 & PARU(112)*PARP(82)
16188 C...Set flags for allowed reacting partons/leptons
16193 IF(MINT(44+I).EQ.1) THEN
16194 KFAC(I,MINT(10+I))=1
16195 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
16196 KFAC(I,MINT(10+I))=1
16202 KFAC(I,J)=KFIN(I,J)
16203 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
16204 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
16209 C...Lower and upper limit for fermion flavour loops
16215 IF(KFAC(1,-J).EQ.1) MMIN1=-J
16216 IF(KFAC(1,J).EQ.1) MMAX1=J
16217 IF(KFAC(2,-J).EQ.1) MMIN2=-J
16218 IF(KFAC(2,J).EQ.1) MMAX2=J
16220 MMINA=MIN(MMIN1,MMIN2)
16221 MMAXA=MAX(MMAX1,MMAX2)
16223 C...Common resonance mass and width combinations
16226 SQMH=PMAS(KFHIGG,1)**2
16227 GMMZ=PMAS(23,1)*PMAS(23,2)
16228 GMMW=PMAS(24,1)*PMAS(24,2)
16229 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
16236 C...Phase space integral in tau
16237 COMFAC=PARU(1)*PARU(5)/VINT(2)
16238 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
16239 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
16241 ATAU1=LOG(TAUMAX/TAUMIN)
16242 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
16243 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
16244 IF(MINT(72).GE.1) THEN
16247 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
16249 IF(ATAUD.GT.1D-6) H1=H1+
16250 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
16251 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
16253 IF(ATAUD.GT.1D-6) H1=H1+
16254 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
16256 IF(MINT(72).EQ.2) THEN
16259 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
16261 IF(ATAUD.GT.1D-6) H1=H1+
16262 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
16263 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
16265 IF(ATAUD.GT.1D-6) H1=H1+
16266 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
16268 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
16269 ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
16270 IF(ATAU7.GT.1D-6) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
16271 & MAX(2D-6,1D0-TAU)
16273 COMFAC=COMFAC*ATAU1/(TAU*H1)
16276 C...Phase space integral in y*
16277 IF(MINT(47).GE.4.AND.ISTSB.NE.9) THEN
16278 AYST0=YSTMAX-YSTMIN
16279 IF(AYST0.LT.1D-6) THEN
16282 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16284 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16285 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16286 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16287 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16288 IF(MINT(45).EQ.3) THEN
16289 YST0=-0.5D0*LOG(TAUE)
16290 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
16291 & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
16292 IF(AYST4.GT.1D-6) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
16293 & MAX(1D-6,1D0-EXP(YST-YST0))
16295 IF(MINT(46).EQ.3) THEN
16296 YST0=-0.5D0*LOG(TAUE)
16297 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
16298 & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
16299 IF(AYST5.GT.1D-6) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
16300 & MAX(1D-6,1D0-EXP(-YST-YST0))
16302 COMFAC=COMFAC*AYST0/H2
16306 C...2 -> 1 processes: reduction in angular part of phase space integral
16307 C...for case of decaying resonance
16308 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
16309 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
16310 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
16311 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
16312 & KFPR(ISUB,1).EQ.39) THEN
16313 COMFAC=COMFAC*0.5D0*ACTH0
16315 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
16316 & CTPMAX**3-CTPMIN**3)
16320 C...2 -> 2 processes: angular part of phase space integral
16321 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
16322 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
16323 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
16324 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
16325 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
16326 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
16327 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
16328 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
16329 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
16330 H3=COEF(ISUBSV,13)+
16331 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
16332 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
16333 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
16334 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
16335 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
16337 C...2 -> 2 processes: take into account final state Breit-Wigners
16338 COMFAC=COMFAC*VINT(80)
16341 C...2 -> 3, 4 processes: phace space integral in tau'
16342 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16343 ATAUP1=LOG(TAUPMX/TAUPMN)
16344 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
16345 H4=COEF(ISUBSV,18)+
16346 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
16347 IF(MINT(47).EQ.5) THEN
16348 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
16349 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-6,1D0-TAUP)
16351 COMFAC=COMFAC*ATAUP1/H4
16354 C...2 -> 3, 4 processes: effective W/Z parton distributions
16355 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
16356 IF(1D0-TAU/TAUP.GT.1.D-4) THEN
16357 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
16359 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
16364 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
16365 IF(ISTSB.EQ.5) THEN
16366 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
16367 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
16370 C...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2
16371 IF(MSTP(85).EQ.1.AND.MOD(ISTSB,2).EQ.0) COMFAC=COMFAC*
16372 &SQPTH**2/(PARP(82)**2+SQPTH)**2
16374 C...gamma + gamma: include factor 2 when different nature
16375 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4)
16378 C...Phase space integral for low-pT and multiple interactions
16379 IF(ISTSB.EQ.9) THEN
16380 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
16381 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
16382 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
16383 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
16384 COMFAC=COMFAC*ATAU1/H1
16385 AYST0=YSTMAX-YSTMIN
16386 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16387 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16388 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16389 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16390 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16391 COMFAC=COMFAC*AYST0/H2
16392 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
16393 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16394 C...introduced to make cross-section finite for xT2 -> 0
16395 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
16399 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
16400 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
16401 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
16402 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
16403 IF(MSTP(46).LE.4) THEN
16404 HDTLH=LOG(PMAS(25,1)/PARP(44))
16405 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
16406 HDTNR=-1D0/18D0+HDTLH/6D0
16408 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
16409 HDTLQ=LOG(PARP(45)/PARP(44))
16410 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
16411 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
16414 C...Calculate lowest and next-to-lowest order partial wave amplitudes
16415 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
16419 HDTLS=LOG(SH/PARP(44)**2)
16420 A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16421 & CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
16422 & (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1)))
16423 A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16424 & CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
16425 & (20D0/9D0)*HDTLS),SNGL(PARU(1)))
16426 A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))*
16427 & CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0))
16429 C...Unitarize partial wave amplitudes with Pade or K-matrix method
16430 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
16431 A00U=A00L/(1.-A004/A00L)
16432 A20U=A20L/(1.-A204/A20L)
16433 A11U=A11L/(1.-A114/A11L)
16435 A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004)))
16436 A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204)))
16437 A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114)))
16441 C...Supersymmetric processes - all of type 2 -> 2 :
16442 C...correct final-state Breit-Wigners from fixed to running width.
16443 IF(ISUB.GE.200.AND.ISUB.LE.280.AND.MSTP(42).GT.0) THEN
16445 KFLW=KFPR(ISUBSV,I)
16447 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160
16448 IF(I.EQ.1) SQMI=SQM3
16449 IF(I.EQ.2) SQMI=SQM4
16450 SQMS=PMAS(KCW,1)**2
16451 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
16452 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
16453 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
16454 GMMI=SQRT(SQMI)*WDTP(0)
16455 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
16456 COMFAC=COMFAC*(HBWI/HBWS)
16460 C...A: 2 -> 1, tree diagrams
16462 170 IF(ISUB.LE.10) THEN
16464 C...f + fbar -> gamma*/Z0
16466 CALL PYWIDT(23,SH,WDTP,WDTE)
16468 FACZ=4D0*COMFAC*3D0
16471 DO 180 I=MMINA,MMAXA
16472 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
16473 EI=KCHG(IABS(I),1)/3D0
16477 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
16479 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
16484 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
16485 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
16486 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
16487 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
16490 ELSEIF(ISUB.EQ.2) THEN
16491 C...f + fbar' -> W+/-
16492 CALL PYWIDT(24,SH,WDTP,WDTE)
16494 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
16495 HP=AEM/(24D0*XW)*SH
16496 DO 200 I=MMIN1,MMAX1
16497 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
16499 DO 190 J=MMIN2,MMAX2
16500 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
16502 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
16503 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
16505 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16507 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
16512 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
16513 SIGH(NCHN)=HI*FACBW*HF
16517 ELSEIF(ISUB.EQ.3) THEN
16518 C...f + fbar -> h0 (or H0, or A0)
16519 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
16521 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16522 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
16524 HP=AEM/(8D0*XW)*SH/SQMW*SH
16525 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16526 DO 210 I=MMINA,MMAXA
16527 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
16529 RMQ=PMAS(IA,1)**2/SH
16531 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
16532 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) HI=HI*
16533 & (LOG(MAX(4D0,PARP(37)**2*RMQ*SH/PARU(117)**2))/
16534 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
16535 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16537 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
16538 IF(IA.GT.10) IKFI=3
16539 HI=HI*PARU(150+10*IHIGG+IKFI)**2
16545 SIGH(NCHN)=HI*FACBW*HF
16548 ELSEIF(ISUB.EQ.4) THEN
16549 C...gamma + W+/- -> W+/-
16551 ELSEIF(ISUB.EQ.5) THEN
16553 CALL PYWIDT(25,SH,WDTP,WDTE)
16555 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16556 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16557 HP=AEM/(8D0*XW)*SH/SQMW*SH
16558 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16560 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
16561 DO 230 I=MMIN1,MMAX1
16562 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230
16563 DO 220 J=MMIN2,MMAX2
16564 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220
16565 EI=KCHG(IABS(I),1)/3D0
16568 EJ=KCHG(IABS(J),1)/3D0
16575 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
16579 ELSEIF(ISUB.EQ.6) THEN
16580 C...Z0 + W+/- -> W+/-
16582 ELSEIF(ISUB.EQ.7) THEN
16585 ELSEIF(ISUB.EQ.8) THEN
16587 CALL PYWIDT(25,SH,WDTP,WDTE)
16589 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16590 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16591 HP=AEM/(8D0*XW)*SH/SQMW*SH
16592 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16594 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
16595 DO 250 I=MMIN1,MMAX1
16596 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250
16597 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
16598 DO 240 J=MMIN2,MMAX2
16599 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240
16600 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
16601 IF(EI*EJ.GT.0D0) GOTO 240
16606 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
16610 C...B: 2 -> 2, tree diagrams
16612 ELSEIF(ISUB.EQ.10) THEN
16613 C...f + f' -> f + f' (gamma/Z/W exchange)
16614 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
16615 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
16616 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
16617 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
16618 DO 270 I=MMIN1,MMAX1
16619 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
16621 DO 260 J=MMIN2,MMAX2
16622 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
16624 C...Electroweak couplings
16625 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
16626 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
16628 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
16629 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
16632 C...gamma/Z exchange, only gamma exchange, or only Z exchange
16633 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
16634 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
16635 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
16636 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
16637 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
16638 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16639 ELSEIF(MSTP(21).EQ.2) THEN
16640 FACNCF=FACGGF*EI**2*EJ**2
16642 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
16643 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16652 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
16653 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
16654 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
16655 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
16656 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
16667 ELSEIF(ISUB.LE.20) THEN
16668 IF(ISUB.EQ.11) THEN
16669 C...f + f' -> f + f' (g exchange)
16670 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
16671 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
16672 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
16673 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
16674 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
16675 IF(MSTP(5).GE.1) THEN
16676 C...Modifications from contact interactions (compositeness)
16677 FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
16678 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16679 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
16680 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16681 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
16682 FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
16684 DO 290 I=MMIN1,MMAX1
16686 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290
16687 DO 280 J=MMIN2,MMAX2
16689 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280
16694 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
16697 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
16700 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
16701 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
16704 SIGH(NCHN)=0.5D0*SIGH(NCHN)
16709 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
16710 SIGH(NCHN)=0.5D0*FACQQ2
16712 SIGH(NCHN)=0.5D0*FACCI2
16718 ELSEIF(ISUB.EQ.12) THEN
16719 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
16720 CALL PYWIDT(21,SH,WDTP,WDTE)
16721 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
16722 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16723 IF(MSTP(5).EQ.1) THEN
16724 C...Modifications from contact interactions (compositeness)
16727 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
16728 & WDTE(I,2)+WDTE(I,4))
16730 ELSEIF(MSTP(5).GE.2) THEN
16731 FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
16732 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16734 DO 310 I=MMINA,MMAXA
16735 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16736 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
16741 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
16748 ELSEIF(ISUB.EQ.13) THEN
16749 C...f + fbar -> g + g (q + qbar -> g + g only)
16750 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
16752 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
16754 DO 320 I=MMINA,MMAXA
16755 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16756 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
16761 SIGH(NCHN)=0.5D0*FACGG1
16766 SIGH(NCHN)=0.5D0*FACGG2
16769 ELSEIF(ISUB.EQ.14) THEN
16770 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
16771 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
16772 DO 330 I=MMINA,MMAXA
16773 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16774 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
16775 EI=KCHG(IABS(I),1)/3D0
16780 SIGH(NCHN)=FACGG*EI**2
16783 ELSEIF(ISUB.EQ.15) THEN
16784 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
16785 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16786 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16790 RADC4=1D0+PYALPS(SQM4)/PARU(1)
16791 DO 340 I=1,MIN(16,MDCY(23,3))
16793 IF(MDME(IDC,1).LT.0) GOTO 340
16795 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16799 AF=SIGN(1D0,EF+0.1D0)
16801 ELSEIF(I.LE.16) THEN
16803 AF=SIGN(1D0,EF+0.1D0)
16806 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16807 IF(4D0*RM1.LT.1D0) THEN
16809 IF(I.LE.8) FCOF=3D0*RADC4
16810 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16812 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16813 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16814 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16815 & AF**2*(1D0-4D0*RM1))*BE34
16819 C...Propagators: as simulated in PYOFSH and as desired
16820 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16823 CALL PYWIDT(23,SQM4,WDTP,WDTE)
16824 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16825 HFGG=HFGG*HFAEM*VINT(111)/SQM4
16826 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16827 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16828 C...Loop over flavours; consider full gamma/Z structure
16829 DO 350 I=MMINA,MMAXA
16830 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16831 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
16832 EI=KCHG(IABS(I),1)/3D0
16839 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
16840 & (VI**2+AI**2)*HFZZ)/HBW4
16843 ELSEIF(ISUB.EQ.16) THEN
16844 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
16845 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16846 C...Propagators: as simulated in PYOFSH and as desired
16847 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
16848 CALL PYWIDT(24,SQM4,WDTP,WDTE)
16849 GMMWC=SQRT(SQM4)*WDTP(0)
16850 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
16851 FACWG=FACWG*HBW4C/HBW4
16852 DO 370 I=MMIN1,MMAX1
16854 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370
16855 DO 360 J=MMIN2,MMAX2
16857 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360
16858 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
16859 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16860 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
16861 FCKM=VCKM((IA+1)/2,(JA+1)/2)
16866 SIGH(NCHN)=FACWG*FCKM*WIDSC
16870 ELSEIF(ISUB.EQ.17) THEN
16871 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
16873 ELSEIF(ISUB.EQ.18) THEN
16874 C...f + fbar -> gamma + gamma
16875 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
16876 DO 380 I=MMINA,MMAXA
16877 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
16878 EI=KCHG(IABS(I),1)/3D0
16880 IF(IABS(I).LE.10) FCOI=FACA/3D0
16885 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
16888 ELSEIF(ISUB.EQ.19) THEN
16889 C...f + fbar -> gamma + (gamma*/Z0)
16890 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16891 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16895 RADC4=1D0+PYALPS(SQM4)/PARU(1)
16896 DO 390 I=1,MIN(16,MDCY(23,3))
16898 IF(MDME(IDC,1).LT.0) GOTO 390
16900 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16904 AF=SIGN(1D0,EF+0.1D0)
16906 ELSEIF(I.LE.16) THEN
16908 AF=SIGN(1D0,EF+0.1D0)
16911 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16912 IF(4D0*RM1.LT.1D0) THEN
16914 IF(I.LE.8) FCOF=3D0*RADC4
16915 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16917 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16918 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16919 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16920 & AF**2*(1D0-4D0*RM1))*BE34
16924 C...Propagators: as simulated in PYOFSH and as desired
16925 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16928 CALL PYWIDT(23,SQM4,WDTP,WDTE)
16929 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16930 HFGG=HFGG*HFAEM*VINT(111)/SQM4
16931 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16932 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16933 C...Loop over flavours; consider full gamma/Z structure
16934 DO 400 I=MMINA,MMAXA
16935 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
16936 EI=KCHG(IABS(I),1)/3D0
16940 IF(IABS(I).LE.10) FCOI=FACA/3D0
16945 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
16946 & (VI**2+AI**2)*HFZZ)/HBW4
16949 ELSEIF(ISUB.EQ.20) THEN
16950 C...f + fbar' -> gamma + W+/-
16951 FACGW=COMFAC*0.5D0*AEM**2/XW
16952 C...Propagators: as simulated in PYOFSH and as desired
16953 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
16954 CALL PYWIDT(24,SQM4,WDTP,WDTE)
16955 GMMWC=SQRT(SQM4)*WDTP(0)
16956 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
16957 FACGW=FACGW*HBW4C/HBW4
16958 C...Anomalous couplings
16959 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16962 IF(MSTP(5).GE.1) THEN
16963 TERM2=PARU(153)*(TH-UH)/(TH+UH)
16964 TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
16965 & (4D0*SQMW))/(TH+UH)**2
16967 DO 420 I=MMIN1,MMAX1
16969 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420
16970 DO 410 J=MMIN2,MMAX2
16972 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410
16973 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
16974 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
16976 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16977 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
16979 FACWR=UH/(TH+UH)-1D0/3D0
16980 FCKM=VCKM((IA+1)/2,(JA+1)/2)
16987 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
16992 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
16997 ELSEIF(ISUB.LE.30) THEN
16998 IF(ISUB.EQ.21) THEN
16999 C...f + fbar -> gamma + h0
17001 ELSEIF(ISUB.EQ.22) THEN
17002 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
17003 C...Kinematics dependence
17004 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
17005 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
17006 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17012 RADC3=1D0+PYALPS(SQM3)/PARU(1)
17013 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17014 DO 450 I=1,MIN(16,MDCY(23,3))
17016 IF(MDME(IDC,1).LT.0) GOTO 450
17018 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
17019 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
17022 AF=SIGN(1D0,EF+0.1D0)
17024 ELSEIF(I.LE.16) THEN
17026 AF=SIGN(1D0,EF+0.1D0)
17029 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
17030 IF(4D0*RM1.LT.1D0) THEN
17032 IF(I.LE.8) FCOF=3D0*RADC3
17033 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17035 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17036 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17037 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17038 & AF**2*(1D0-4D0*RM1))*BE34
17041 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17042 IF(4D0*RM1.LT.1D0) THEN
17044 IF(I.LE.8) FCOF=3D0*RADC4
17045 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17047 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17048 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17049 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17050 & AF**2*(1D0-4D0*RM1))*BE34
17054 C...Propagators: as simulated in PYOFSH and as desired
17055 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
17056 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17059 CALL PYWIDT(23,SQM3,WDTP,WDTE)
17060 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17062 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
17063 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
17064 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
17067 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17068 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17070 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
17071 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
17072 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
17074 C...Loop over flavours; separate left- and right-handed couplings
17075 DO 490 I=MMINA,MMAXA
17076 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
17077 EI=KCHG(IABS(I),1)/3D0
17083 IF(IABS(I).LE.10) FCOI=FACA/3D0
17085 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
17086 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
17087 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
17088 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
17090 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
17091 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
17092 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
17093 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
17098 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
17101 ELSEIF(ISUB.EQ.23) THEN
17102 C...f + fbar' -> Z0 + W+/-
17103 FACZW=COMFAC*0.5D0*(AEM/XW)**2
17104 FACZW=FACZW*WIDS(23,2)
17105 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17106 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17107 DO 510 I=MMIN1,MMAX1
17109 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510
17110 DO 500 J=MMIN2,MMAX2
17112 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500
17113 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500
17114 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17116 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17118 AI=SIGN(1D0,EI+0.1D0)
17121 AJ=SIGN(1D0,EJ+0.1D0)
17123 IF(VI+AI.GT.0) THEN
17132 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17134 IF(IA.LE.10) FCOI=FACA/3D0
17139 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
17140 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
17141 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
17142 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
17143 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
17144 & WIDS(24,(5-KCHW)/2)
17148 ELSEIF(ISUB.EQ.24) THEN
17149 C...f + fbar -> Z0 + h0 (or H0, or A0)
17150 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17151 FACHZ=COMFAC*8D0*(AEM*XWC)**2*
17152 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
17153 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
17154 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
17155 & PARU(154+10*IHIGG)**2
17156 DO 520 I=MMINA,MMAXA
17157 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
17158 EI=KCHG(IABS(I),1)/3D0
17162 IF(IABS(I).LE.10) FCOI=FACA/3D0
17167 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
17170 ELSEIF(ISUB.EQ.25) THEN
17171 C...f + fbar -> W+ + W-
17172 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
17173 CALL PYWIDT(23,SH,WDTP,WDTE)
17175 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
17176 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
17177 CALL PYWIDT(24,SQM3,WDTP,WDTE)
17178 GMMW3=SQRT(SQM3)*WDTP(0)
17179 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
17180 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17181 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17182 GMMW4=SQRT(SQM4)*WDTP(0)
17183 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
17184 C...Kinematical functions
17185 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17186 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
17187 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
17188 GT=THUH34+4D0*THUH/TH2
17189 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
17190 GU=THUH34+4D0*THUH/UH2
17191 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
17192 C...Common factors and couplings
17193 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
17194 FACWW=FACWW*WIDS(24,1)
17196 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
17197 CZZ=AEM**2/(32D0*XW**2)*HBWZC
17198 CNG=AEM**2/(4D0*XW)
17199 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
17200 CNN=AEM**2/(16D0*XW**2)
17201 C...Coulomb factor for W+W- pair
17202 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
17203 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
17204 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
17205 IF(COULE.LT.100D0*PMAS(24,2)) THEN
17206 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17207 & PMAS(24,2)**2)-COULE))
17209 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
17211 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
17212 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17213 & PMAS(24,2)**2)+COULE))
17215 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
17218 IF(MSTP(40).EQ.1) THEN
17219 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
17220 & MAX(1D-10,2D0*COULP*COULP1))
17221 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17222 ELSEIF(MSTP(40).EQ.2) THEN
17223 COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2))
17224 COULCP=CMPLX(0.,SNGL(COULP))
17225 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
17226 COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD)
17227 COULCS=CMPLX(0.,0.)
17230 COULXX=(ISTP-0.5)/NSTP
17231 COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/
17232 & (1.+COULXX/COULCD))
17234 COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)*
17236 FACCOU=ABS(COULCR)**2
17237 ELSEIF(MSTP(40).EQ.3) THEN
17238 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
17239 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
17240 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17242 ELSEIF(MSTP(40).EQ.4) THEN
17243 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
17249 C...Loop over allowed flavours
17250 DO 540 I=MMINA,MMAXA
17251 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
17252 EI=KCHG(IABS(I),1)/3D0
17253 AI=SIGN(1D0,EI+0.1D0)
17256 IF(IABS(I).LE.10) FCOI=FACA/3D0
17258 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
17259 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
17261 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
17262 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
17268 SIGH(NCHN)=FACWW*FCOI*DSIGWW
17271 ELSEIF(ISUB.EQ.26) THEN
17272 C...f + fbar' -> W+/- + h0 (or H0, or A0)
17273 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17274 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
17275 & ((SH-SQMW)**2+GMMW**2)
17276 FACHW=FACHW*WIDS(KFHIGG,2)
17277 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
17278 & PARU(155+10*IHIGG)**2
17279 DO 560 I=MMIN1,MMAX1
17281 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560
17282 DO 550 J=MMIN2,MMAX2
17284 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550
17285 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550
17286 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17288 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17290 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17292 IF(IA.LE.10) FCOI=FACA/3D0
17297 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
17301 ELSEIF(ISUB.EQ.27) THEN
17302 C...f + fbar -> h0 + h0
17304 ELSEIF(ISUB.EQ.28) THEN
17305 C...f + g -> f + g (q + g -> q + g only)
17306 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
17308 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
17310 DO 580 I=MMINA,MMAXA
17311 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580
17313 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570
17314 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570
17317 ISIG(NCHN,3-ISDE)=21
17322 ISIG(NCHN,3-ISDE)=21
17328 ELSEIF(ISUB.EQ.29) THEN
17329 C...f + g -> f + gamma (q + g -> q + gamma only)
17330 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
17331 DO 600 I=MMINA,MMAXA
17332 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600
17333 EI=KCHG(IABS(I),1)/3D0
17336 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590
17337 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590
17340 ISIG(NCHN,3-ISDE)=21
17346 ELSEIF(ISUB.EQ.30) THEN
17347 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
17348 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
17350 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17354 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17355 DO 610 I=1,MIN(16,MDCY(23,3))
17357 IF(MDME(IDC,1).LT.0) GOTO 610
17359 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17363 AF=SIGN(1D0,EF+0.1D0)
17365 ELSEIF(I.LE.16) THEN
17367 AF=SIGN(1D0,EF+0.1D0)
17370 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17371 IF(4D0*RM1.LT.1D0) THEN
17373 IF(I.LE.8) FCOF=3D0*RADC4
17374 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17376 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17377 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17378 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17379 & AF**2*(1D0-4D0*RM1))*BE34
17383 C...Propagators: as simulated in PYOFSH and as desired
17384 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17387 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17388 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17389 HFGG=HFGG*HFAEM*VINT(111)/SQM4
17390 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17391 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17392 C...Loop over flavours; consider full gamma/Z structure
17393 DO 630 I=MMINA,MMAXA
17394 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630
17395 EI=KCHG(IABS(I),1)/3D0
17398 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
17399 & (VI**2+AI**2)*HFZZ)/HBW4
17401 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620
17402 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620
17405 ISIG(NCHN,3-ISDE)=21
17412 ELSEIF(ISUB.LE.40) THEN
17413 IF(ISUB.EQ.31) THEN
17414 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
17415 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
17416 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
17417 C...Propagators: as simulated in PYOFSH and as desired
17418 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17419 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17420 GMMWC=SQRT(SQM4)*WDTP(0)
17421 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17422 FACWQ=FACWQ*HBW4C/HBW4
17423 DO 650 I=MMINA,MMAXA
17424 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650
17426 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17427 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17429 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640
17430 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640
17433 ISIG(NCHN,3-ISDE)=21
17435 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17439 ELSEIF(ISUB.EQ.32) THEN
17440 C...f + g -> f + h0 (q + g -> q + h0 only)
17442 ELSEIF(ISUB.EQ.33) THEN
17443 C...f + gamma -> f + g (q + gamma -> q + g only)
17444 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
17445 DO 670 I=MMINA,MMAXA
17446 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670
17447 EI=KCHG(IABS(I),1)/3D0
17450 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660
17451 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660
17454 ISIG(NCHN,3-ISDE)=22
17460 ELSEIF(ISUB.EQ.34) THEN
17461 C...f + gamma -> f + gamma
17462 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
17463 DO 690 I=MMINA,MMAXA
17464 IF(I.EQ.0) GOTO 690
17465 EI=KCHG(IABS(I),1)/3D0
17468 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680
17469 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680
17472 ISIG(NCHN,3-ISDE)=22
17478 ELSEIF(ISUB.EQ.35) THEN
17479 C...f + gamma -> f + (gamma*/Z0)
17480 FZQN=COMFAC*2D0*AEM**2*(SH2+UH2+2D0*SQM4*TH)
17481 FZQD=SQPTH*SQM4-SH*UH
17482 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17486 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17487 DO 700 I=1,MIN(16,MDCY(23,3))
17489 IF(MDME(IDC,1).LT.0) GOTO 700
17491 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17495 AF=SIGN(1D0,EF+0.1D0)
17497 ELSEIF(I.LE.16) THEN
17499 AF=SIGN(1D0,EF+0.1D0)
17502 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17503 IF(4D0*RM1.LT.1D0) THEN
17505 IF(I.LE.8) FCOF=3D0*RADC4
17506 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17508 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17509 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17510 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17511 & AF**2*(1D0-4D0*RM1))*BE34
17515 C...Propagators: as simulated in PYOFSH and as desired
17516 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17519 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17520 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17521 HFGG=HFGG*HFAEM*VINT(111)/SQM4
17522 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17523 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17524 C...Loop over flavours; consider full gamma/Z structure
17525 DO 720 I=MMINA,MMAXA
17526 IF(I.EQ.0) GOTO 720
17527 EI=KCHG(IABS(I),1)/3D0
17530 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
17531 & (VI**2+AI**2)*HFZZ)/HBW4
17533 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710
17534 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710
17537 ISIG(NCHN,3-ISDE)=22
17539 SIGH(NCHN)=FACZQ*FZQN/MAX(PMAS(IABS(I),1)**2*SQM4,FZQD)
17543 ELSEIF(ISUB.EQ.36) THEN
17544 C...f + gamma -> f' + W+/-
17545 FWQ=COMFAC*AEM**2/(2D0*XW)*
17546 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
17547 C...Propagators: as simulated in PYOFSH and as desired
17548 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17549 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17550 GMMWC=SQRT(SQM4)*WDTP(0)
17551 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17553 DO 740 I=MMINA,MMAXA
17554 IF(I.EQ.0) GOTO 740
17556 EIA=ABS(KCHG(IABS(I),1)/3D0)
17557 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
17558 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17559 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17561 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730
17562 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730
17565 ISIG(NCHN,3-ISDE)=22
17567 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17571 ELSEIF(ISUB.EQ.37) THEN
17572 C...f + gamma -> f + h0
17574 ELSEIF(ISUB.EQ.38) THEN
17575 C...f + Z0 -> f + g (q + Z0 -> q + g only)
17577 ELSEIF(ISUB.EQ.39) THEN
17578 C...f + Z0 -> f + gamma
17580 ELSEIF(ISUB.EQ.40) THEN
17581 C...f + Z0 -> f + Z0
17584 ELSEIF(ISUB.LE.50) THEN
17585 IF(ISUB.EQ.41) THEN
17586 C...f + Z0 -> f' + W+/-
17588 ELSEIF(ISUB.EQ.42) THEN
17589 C...f + Z0 -> f + h0
17591 ELSEIF(ISUB.EQ.43) THEN
17592 C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
17594 ELSEIF(ISUB.EQ.44) THEN
17595 C...f + W+/- -> f' + gamma
17597 ELSEIF(ISUB.EQ.45) THEN
17598 C...f + W+/- -> f' + Z0
17600 ELSEIF(ISUB.EQ.46) THEN
17601 C...f + W+/- -> f' + W+/-
17603 ELSEIF(ISUB.EQ.47) THEN
17604 C...f + W+/- -> f' + h0
17606 ELSEIF(ISUB.EQ.48) THEN
17607 C...f + h0 -> f + g (q + h0 -> q + g only)
17609 ELSEIF(ISUB.EQ.49) THEN
17610 C...f + h0 -> f + gamma
17612 ELSEIF(ISUB.EQ.50) THEN
17613 C...f + h0 -> f + Z0
17616 ELSEIF(ISUB.LE.60) THEN
17617 IF(ISUB.EQ.51) THEN
17618 C...f + h0 -> f' + W+/-
17620 ELSEIF(ISUB.EQ.52) THEN
17621 C...f + h0 -> f + h0
17623 ELSEIF(ISUB.EQ.53) THEN
17624 C...g + g -> f + fbar (g + g -> q + qbar only)
17625 CALL PYWIDT(21,SH,WDTP,WDTE)
17626 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
17627 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17628 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
17629 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17630 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750
17643 ELSEIF(ISUB.EQ.54) THEN
17644 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
17645 CALL PYWIDT(21,SH,WDTP,WDTE)
17647 DO 760 I=1,MIN(8,MDCY(21,3))
17649 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17652 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
17653 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
17660 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
17668 ELSEIF(ISUB.EQ.55) THEN
17669 C...g + Z -> f + fbar (g + Z -> q + qbar only)
17671 ELSEIF(ISUB.EQ.56) THEN
17672 C...g + W -> f + f'bar (g + W -> q + q'bar only)
17674 ELSEIF(ISUB.EQ.57) THEN
17675 C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
17677 ELSEIF(ISUB.EQ.58) THEN
17678 C...gamma + gamma -> f + fbar
17679 CALL PYWIDT(22,SH,WDTP,WDTE)
17681 DO 770 I=1,MIN(12,MDCY(22,3))
17682 IF(I.LE.8) EF= KCHG(I,1)/3D0
17683 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
17684 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17687 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
17688 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
17696 ELSEIF(ISUB.EQ.59) THEN
17697 C...gamma + Z0 -> f + fbar
17699 ELSEIF(ISUB.EQ.60) THEN
17700 C...gamma + W+/- -> f + fbar'
17703 ELSEIF(ISUB.LE.70) THEN
17704 IF(ISUB.EQ.61) THEN
17705 C...gamma + h0 -> f + fbar
17707 ELSEIF(ISUB.EQ.62) THEN
17708 C...Z0 + Z0 -> f + fbar
17710 ELSEIF(ISUB.EQ.63) THEN
17711 C...Z0 + W+/- -> f + fbar'
17713 ELSEIF(ISUB.EQ.64) THEN
17714 C...Z0 + h0 -> f + fbar
17716 ELSEIF(ISUB.EQ.65) THEN
17717 C...W+ + W- -> f + fbar
17719 ELSEIF(ISUB.EQ.66) THEN
17720 C...W+/- + h0 -> f + fbar'
17722 ELSEIF(ISUB.EQ.67) THEN
17723 C...h0 + h0 -> f + fbar
17725 ELSEIF(ISUB.EQ.68) THEN
17727 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
17729 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
17731 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
17733 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780
17738 SIGH(NCHN)=0.5D0*FACGG1
17743 SIGH(NCHN)=0.5D0*FACGG2
17748 SIGH(NCHN)=0.5D0*FACGG3
17751 ELSEIF(ISUB.EQ.69) THEN
17752 C...gamma + gamma -> W+ + W-
17753 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17754 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
17755 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
17756 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
17757 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790
17765 ELSEIF(ISUB.EQ.70) THEN
17766 C...gamma + W+/- -> Z0 + W+/-
17767 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17768 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
17769 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
17770 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
17771 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
17772 DO 810 KCHW=1,-1,-2
17774 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800
17777 ISIG(NCHN,3-ISDE)=24*KCHW
17779 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
17784 ELSEIF(ISUB.LE.80) THEN
17785 IF(ISUB.EQ.71) THEN
17786 C...Z0 + Z0 -> Z0 + Z0
17787 IF(SH.LE.4.01D0*SQMZ) GOTO 840
17789 IF(MSTP(46).LE.2) THEN
17790 C...Exact scattering ME:s for on-mass-shell gauge bosons
17791 BE2=1D0-4D0*SQMZ/SH
17792 TH=-0.5D0*SH*BE2*(1D0-CTH)
17793 UH=-0.5D0*SH*BE2*(1D0+CTH)
17794 IF(MAX(TH,UH).GT.-1D0) GOTO 840
17795 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
17796 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17797 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17798 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
17799 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17800 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17801 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
17802 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
17803 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
17804 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17805 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17806 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
17807 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
17808 & (ASHIM+ATHIM+AUHIM)**2)
17809 IF(MSTP(46).EQ.2) FACZZ=0D0
17812 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17813 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17814 & ABS(A00U+2.*A20U)**2
17816 FACZZ=FACZZ*WIDS(23,1)
17818 DO 830 I=MMIN1,MMAX1
17819 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830
17820 EI=KCHG(IABS(I),1)/3D0
17824 DO 820 J=MMIN2,MMAX2
17825 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820
17826 EJ=KCHG(IABS(J),1)/3D0
17834 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
17839 ELSEIF(ISUB.EQ.72) THEN
17840 C...Z0 + Z0 -> W+ + W-
17841 IF(SH.LE.4.01D0*SQMZ) GOTO 870
17843 IF(MSTP(46).LE.2) THEN
17844 C...Exact scattering ME:s for on-mass-shell gauge bosons
17845 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
17847 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
17848 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
17849 IF(MAX(TH,UH).GT.-1D0) GOTO 870
17850 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
17851 & (1D0-2D0*SQMZ/SH)
17852 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17853 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17854 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
17855 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17856 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17857 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
17858 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17860 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
17861 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17862 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17863 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
17864 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17866 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
17868 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17869 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17870 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
17871 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
17872 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
17873 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
17874 & (ATWIM+AUWIM+A4IM)**2)
17877 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17878 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17879 & ABS(A00U-A20U)**2
17881 FACWW=FACWW*WIDS(24,1)
17883 DO 860 I=MMIN1,MMAX1
17884 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
17885 EI=KCHG(IABS(I),1)/3D0
17889 DO 850 J=MMIN2,MMAX2
17890 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
17891 EJ=KCHG(IABS(J),1)/3D0
17899 SIGH(NCHN)=FACWW*AVI*AVJ
17904 ELSEIF(ISUB.EQ.73) THEN
17905 C...Z0 + W+/- -> Z0 + W+/-
17906 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900
17908 IF(MSTP(46).LE.2) THEN
17909 C...Exact scattering ME:s for on-mass-shell gauge bosons
17910 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
17911 EP1=1D0-(SQMZ-SQMW)/SH
17912 EP2=1D0+(SQMZ-SQMW)/SH
17913 TH=-0.5D0*SH*BE2*(1D0-CTH)
17914 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
17915 IF(MAX(TH,UH).GT.-1D0) GOTO 900
17916 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
17917 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17918 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17919 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
17920 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
17921 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
17922 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
17924 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
17925 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
17926 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
17927 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
17928 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
17929 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
17930 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
17931 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
17932 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
17933 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
17934 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
17935 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
17937 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
17938 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
17940 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
17941 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
17942 IF(MSTP(46).LE.0) FACZW=0D0
17943 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
17944 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
17945 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
17946 & (ASWIM+AUWIM+A4IM)**2)
17949 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17950 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
17951 & ABS(A20U+3.*A11U*SNGL(CTH))**2
17953 FACZW=FACZW*WIDS(23,2)
17955 DO 890 I=MMIN1,MMAX1
17956 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890
17957 EI=KCHG(IABS(I),1)/3D0
17961 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
17962 DO 880 J=MMIN2,MMAX2
17963 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880
17964 EJ=KCHG(IABS(J),1)/3D0
17968 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
17973 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
17978 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
17983 ELSEIF(ISUB.EQ.75) THEN
17984 C...W+ + W- -> gamma + gamma
17986 ELSEIF(ISUB.EQ.76) THEN
17987 C...W+ + W- -> Z0 + Z0
17988 IF(SH.LE.4.01D0*SQMZ) GOTO 930
17990 IF(MSTP(46).LE.2) THEN
17991 C...Exact scattering ME:s for on-mass-shell gauge bosons
17992 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
17994 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
17995 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
17996 IF(MAX(TH,UH).GT.-1D0) GOTO 930
17997 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
17998 & (1D0-2D0*SQMZ/SH)
17999 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18000 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18001 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
18002 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18003 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18004 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
18005 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18007 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
18008 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18009 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18010 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
18011 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18013 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
18015 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18017 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
18018 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
18019 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
18020 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
18021 & (ATWIM+AUWIM+A4IM)**2)
18024 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18025 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18026 & ABS(A00U-A20U)**2
18028 FACZZ=FACZZ*WIDS(23,1)
18030 DO 920 I=MMIN1,MMAX1
18031 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920
18032 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18033 DO 910 J=MMIN2,MMAX2
18034 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910
18035 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18036 IF(EI*EJ.GT.0D0) GOTO 910
18041 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
18046 ELSEIF(ISUB.EQ.77) THEN
18047 C...W+/- + W+/- -> W+/- + W+/-
18048 IF(SH.LE.4.01D0*SQMW) GOTO 960
18050 IF(MSTP(46).LE.2) THEN
18051 C...Exact scattering ME:s for on-mass-shell gauge bosons
18052 BE2=1D0-4D0*SQMW/SH
18056 TH=-0.5D0*SH*BE2*(1D0-CTH)
18057 UH=-0.5D0*SH*BE2*(1D0+CTH)
18058 IF(MAX(TH,UH).GT.-1D0) GOTO 960
18060 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18061 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18063 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
18064 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
18066 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
18067 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
18068 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
18071 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
18073 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
18074 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
18075 ATGRE=0.5D0*XW*SH/TH*TGZANG
18077 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
18079 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
18080 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
18081 AUGRE=0.5D0*XW*SH/UH*UGZANG
18083 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
18085 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
18087 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
18089 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18091 IF(MSTP(46).LE.0) THEN
18096 ELSEIF(MSTP(46).EQ.1) THEN
18097 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18098 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18099 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18100 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18102 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18103 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18104 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18105 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18107 AWWA2=AWWARE**2+AWWAIM**2
18108 AWWS2=AWWSRE**2+AWWSIM**2
18111 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18112 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18113 & ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2
18114 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
18117 DO 950 I=MMIN1,MMAX1
18118 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950
18119 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18120 DO 940 J=MMIN2,MMAX2
18121 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940
18122 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18123 IF(EI*EJ.LT.0D0) THEN
18125 IF(MSTP(45).EQ.1) GOTO 940
18126 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
18127 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
18130 IF(MSTP(45).EQ.2) GOTO 940
18131 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
18132 IF(MSTP(46).GE.3) FACWW=FWWS
18133 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
18134 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
18140 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
18141 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
18146 ELSEIF(ISUB.EQ.78) THEN
18147 C...W+/- + h0 -> W+/- + h0
18149 ELSEIF(ISUB.EQ.79) THEN
18150 C...h0 + h0 -> h0 + h0
18152 ELSEIF(ISUB.EQ.80) THEN
18153 C...q + gamma -> q' + pi+/-
18154 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
18155 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
18156 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
18157 DELSH=UH*SQRT(ASSH*Q2FPSH)
18158 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
18159 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
18160 DELUH=SH*SQRT(ASUH*Q2FPUH)
18161 DO 980 I=MAX(-2,MMINA),MIN(2,MMAXA)
18162 IF(I.EQ.0) GOTO 980
18163 EI=KCHG(IABS(I),1)/3D0
18164 EJ=SIGN(1D0-ABS(EI),EI)
18166 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970
18167 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970
18170 ISIG(NCHN,3-ISDE)=22
18172 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
18178 C...C: 2 -> 2, tree diagrams with masses
18180 ELSEIF(ISUB.LE.90) THEN
18181 IF(ISUB.EQ.81) THEN
18182 C...q + qbar -> Q + Qbar
18183 FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQM3)**2+
18184 & (UH-SQM3)**2)/SH2+2D0*SQM3/SH)
18185 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQM3,0D0)
18187 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18188 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18190 DO 990 I=MMINA,MMAXA
18191 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18192 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990
18200 ELSEIF(ISUB.EQ.82) THEN
18201 C...g + g -> Q + Qbar
18202 IF(MSTP(34).EQ.0) THEN
18203 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18204 & 2D0*(UH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18206 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18207 & 2D0*(TH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18210 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18211 & 2.25D0*(UH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18212 & (TH-SQM3)**2+0.5D0*SQM3*TH/(TH-SQM3)**2-SQM3**2/
18214 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18215 & 2.25D0*(TH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18216 & (UH-SQM3)**2+0.5D0*SQM3*UH/(UH-SQM3)**2-SQM3**2/
18219 IF(MSTP(35).GE.1) THEN
18220 FATRE=PYHFTH(SH,SQM3,2D0/7D0)
18221 FACQQ1=FACQQ1*FATRE
18222 FACQQ2=FACQQ2*FATRE
18225 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18226 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18229 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1000
18242 ELSEIF(ISUB.EQ.83) THEN
18243 C...f + q -> f' + Q
18244 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
18245 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
18246 DO 1020 I=MMIN1,MMAX1
18247 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
18248 DO 1010 J=MMIN2,MMAX2
18249 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
18250 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010
18251 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010
18252 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
18258 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18259 & (IABS(I)+1)/2)*VINT(180+J)
18260 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
18261 & (MINT(55)+1)/2)*VINT(180+J)
18264 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18265 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18268 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18269 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18272 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18273 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18275 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
18281 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18282 & (IABS(J)+1)/2)*VINT(180+I)
18283 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
18284 & (MINT(55)+1)/2)*VINT(180+I)
18286 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18287 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18290 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18291 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18294 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18295 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18300 ELSEIF(ISUB.EQ.84) THEN
18301 C...g + gamma -> Q + Qbar
18302 FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18303 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
18304 & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18305 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQM3,0D0)
18307 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18308 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18310 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18317 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18325 ELSEIF(ISUB.EQ.85) THEN
18326 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
18327 FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18328 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
18329 & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18330 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
18331 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
18332 & FACFF=FACFF*PYHFTH(SH,SQM3,1D0)
18334 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
18335 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
18336 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
18338 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18346 ELSEIF(ISUB.EQ.86) THEN
18347 C...g + g -> J/Psi + g
18348 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
18349 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18350 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18351 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18359 ELSEIF(ISUB.EQ.87) THEN
18360 C...g + g -> chi_0c + g
18361 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18362 QGTW=(SH*TH*UH)/SH**3
18364 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18365 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18366 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
18367 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
18368 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
18369 & (QGTW*(QGTW-RGTW*PGTW)**4)
18370 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18378 ELSEIF(ISUB.EQ.88) THEN
18379 C...g + g -> chi_1c + g
18380 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18381 QGTW=(SH*TH*UH)/SH**3
18383 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18384 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
18385 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
18386 & (QGTW-RGTW*PGTW)**4
18387 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18395 ELSEIF(ISUB.EQ.89) THEN
18396 C...g + g -> chi_2c + g
18397 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18398 QGTW=(SH*TH*UH)/SH**3
18400 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18401 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18402 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
18403 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
18404 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
18405 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
18406 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18415 C...D: Mimimum bias processes
18417 ELSEIF(ISUB.LE.100) THEN
18418 IF(ISUB.EQ.91) THEN
18419 C...Elastic scattering
18422 ELSEIF(ISUB.EQ.92) THEN
18423 C...Single diffractive scattering (first side, i.e. XB)
18426 ELSEIF(ISUB.EQ.93) THEN
18427 C...Single diffractive scattering (second side, i.e. AX)
18430 ELSEIF(ISUB.EQ.94) THEN
18431 C...Double diffractive scattering
18434 ELSEIF(ISUB.EQ.95) THEN
18435 C...Low-pT scattering
18438 ELSEIF(ISUB.EQ.96) THEN
18439 C...Multiple interactions: sum of QCD processes
18440 CALL PYWIDT(21,SH,WDTP,WDTE)
18442 C...q + q' -> q + q'
18443 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
18444 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
18445 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
18446 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
18447 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
18449 IF(I.EQ.0) GOTO 1040
18451 IF(J.EQ.0) GOTO 1030
18457 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
18459 SIGH(NCHN)=0.5D0*SIGH(NCHN)
18464 SIGH(NCHN)=0.5D0*FACQQ2
18469 C...q + qbar -> q' + qbar' or g + g
18470 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
18471 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
18472 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18474 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18477 IF(I.EQ.0) GOTO 1050
18487 SIGH(NCHN)=0.5D0*FACGG1
18492 SIGH(NCHN)=0.5D0*FACGG2
18496 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
18498 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
18501 IF(I.EQ.0) GOTO 1070
18505 ISIG(NCHN,3-ISDE)=21
18510 ISIG(NCHN,3-ISDE)=21
18516 C...g + g -> q + qbar or g + g
18517 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18518 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18519 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18520 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18521 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
18522 & 2D0*TH/SH+TH2/SH2)*FACA
18523 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
18524 & 2D0*SH/UH+SH2/UH2)*FACA
18525 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
18526 & 2D0*UH/TH+UH2/TH2)
18541 SIGH(NCHN)=0.5D0*FACGG1
18546 SIGH(NCHN)=0.5D0*FACGG2
18551 SIGH(NCHN)=0.5D0*FACGG3
18554 C...E: 2 -> 1, loop diagrams
18556 ELSEIF(ISUB.LE.110) THEN
18557 IF(ISUB.EQ.101) THEN
18558 C...g + g -> gamma*/Z0
18560 ELSEIF(ISUB.EQ.102) THEN
18561 C...g + g -> h0 (or H0, or A0)
18562 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18564 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18565 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18566 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18568 HI=SHR*WDTP(13)/32D0
18569 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080
18574 SIGH(NCHN)=HI*FACBW*HF
18577 ELSEIF(ISUB.EQ.103) THEN
18578 C...gamma + gamma -> h0 (or H0, or A0)
18579 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18581 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18582 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18583 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18585 HI=SHR*WDTP(14)*2D0
18586 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090
18591 SIGH(NCHN)=HI*FACBW*HF
18594 C...Continuation C: 2 -> 2, tree diagrams with masses.
18596 ELSEIF(ISUB.EQ.106) THEN
18597 C...g + g -> J/Psi + gamma.
18599 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
18600 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18601 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18602 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18610 ELSEIF(ISUB.EQ.107) THEN
18611 C...g + gamma -> J/Psi + g.
18613 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
18614 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18615 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18616 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18623 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18631 ELSEIF(ISUB.EQ.108) THEN
18632 C...gamma + gamma -> J/Psi + gamma.
18634 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
18635 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18636 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18637 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18645 C...F: 2 -> 2, box diagrams
18647 ELSEIF(ISUB.EQ.110) THEN
18648 C...f + fbar -> gamma + h0
18649 THUH=MAX(TH*UH,SH*CKIN(3)**2)
18650 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
18651 FACHG=FACHG*WIDS(KFHIGG,2)
18652 C...Calculate loop contributions for intermediate gamma* and Z0
18653 CIGTOT=CMPLX(0.,0.)
18654 CIZTOT=CMPLX(0.,0.)
18657 IF(J.LE.2*MSTP(1)) THEN
18660 AJ=SIGN(1D0,EJ+0.1D0)
18662 BALP=SQM4/(2D0*PMAS(J,1))**2
18663 BBET=SH/(2D0*PMAS(J,1))**2
18664 ELSEIF(J.LE.3*MSTP(1)) THEN
18666 JL=2*(J-2*MSTP(1))-1
18667 EJ=KCHG(10+JL,1)/3D0
18668 AJ=SIGN(1D0,EJ+0.1D0)
18670 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
18671 BBET=SH/(2D0*PMAS(10+JL,1))**2
18673 BALP=SQM4/(2D0*PMAS(24,1))**2
18674 BBET=SH/(2D0*PMAS(24,1))**2
18676 BABI=1D0/(BALP-BBET)
18677 IF(BALP.LT.1D0) THEN
18678 F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.)
18681 F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
18682 & -SNGL(0.5D0*PARU(1)))
18685 F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
18686 IF(BBET.LT.1D0) THEN
18687 F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.)
18690 F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
18691 & -SNGL(0.5D0*PARU(1)))
18694 F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET
18695 IF(J.LE.3*MSTP(1)) THEN
18696 FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+
18697 & BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP))
18698 CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF
18699 CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF
18702 CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)*
18703 & (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
18704 & SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
18705 CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP*
18706 & (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+
18707 & SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
18711 CIGTOT=CIGTOT/SNGL(SH)
18712 CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ))
18713 C...Loop over initial flavours
18714 DO 1110 I=MMINA,MMAXA
18715 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110
18716 EI=KCHG(IABS(I),1)/3D0
18720 IF(IABS(I).LE.10) FCOI=FACA/3D0
18725 SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)*
18726 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
18731 ELSEIF(ISUB.LE.120) THEN
18732 IF(ISUB.EQ.111) THEN
18733 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
18736 DO 1120 I=1,2*MSTP(1)
18740 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18741 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18742 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18743 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18744 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
18745 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
18746 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
18747 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
18749 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18750 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
18751 FACGH=FACGH*WIDS(25,2)
18752 DO 1130 I=MMINA,MMAXA
18753 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18754 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130
18762 ELSEIF(ISUB.EQ.112) THEN
18763 C...f + g -> f + h0 (q + g -> q + h0 only)
18766 DO 1140 I=1,2*MSTP(1)
18770 CALL PYWAUX(1,EPST,W1TR,W1TI)
18771 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18772 CALL PYWAUX(2,EPST,W2TR,W2TI)
18773 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18774 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
18775 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
18776 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
18777 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
18779 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18780 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
18781 FACQH=FACQH*WIDS(25,2)
18782 DO 1160 I=MMINA,MMAXA
18783 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160
18785 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150
18786 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150
18789 ISIG(NCHN,3-ISDE)=21
18795 ELSEIF(ISUB.EQ.113) THEN
18796 C...g + g -> g + h0
18805 DO 1170 I=1,2*MSTP(1)
18811 IF(EPSH.LT.1.D-6) GOTO 1170
18812 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18813 CALL PYWAUX(1,EPST,W1TR,W1TI)
18814 CALL PYWAUX(1,EPSU,W1UR,W1UI)
18815 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18816 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18817 CALL PYWAUX(2,EPST,W2TR,W2TI)
18818 CALL PYWAUX(2,EPSU,W2UR,W2UI)
18819 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18820 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
18821 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
18822 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
18823 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
18824 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
18825 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
18826 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
18827 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
18828 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
18829 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
18830 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
18831 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
18832 W3STUR=YHSTUR-Y3STUR-Y3UTSR
18833 W3STUI=YHSTUI-Y3STUI-Y3UTSI
18834 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
18835 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
18836 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
18837 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
18838 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
18839 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
18840 W3USTR=YHUSTR-Y3USTR-Y3TSUR
18841 W3USTI=YHUSTI-Y3USTI-Y3TSUI
18842 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
18843 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
18844 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
18845 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
18846 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
18847 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
18848 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
18849 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
18850 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
18851 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
18852 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
18853 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
18854 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
18855 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
18856 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
18857 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
18858 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
18859 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
18860 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
18861 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
18862 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
18863 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
18864 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
18865 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
18866 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
18867 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
18868 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
18869 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
18870 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
18871 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
18872 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
18873 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
18874 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
18875 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
18876 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
18877 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
18878 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
18879 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
18880 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
18881 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
18882 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
18883 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
18884 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
18885 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
18886 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
18887 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
18888 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
18889 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
18890 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
18891 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
18892 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
18893 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
18894 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
18895 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
18896 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
18897 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
18898 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
18899 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
18900 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
18901 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
18902 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
18903 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
18904 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18905 & (W2SR-W2HR+W3STUR))
18906 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
18907 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18908 & (W2TR-W2HR+W3TUSR))
18909 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
18910 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18911 & (W2UR-W2HR+W3USTR))
18912 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
18913 A2STUR=A2STUR+B2STUR+B2SUTR
18914 A2STUI=A2STUI+B2STUI+B2SUTI
18915 A2USTR=A2USTR+B2USTR+B2UTSR
18916 A2USTI=A2USTI+B2USTI+B2UTSI
18917 A2TUSR=A2TUSR+B2TUSR+B2TSUR
18918 A2TUSI=A2TUSI+B2TUSI+B2TSUI
18919 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
18920 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
18922 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
18923 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
18924 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
18925 FACGH=FACGH*WIDS(25,2)
18926 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180
18934 ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
18935 C...g + g -> gamma + gamma or g + g -> g + gamma
18950 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
18952 EI=KCHG(IABS(I),1)/3D0
18954 IF(ISUB.EQ.115) EIWT=EI
18959 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1.D-4) THEN
18960 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
18963 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
18964 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
18965 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
18966 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
18972 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18973 CALL PYWAUX(1,EPST,W1TR,W1TI)
18974 CALL PYWAUX(1,EPSU,W1UR,W1UI)
18975 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18976 CALL PYWAUX(2,EPST,W2TR,W2TI)
18977 CALL PYWAUX(2,EPSU,W2UR,W2UI)
18978 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
18979 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
18980 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
18981 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
18982 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
18983 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
18984 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
18985 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
18986 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
18987 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
18988 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
18989 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
18990 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
18991 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
18992 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
18993 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
18994 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
18995 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
18996 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
18997 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
18998 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
18999 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
19000 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19001 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
19002 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
19003 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
19004 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
19005 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
19006 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19007 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
19008 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
19009 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
19010 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
19011 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
19012 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19013 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
19014 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
19015 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
19016 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
19017 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
19018 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19019 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
19020 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
19021 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
19022 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
19023 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
19024 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
19025 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
19026 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
19027 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
19028 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
19029 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
19030 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
19031 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
19032 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
19033 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
19035 A0STUR=A0STUR+EIWT*B0STUR
19036 A0STUI=A0STUI+EIWT*B0STUI
19037 A0TSUR=A0TSUR+EIWT*B0TSUR
19038 A0TSUI=A0TSUI+EIWT*B0TSUI
19039 A0UTSR=A0UTSR+EIWT*B0UTSR
19040 A0UTSI=A0UTSI+EIWT*B0UTSI
19041 A1STUR=A1STUR+EIWT*B1STUR
19042 A1STUI=A1STUI+EIWT*B1STUI
19043 A2STUR=A2STUR+EIWT*B2STUR
19044 A2STUI=A2STUI+EIWT*B2STUI
19046 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
19047 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
19048 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
19049 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
19050 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1200
19055 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
19056 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
19059 ELSEIF(ISUB.EQ.116) THEN
19060 C...g + g -> gamma + Z0
19062 ELSEIF(ISUB.EQ.117) THEN
19063 C...g + g -> Z0 + Z0
19065 ELSEIF(ISUB.EQ.118) THEN
19066 C...g + g -> W+ + W-
19070 C...G: 2 -> 3, tree diagrams
19072 ELSEIF(ISUB.LE.140) THEN
19073 IF(ISUB.EQ.121) THEN
19074 C...g + g -> Q + Qbar + h0
19075 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210
19078 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19079 & (0.5D0*PMF/PMAS(24,1))**2
19080 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19081 & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19082 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19084 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19086 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19088 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19089 IF(IA.GT.10) IKFI=3
19090 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19092 CALL PYQQBH(WTQQBH)
19093 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19095 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19096 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19097 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19103 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19106 ELSEIF(ISUB.EQ.122) THEN
19107 C...q + qbar -> Q + Qbar + h0
19110 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19111 & (0.5D0*PMF/PMAS(24,1))**2
19112 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19113 & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19114 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19116 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19118 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19120 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19121 IF(IA.GT.10) IKFI=3
19122 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19124 CALL PYQQBH(WTQQBH)
19125 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19127 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19128 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19129 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19131 DO 1220 I=MMINA,MMAXA
19132 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19133 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220
19138 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19141 ELSEIF(ISUB.EQ.123) THEN
19142 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
19144 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
19145 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19146 & PARU(154+10*IHIGG)**2
19147 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19148 & (VINT(216)-VINT(209)**2))**2
19149 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19150 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
19151 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19153 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19154 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19155 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19157 DO 1240 I=MMIN1,MMAX1
19158 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240
19160 DO 1230 J=MMIN2,MMAX2
19161 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230
19163 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
19164 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
19166 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
19167 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
19169 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
19170 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
19175 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
19179 ELSEIF(ISUB.EQ.124) THEN
19180 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
19182 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
19183 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19184 & PARU(155+10*IHIGG)**2
19185 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19186 & (VINT(216)-VINT(209)**2))**2
19187 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19188 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19190 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19191 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19192 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19194 DO 1260 I=MMIN1,MMAX1
19195 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260
19196 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
19197 DO 1250 J=MMIN2,MMAX2
19198 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250
19199 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
19200 IF(EI*EJ.GT.0D0) GOTO 1250
19201 FACLR=VINT(180+I)*VINT(180+J)
19206 SIGH(NCHN)=FACLR*FACWW*FACBW
19210 ELSEIF(ISUB.EQ.131) THEN
19211 C...g + g -> Z0 + q + qbar
19215 C...H: 2 -> 1, tree diagrams, non-standard model processes
19217 ELSEIF(ISUB.LE.160) THEN
19218 IF(ISUB.EQ.141) THEN
19219 C...f + fbar -> gamma*/Z0/Z'0
19220 SQMZP=PMAS(32,1)**2
19222 CALL PYWIDT(32,SH,WDTP,WDTE)
19228 FACZP=4D0*COMFAC*3D0
19229 DO 1270 I=MMINA,MMAXA
19230 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1270
19231 EI=KCHG(IABS(I),1)/3D0
19234 IF(IABS(I).LT.10) THEN
19235 VPI=PARU(123-2*MOD(IABS(I),2))
19236 API=PARU(124-2*MOD(IABS(I),2))
19238 VPI=PARU(127-2*MOD(IABS(I),2))
19239 API=PARU(128-2*MOD(IABS(I),2))
19242 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
19244 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
19246 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
19251 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
19252 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
19253 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
19254 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
19255 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
19256 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
19257 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
19258 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
19261 ELSEIF(ISUB.EQ.142) THEN
19262 C...f + fbar' -> W'+/-
19263 SQMWP=PMAS(34,1)**2
19264 CALL PYWIDT(34,SH,WDTP,WDTE)
19266 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
19267 HP=AEM/(24D0*XW)*SH
19268 DO 1290 I=MMIN1,MMAX1
19269 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1290
19271 DO 1280 J=MMIN2,MMAX2
19272 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1280
19274 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1280
19275 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19277 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19278 HI=HP*(PARU(133)**2+PARU(134)**2)
19279 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
19280 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19285 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
19286 SIGH(NCHN)=HI*FACBW*HF
19290 ELSEIF(ISUB.EQ.143) THEN
19291 C...f + fbar' -> H+/-
19292 SQMHC=PMAS(37,1)**2
19293 CALL PYWIDT(37,SH,WDTP,WDTE)
19295 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
19296 HP=AEM/(8D0*XW)*SH/SQMW*SH
19297 DO 1310 I=MMIN1,MMAX1
19298 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1310
19300 IM=(MOD(IA,10)+1)/2
19301 DO 1300 J=MMIN2,MMAX2
19302 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1300
19304 JM=(MOD(JA,10)+1)/2
19305 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1300
19306 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19308 IF(MOD(IA,2).EQ.0) THEN
19315 RML=PMAS(IL,1)**2/SH
19316 RMU=PMAS(IU,1)**2/SH
19317 IF(IL.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) RML=
19318 & RML*(LOG(MAX(4D0,PARP(37)**2*RML*SH/PARU(117)**2))/
19319 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-
19321 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
19322 IF(IA.LE.10) HI=HI*FACA/3D0
19323 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19324 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
19329 SIGH(NCHN)=HI*FACBW*HF
19333 ELSEIF(ISUB.EQ.144) THEN
19336 CALL PYWIDT(40,SH,WDTP,WDTE)
19338 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
19339 HP=AEM/(12D0*XW)*SH
19340 DO 1330 I=MMIN1,MMAX1
19341 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1330
19343 DO 1320 J=MMIN2,MMAX2
19344 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1320
19346 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1320
19348 IF(IA.LE.10) HI=HI*FACA/3D0
19349 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
19354 SIGH(NCHN)=HI*FACBW*HF
19358 ELSEIF(ISUB.EQ.145) THEN
19359 C...q + l -> LQ (leptoquark)
19360 SQMLQ=PMAS(39,1)**2
19361 CALL PYWIDT(39,SH,WDTP,WDTE)
19363 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
19364 IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0
19366 KFLQQ=KFDP(MDCY(39,2),1)
19367 KFLQL=KFDP(MDCY(39,2),2)
19368 DO 1350 I=MMIN1,MMAX1
19369 IF(KFAC(1,I).EQ.0) GOTO 1350
19371 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1350
19372 DO 1340 J=MMIN2,MMAX2
19373 IF(KFAC(2,J).EQ.0) GOTO 1340
19375 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1340
19376 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1340
19377 IF(JA.EQ.IA) GOTO 1340
19378 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
19379 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
19381 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
19386 SIGH(NCHN)=HI*FACBW*HF
19390 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
19391 C...d + g -> d* and u + g -> u* (excited quarks)
19392 KFQSTR=KFPR(ISUB,1)
19393 KCQSTR=PYCOMP(KFQSTR)
19394 KFQEXC=MOD(KFQSTR,KEXCIT)
19395 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
19397 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
19398 FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
19399 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
19402 DO 1370 I=-KFQEXC,KFQEXC,2*KFQEXC
19404 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
19405 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
19407 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19408 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
19411 ISIG(NCHN,3-ISDE)=21
19413 SIGH(NCHN)=HI*FACBW*HF
19417 ELSEIF(ISUB.EQ.149) THEN
19418 C...g + g -> eta_techni
19419 CALL PYWIDT(38,SH,WDTP,WDTE)
19421 FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2)
19422 IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0
19424 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1380
19426 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19431 SIGH(NCHN)=HI*FACBW*HF
19436 C...I: 2 -> 2, tree diagrams, non-standard model processes
19438 ELSEIF(ISUB.LE.200) THEN
19439 IF(ISUB.EQ.161) THEN
19440 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
19441 C...(choice of only b and t to avoid kinematics problems)
19442 SQMHC=PMAS(37,1)**2
19443 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
19444 DO 1400 I=MMINA,MMAXA
19446 IF(IA.NE.5) GOTO 1400
19448 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
19449 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
19450 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19452 SQMQ=PMAS(IUA,1)**2
19453 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
19454 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
19455 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
19456 & (SQMHC-SQMQ-SH)/SH)
19457 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
19459 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1390
19460 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1390
19463 ISIG(NCHN,3-ISDE)=21
19465 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
19469 ELSEIF(ISUB.EQ.162) THEN
19470 C...q + g -> LQ + lbar; LQ=leptoquark
19471 SQMLQ=PMAS(39,1)**2
19472 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
19473 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
19474 KFLQQ=KFDP(MDCY(39,2),1)
19475 DO 1420 I=MMINA,MMAXA
19476 IF(IABS(I).NE.KFLQQ) GOTO 1420
19479 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1410
19480 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1410
19483 ISIG(NCHN,3-ISDE)=21
19485 SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
19489 ELSEIF(ISUB.EQ.163) THEN
19490 C...g + g -> LQ + LQbar; LQ=leptoquark
19491 SQMLQ=PMAS(39,1)**2
19492 FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)*
19493 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
19494 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
19495 & ((TH-SQMLQ)*(UH-SQMLQ)))
19496 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1430
19500 C...Since don't know proper colour flow, randomize between alternatives
19501 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
19505 ELSEIF(ISUB.EQ.164) THEN
19506 C...q + qbar -> LQ + LQbar; LQ=leptoquark
19507 SQMLQ=PMAS(39,1)**2
19508 FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)*
19509 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
19510 FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)*
19511 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
19512 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
19513 KFLQQ=KFDP(MDCY(39,2),1)
19514 DO 1440 I=MMINA,MMAXA
19515 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19516 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1440
19522 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
19525 ELSEIF(ISUB.EQ.165) THEN
19526 C...q + qbar -> l+ + l- (including contact term for compositeness)
19527 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19528 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19529 KFF=IABS(KFPR(ISUB,1))
19531 AF=SIGN(1D0,EF+0.1D0)
19536 IF(KFF.LE.10) FCOF=3D0
19538 IF(KFF.EQ.6) WID2=WIDS(6,1)
19539 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
19540 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19541 DO 1450 I=MMINA,MMAXA
19542 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1450
19543 EI=KCHG(IABS(I),1)/3D0
19544 AI=SIGN(1D0,EI+0.1D0)
19549 IF(IABS(I).LE.10) FCOI=FACA/3D0
19550 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
19551 FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
19552 & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
19553 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19555 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
19556 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19558 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
19559 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
19560 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
19561 IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
19562 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
19567 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
19570 ELSEIF(ISUB.EQ.166) THEN
19571 C...q + q'bar -> l + nu_l (including contact term for compositeness)
19572 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
19573 WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
19574 KFF=IABS(KFPR(ISUB,1))
19576 IF(KFF.LE.10) FCOF=3D0
19577 DO 1470 I=MMIN1,MMAX1
19578 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
19580 DO 1460 J=MMIN2,MMAX2
19581 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
19583 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1460
19584 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19587 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19589 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
19590 & MOD(J,2).EQ.0)) THEN
19591 IF(KFF.EQ.5) WID2=WIDS(6,2)
19592 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
19593 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
19595 IF(KFF.EQ.5) WID2=WIDS(6,3)
19596 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
19597 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
19603 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
19604 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
19605 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
19609 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
19610 C...d + g -> d* and u + g -> u* (excited quarks)
19611 KFQSTR=KFPR(ISUB,2)
19612 KCQSTR=PYCOMP(KFQSTR)
19613 KFQEXC=MOD(KFQSTR,KEXCIT)
19614 FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
19615 FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
19616 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
19617 C...Propagators: as simulated in PYOFSH and as desired
19618 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
19619 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
19620 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
19621 GMMQC=SQRT(SQM4)*WDTP(0)
19622 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
19623 FACQSA=FACQSA*HBW4C/HBW4
19624 FACQSB=FACQSB*HBW4C/HBW4
19625 DO 1490 I=MMIN1,MMAX1
19627 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1490
19628 DO 1480 J=MMIN2,MMAX2
19630 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1480
19631 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
19636 SIGH(NCHN)=(4D0/3D0)*FACQSA
19641 SIGH(NCHN)=(4D0/3D0)*FACQSA
19642 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
19647 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19649 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
19654 SIGH(NCHN)=(8D0/3D0)*FACQSB
19659 SIGH(NCHN)=(8D0/3D0)*FACQSB
19660 ELSEIF(I.EQ.-J) THEN
19671 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
19676 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19682 ELSEIF(ISUB.EQ.191) THEN
19683 C...q + qbar -> rho_tech0.
19684 SQMRHT=PMAS(54,1)**2
19685 CALL PYWIDT(54,SH,WDTP,WDTE)
19687 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19688 IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0
19689 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19690 ALPRHT=2.91D0*(3D0/PARP(144))
19691 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
19692 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19693 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19694 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19695 DO 1500 I=MMINA,MMAXA
19696 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
19698 EI=KCHG(IABS(I),1)/3D0
19699 AI=SIGN(1D0,EI+0.1D0)
19703 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
19704 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
19705 IF(IA.LE.10) HI=HI*FACA/3D0
19710 SIGH(NCHN)=HI*FACBW*HF
19713 ELSEIF(ISUB.EQ.192) THEN
19714 C...q + qbar' -> rho_tech+/-.
19715 SQMRHT=PMAS(55,1)**2
19716 CALL PYWIDT(55,SH,WDTP,WDTE)
19718 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19719 IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0
19720 ALPRHT=2.91D0*(3D0/PARP(144))
19721 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
19722 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
19723 DO 1520 I=MMIN1,MMAX1
19724 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1520
19726 DO 1510 J=MMIN2,MMAX2
19727 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1510
19729 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1510
19730 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19732 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19733 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
19735 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19740 SIGH(NCHN)=HI*FACBW*HF
19744 ELSEIF(ISUB.EQ.193) THEN
19745 C...q + qbar -> omega_tech0.
19746 SQMOMT=PMAS(56,1)**2
19747 CALL PYWIDT(56,SH,WDTP,WDTE)
19749 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
19750 IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0
19751 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19752 ALPRHT=2.91D0*(3D0/PARP(144))
19753 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
19754 & (2D0*PARP(143)-1D0)**2
19755 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19756 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19757 DO 1530 I=MMINA,MMAXA
19758 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1530
19760 EI=KCHG(IABS(I),1)/3D0
19761 AI=SIGN(1D0,EI+0.1D0)
19765 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
19766 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
19767 IF(IA.LE.10) HI=HI*FACA/3D0
19772 SIGH(NCHN)=HI*FACBW*HF
19775 ELSEIF(ISUB.EQ.194) THEN
19776 C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
19777 SQMRHT=PMAS(54,1)**2
19778 CALL PYWIDT(54,SH,WDTP,WDTE)
19780 BWRHTR=SQMRHT**2*(SH-SQMRHT)/((SH-SQMRHT)**2+HSRHT**2)
19781 BWRHTI=SQMRHT**2*HSRHT/((SH-SQMRHT)**2+HSRHT**2)
19782 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19783 SQMOMT=PMAS(56,1)**2
19784 CALL PYWIDT(56,SH,WDTP,WDTE)
19786 BWOMTR=SQMOMT**2*(SH-SQMOMT)/((SH-SQMOMT)**2+HSOMT**2)
19787 BWOMTI=SQMOMT**2*HSOMT/((SH-SQMOMT)**2+HSOMT**2)
19788 XWOMT=0.5D0/(1D0-XW)
19789 KFF=IABS(KFPR(ISUB,1))
19791 AF=SIGN(1D0,EF+0.1D0)
19796 IF(KFF.LE.10) FCOF=3D0
19798 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
19799 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19800 ALPRHT=2.91D0*(3D0/PARP(144))
19801 FACTC=COMFAC*(AEM**2/(ALPRHT*SH2))**2*FCOF*WID2
19803 ALEFTF=EF+VALF*XWRHT*BWZ
19804 ARIGHF=EF+VARF*XWRHT*BWZ
19805 BLEFTF=(EF-VALF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19806 BRIGHF=(EF-VARF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19807 DO 1540 I=MMINA,MMAXA
19808 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
19809 EI=KCHG(IABS(I),1)/3D0
19810 AI=SIGN(1D0,EI+0.1D0)
19815 IF(IABS(I).LE.10) FCOI=FACA/3D0
19816 ALEFTI=EI+VALI*XWRHT*BWZ
19817 ARIGHI=EI+VARI*XWRHT*BWZ
19818 BLEFTI=(EI-VALI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19819 BRIGHI=(EI-VARI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19820 DIFLL=(ALEFTI*ALEFTF*BWRHTR+BLEFTI*BLEFTF*BWOMTR)**2+
19821 & (ALEFTI*ALEFTF*BWRHTI+BLEFTI*BLEFTF*BWOMTI)**2
19822 DIFRR=(ARIGHI*ARIGHF*BWRHTR+BRIGHI*BRIGHF*BWOMTR)**2+
19823 & (ARIGHI*ARIGHF*BWRHTI+BRIGHI*BRIGHF*BWOMTI)**2
19824 DIFLR=(ALEFTI*ARIGHF*BWRHTR+BLEFTI*BRIGHF*BWOMTR)**2+
19825 & (ALEFTI*ARIGHF*BWRHTI+BLEFTI*BRIGHF*BWOMTI)**2
19826 DIFRL=(ARIGHI*ALEFTF*BWRHTR+BRIGHI*BLEFTF*BWOMTR)**2+
19827 & (ARIGHI*ALEFTF*BWRHTI+BRIGHI*BLEFTF*BWOMTI)**2
19828 FACSIG=(DIFLL+DIFRR)*UH2+(DIFLR+DIFRL)*TH2
19833 SIGH(NCHN)=FACTC*FCOI*FACSIG
19839 C...J: 2 -> 2, tree diagrams, SUSY processes
19841 ELSEIF(ISUB.LE.210) THEN
19842 IF(ISUB.EQ.201) THEN
19843 C...f + fbar -> e_L + e_Lbar
19844 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
19845 DO 1570 I=MMIN1,MMAX1
19847 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1570
19849 TT3I=SIGN(1D0,EI+1D-6)/2D0
19853 C...Color factor for e+ e-
19854 IF(IA.GE.11) FCOL=3D0
19856 A1=SFMIX(KFID,3)**2
19857 A2=SFMIX(KFID,4)**2
19858 ELSEIF(ILR.EQ.0) THEN
19859 A1=SFMIX(KFID,1)**2
19860 A2=SFMIX(KFID,2)**2
19862 XLQ=(TT3J-EJ*XW)*A1
19867 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
19868 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
19869 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
19870 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
19874 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19880 DK=1D0/(TH-SMZ(II)**2)
19881 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
19883 FREK=FAC2*TANW*EI*ZMIX(II,1)
19884 TNN1=TNN1+FLEK**2*DK
19885 TNN2=TNN2+FREK**2*DK
19887 DL=1D0/(TH-SMZ(JJ)**2)
19888 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
19890 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
19891 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
19894 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
19895 TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
19896 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
19897 & (TNN1*XLF*A1+TNN2*XRF*A2)
19898 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
19901 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
19903 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
19904 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
19905 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
19910 SIGH(NCHN)=FACQQ1+FACQQ2
19913 ELSEIF(ISUB.EQ.203) THEN
19914 C...f + fbar -> e_L + e_Rbar
19915 DO 1600 I=MMIN1,MMAX1
19917 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
19918 EI=KCHG(IABS(I),1)/3D0
19919 TT3I=SIGN(1D0,EI)/2D0
19923 C...Color factor for e+ e-
19924 IF(IA.GE.11) FCOL=3D0
19925 A1=SFMIX(KFID,1)**2
19926 A2=SFMIX(KFID,2)**2
19931 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
19932 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
19935 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19941 DK=1D0/(TH-SMZ(II)**2)
19942 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
19944 FREK=FAC2*TANW*EI*ZMIX(II,1)
19945 TNN1=TNN1+FLEK**2*DK
19946 TNN2=TNN2+FREK**2*DK
19948 DL=1D0/(TH-SMZ(JJ)**2)
19949 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
19951 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
19952 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
19955 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
19956 TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
19957 TZN=(UH*TH-SQM3*SQM4)*A1*A2
19958 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
19959 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
19962 FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
19963 FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
19964 FACQQ=(FACQQ1+FACQQ2)
19969 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
19970 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
19975 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
19976 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
19979 ELSEIF(ISUB.EQ.210) THEN
19980 C...q + qbar' -> W*- > ~l_L + ~nu_L
19981 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
19982 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
19983 DO 1620 I=MMIN1,MMAX1
19985 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1620
19986 DO 1610 J=MMIN2,MMAX2
19988 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1610
19989 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1610
19991 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
19992 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
19994 IF(KCHSUM.LT.0) KCHW=3
19999 SIGH(NCHN)=FAC0*FAC1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),
20000 & 5-KCHW)*WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20005 ELSEIF(ISUB.LE.220) THEN
20006 IF(ISUB.EQ.213) THEN
20007 C...f + fbar -> ~nu_L + ~nu_Lbar
20008 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20009 PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
20012 DO 1630 I=MMIN1,MMAX1
20014 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
20017 C...Color factor for e+ e-
20018 IF(IA.GE.11) FCOL=3D0
20019 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20023 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
20024 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
20027 TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
20029 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
20035 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
20036 & *AEM**2*FCOL/3D0/XW**2
20039 ELSEIF(ISUB.EQ.216) THEN
20040 C...q + qbar -> ~chi0_1 + ~chi0_1
20041 IF(IZID1.EQ.IZID2) THEN
20042 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20044 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20045 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20047 FACGG1=COMFAC*AEM**2/3D0/XW**2
20048 IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0
20052 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20053 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20054 XS2 = SMZ(IZID1)*SMZ(IZID2)/SH
20055 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20056 REPRPZ = (SH-SQMZ)/PROPZ2
20057 OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+
20058 & ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0
20059 DO 1640 I=MMINA,MMAXA
20060 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1640
20061 EI=KCHG(IABS(I),1)/3D0
20063 IF(ABS(I).GE.11) FCOL=3D0
20064 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20068 C...Factored out sqrt(2)
20069 FR1=TANW*EI*ZMIX(IZID1,1)
20070 FR2=TANW*EI*ZMIX(IZID2,1)
20071 FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW*
20072 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0
20073 FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW*
20074 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0
20079 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
20080 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
20081 FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2)
20082 FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2-
20083 & 2D0*XS2*SH2/(TH-XML2)/(UH-XML2))
20084 FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2-
20085 & 2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2))
20086 FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/
20087 & (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) )
20088 FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/
20089 & (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) )
20094 SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU)
20098 ELSEIF(ISUB.LE.230) THEN
20099 IF(ISUB.EQ.226) THEN
20100 C...f + fbar -> ~chi+_1 + ~chi-_1
20101 FACGG1=COMFAC*AEM**2/3D0/XW**2
20104 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20105 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20106 WS2 = SMW(IZID1)*SMW(IZID2)/SH
20107 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20108 REPRPZ = (SH-SQMZ)/PROPZ2
20110 IF(IZID1.EQ.IZID2) DIFF=1D0
20111 DO 1650 I=MMINA,MMAXA
20112 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1650
20113 EI=KCHG(IABS(I),1)/3D0
20115 IF(IABS(I).GE.11) FCOL=3D0
20116 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20122 OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)-
20123 & VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF
20124 ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)-
20125 & UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF
20128 C...u-type quark - d-type squark
20129 IF(MOD(I,2).EQ.0) THEN
20130 FACT0 = UMIX(IZID1,1)*UMIX(IZID2,1)
20131 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
20132 C...d-type quark - u-type squark
20134 FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1)
20135 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
20137 FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2
20138 FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+
20139 & 4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)*
20140 & (WU2-WT2))*SH2/PROPZ2
20141 FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2
20142 FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+
20143 & WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI)
20144 FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI)
20145 FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2
20146 FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL
20151 IF(IZID1.EQ.IZID2) THEN
20152 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20154 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20155 & WIDS(PYCOMP(KFPR(ISUBSV,1)),2)
20160 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20161 & WIDS(PYCOMP(KFPR(ISUBSV,1)),3)
20165 ELSEIF(ISUB.EQ.229) THEN
20166 C...q + qbar' -> ~chi0_1 + ~chi+-_1
20167 FACGG1=COMFAC*AEM**2/6D0/XW**2
20170 ZMU2 = PMAS(PYCOMP(KSUSY1+2),1)**2
20171 ZMD2 = PMAS(PYCOMP(KSUSY1+1),1)**2
20172 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20173 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20174 WS2 = SMW(IZID1)*SMZ(IZID2)/SH
20175 RT2I = 1D0/SQRT(2D0)
20176 PROPW = ((SH-SQMW)**2+WWID**2*SQMW)
20177 OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+
20178 & ZMIX(IZID2,2)*VMIX(IZID1,1)
20179 OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+
20180 & ZMIX(IZID2,2)*UMIX(IZID1,1)
20184 FACST0=UMIX(IZID1,1)
20185 FACSU0=VMIX(IZID1,1)
20186 FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20187 FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20190 FACTU0=FACSU0*FACST0
20191 FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR
20192 & + SH2*WS2*OL)*FACST0
20193 FACSU = 2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL
20194 & + SH2*WS2*OR)*FACSU0
20195 FACT = WT2*SH2/(TH-ZMD2)**2*FACT0
20196 FACU = WU2*SH2/(UH-ZMU2)**2*FACU0
20197 FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0
20198 FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2
20199 FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST)
20200 DO 1670 I=MMIN1,MMAX1
20202 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1670
20203 DO 1660 J=MMIN2,MMAX2
20205 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1660
20206 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1660
20208 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20209 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20211 IF(KCHSUM.LT.0) KCHW=3
20216 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20217 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20222 ELSEIF(ISUB.LE.240) THEN
20223 IF(ISUB.EQ.237) THEN
20224 C...q + qbar -> gluino + ~chi0_1
20225 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20226 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20227 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
20230 DO 1680 I=MMINA,MMAXA
20231 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1680
20232 EI=KCHG(IABS(I),1)/3D0
20234 XLQC = -TANW*EI*ZMIX(IZID,1)
20235 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20236 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20239 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
20240 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
20241 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
20242 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
20243 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
20244 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20245 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
20246 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
20247 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
20248 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20253 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
20257 ELSEIF(ISUB.LE.250) THEN
20258 IF(ISUB.EQ.241) THEN
20259 C...q + qbar' -> ~chi+-_1 + gluino
20260 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
20263 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
20264 FAC0=UMIX(IZID,1)**2
20265 FAC1=VMIX(IZID,1)**2
20266 DO 1700 I=MMIN1,MMAX1
20268 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1700
20269 DO 1690 J=MMIN2,MMAX2
20271 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1690
20272 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1690
20274 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20275 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20277 IF(KCHSUM.LT.0) KCHW=3
20278 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
20279 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
20280 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
20281 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
20282 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
20283 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
20284 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
20285 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
20286 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
20287 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
20288 & SH/(TH-XMU2)/(UH-XMD2))/2D0
20293 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
20294 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20295 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20299 ELSEIF(ISUB.EQ.243) THEN
20300 C...q + qbar -> gluino + gluino
20301 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20304 DO 1710 I=MMINA,MMAXA
20305 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
20306 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
20308 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
20309 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
20310 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20311 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20312 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20313 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20314 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
20315 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
20316 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20317 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20318 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20319 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20323 C...1/2 for identical particles
20324 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
20327 ELSEIF(ISUB.EQ.244) THEN
20328 C...g + g -> gluino + gluino
20329 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20332 FACQQ1=COMFAC*AS**2*9D0/4D0*(
20333 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
20334 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
20335 FACQQ2=COMFAC*AS**2*9D0/4D0*(
20336 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
20337 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
20338 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
20339 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
20340 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
20345 SIGH(NCHN)=FACQQ1/2D0
20350 SIGH(NCHN)=FACQQ2/2D0
20355 SIGH(NCHN)=FACQQ3/2D0
20358 ELSEIF(ISUB.EQ.246) THEN
20359 C...g + q_j -> ~chi0_1 + ~q_j
20360 FAC0=COMFAC*AS*AEM/6D0/XW
20363 FACZQ0=FAC0*( (ZM2-TH)/SH +
20364 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20365 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20366 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20367 DO 1740 I=-KFNSQ,KFNSQ,2*KFNSQ
20368 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1740
20369 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
20370 EI=KCHG(IABS(I),1)/3D0
20372 XRQZ = -TANW*EI*ZMIX(IZID,1)
20373 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20374 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20376 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
20378 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
20384 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1730
20385 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1730
20388 ISIG(NCHN,3-ISDE)=21
20390 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20391 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20396 ELSEIF(ISUB.LE.260) THEN
20397 IF(ISUB.EQ.254) THEN
20398 C...g + q_j -> ~chi1_1 + ~q_i
20399 FAC0=COMFAC*AS*AEM/12D0/XW
20404 FACZQ0=FAC0*( (ZM2-TH)/SH +
20405 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20406 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20407 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
20408 IF(MOD(KFNSQ1,2).EQ.0) THEN
20415 DO 1760 I=-KFNSQ,KFNSQ,2*KFNSQ
20416 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1760
20417 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1760
20419 IF(MOD(IA,2).EQ.0) THEN
20424 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
20428 IF(I.LT.0) KCHWQ=5-KCHW
20430 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1750
20431 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1750
20434 ISIG(NCHN,3-ISDE)=21
20436 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20437 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
20441 ELSEIF(ISUB.EQ.258) THEN
20442 C...g + q_j -> gluino + ~q_i
20449 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
20450 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
20451 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
20452 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
20453 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
20455 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
20456 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
20457 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
20458 FACQG1=COMFAC*AS**2*FACQG1/2D0
20459 FACQG2=COMFAC*AS**2*FACQG2/2D0
20460 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20461 DO 1780 I=-KFNSQ,KFNSQ,2*KFNSQ
20462 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1780
20463 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1780
20466 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20467 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20469 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1770
20470 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1770
20473 ISIG(NCHN,3-ISDE)=21
20475 SIGH(NCHN)=FACQG1*FACSEL
20478 ISIG(NCHN,3-ISDE)=21
20480 SIGH(NCHN)=FACQG2*FACSEL
20485 ELSEIF(ISUB.LE.270) THEN
20486 IF(ISUB.EQ.261) THEN
20487 C...q_i + q_ibar -> ~t_1 + ~t_1bar
20488 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
20489 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20490 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20492 DO 1790 I=MMIN1,MMAX1
20494 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1790
20495 IF(IA.GE.11.AND.IA.LE.18) THEN
20497 EJ=KCHG(KFNSQ,1)/3D0
20498 T3I=SIGN(1D0,EI)/2D0
20499 T3J=SIGN(1D0,EJ)/2D0
20500 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
20501 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
20502 XLF=2D0*(T3I-EI*XW)
20504 TAA=0.5D0*(EI*EJ)**2
20505 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20506 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20507 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20508 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20509 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20515 SIGH(NCHN)=FACQQ1*FAC0
20518 ELSEIF(ISUB.EQ.263) THEN
20519 C...f + fbar -> ~t1 + ~t2bar
20520 DO 1800 I=MMIN1,MMAX1
20522 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
20523 EI=KCHG(IABS(I),1)/3D0
20524 TT3I=SIGN(1D0,EI)/2D0
20528 C...Color factor for e+ e-
20529 IF(IA.GE.11) FCOL=3D0
20530 XLQ=2D0*(TT3J-EJ*XW)
20532 XLF=2D0*(TT3I-EI*XW)
20534 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
20535 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
20536 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20537 C...Factor of 2 for t1 t2bar + t2 t1bar
20538 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
20539 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
20544 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20545 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
20550 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20551 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20554 ELSEIF(ISUB.EQ.264) THEN
20555 C...g + g -> ~t_1 + ~t_1bar
20558 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
20559 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20560 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20561 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20562 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1810
20576 ELSEIF(ISUB.LE.280) THEN
20577 IF(ISUB.EQ.271) THEN
20578 C...q + q' -> ~q + ~q' (~g exchange)
20579 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20587 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
20588 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
20591 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
20592 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
20593 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
20596 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20597 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20598 DO 1830 I=-KFNSQI,KFNSQI,2*KFNSQI
20599 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1830
20601 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1830
20604 DO 1820 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20605 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1820
20607 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1820
20608 IF(I*J.LT.0) GOTO 1820
20613 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20614 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20616 IF(ISUBSV.LE.272) THEN
20617 SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20618 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20620 SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20621 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20622 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20628 IF(ISUBSV.LE.272) THEN
20629 SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20630 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20632 SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20633 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20634 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20640 ELSEIF(ISUB.EQ.274) THEN
20641 C...q + qbar -> ~q' + ~qbar'
20642 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20646 FACQQ1=COMFAC*AS**2*4D0/9D0*(
20647 & (UH*TH-SQM3*SQM4)/XMT**2 )
20648 FACQQB=COMFAC*AS**2*4D0/9D0*(
20649 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT**2))
20650 FACQQB=FACQQB+FACQQ1
20652 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
20655 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20656 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20657 DO 1850 I=-KFNSQI,KFNSQI,2*KFNSQI
20658 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1850
20660 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1850
20663 DO 1840 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20664 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1840
20666 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1840
20667 IF(I*J.GT.0) GOTO 1840
20672 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20673 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
20674 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
20675 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20679 ELSEIF(ISUB.EQ.277) THEN
20680 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
20681 C...if i .eq. j covered in 274
20682 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
20683 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20685 DO 1860 I=MMIN1,MMAX1
20687 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
20688 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
20689 IF(IA.EQ.KFNSQ) GOTO 1860
20690 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
20692 EJ=KCHG(KFNSQ,1)/3D0
20694 T3I=SIGN(1D0,EI)/2D0
20696 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
20697 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
20699 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
20700 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
20702 XLF=2D0*(T3I-EI*XW)
20709 TAA=0.5D0*(EI*EJ)**2
20710 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20711 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20712 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20713 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20714 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20715 ELSEIF(IA.LE.6) THEN
20716 FAC0=AS**2*8D0/9D0/2D0
20722 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20725 ELSEIF(ISUB.EQ.279) THEN
20726 C...g + g -> ~q_j + ~q_jbar
20729 C...5=RKF because ~t ~tbar treated separately
20730 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
20731 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20732 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20733 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870
20738 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20743 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20750 C...Multiply with parton distributions
20751 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20752 DO 1880 ICHN=1,NCHN
20753 IF(MINT(45).GE.2) THEN
20755 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20757 IF(MINT(46).GE.2) THEN
20759 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20761 SIGS=SIGS+SIGH(ICHN)
20768 C*********************************************************************
20771 C...Gives electron, photon, pi+, neutron, proton and hyperon
20772 C...parton distributions according to a few different parametrizations.
20773 C...Note that what is coded is x times the probability distribution,
20774 C...i.e. xq(x,Q2) etc.
20776 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
20778 C...Double precision and integer declarations.
20779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20780 INTEGER PYK,PYCHGE,PYCOMP
20782 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20783 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20784 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20785 COMMON/PYINT1/MINT(400),VINT(400)
20786 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
20788 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
20790 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
20791 &XPPI(-6:6),XPPR(-6:6)
20793 C...Interface to PDFLIB.
20794 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
20796 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
20797 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
20798 CHARACTER*20 PARM(20)
20799 DATA VALUE/20*0D0/,PARM/20*' '/
20801 C...Data related to Schuler-Sjostrand photon distributions.
20802 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
20804 C...Reset parton distributions.
20810 C...Check x and particle species.
20811 IF(X.LE.0D0.OR.X.GE.1D0) THEN
20812 WRITE(MSTU(11),5000) X
20816 IF(KFA.NE.11.AND.KFA.NE.22.AND.KFA.NE.211.AND.KFA.NE.2112.AND.
20817 &KFA.NE.2212.AND.KFA.NE.3122.AND.KFA.NE.3112.AND.KFA.NE.3212
20818 &.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.KFA.NE.3322.AND.
20819 &KFA.NE.3334.AND.KFA.NE.111) THEN
20820 WRITE(MSTU(11),5100) KF
20824 C...Electron parton distribution call.
20826 CALL PYPDEL(X,Q2,XPEL)
20831 C...Photon parton distribution call (VDM+anomalous).
20832 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
20833 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
20834 CALL PYPDGA(X,Q2,XPGA)
20838 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
20841 IF(MSTP(55).GE.7) P2MX=4.0D0
20842 IF(MSTP(57).EQ.0) Q2MX=P2MX
20843 CALL PYGGAM(MSTP(55)-4,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20848 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
20851 IF(MSTP(55).GE.11) P2MX=4.0D0
20852 IF(MSTP(57).EQ.0) Q2MX=P2MX
20853 CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20855 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
20858 ELSEIF(MSTP(56).EQ.2) THEN
20859 C...Call PDFLIB parton distributions.
20863 VALUE(2)=MSTP(55)/1000
20865 VALUE(3)=MOD(MSTP(55),1000)
20866 IF(MINT(93).NE.3000000+MSTP(55)) THEN
20867 CALL PDFSET(PARM,VALUE)
20868 MINT(93)=3000000+MSTP(55)
20871 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20872 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20873 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20889 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
20892 C...Pion/gammaVDM parton distribution call.
20893 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND.
20894 & MINT(109).EQ.2)) THEN
20895 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
20896 & MSTP(55).LE.12) THEN
20897 ISET=1+MOD(MSTP(55)-1,4)
20900 IF(ISET.GE.3) P2MX=4.0D0
20901 IF(MSTP(57).EQ.0) Q2MX=P2MX
20902 CALL PYGVMD(ISET,2,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20907 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
20908 CALL PYPDPI(X,Q2,XPPI)
20912 ELSEIF(MSTP(54).EQ.2) THEN
20913 C...Call PDFLIB parton distributions.
20917 VALUE(2)=MSTP(53)/1000
20919 VALUE(3)=MOD(MSTP(53),1000)
20920 IF(MINT(93).NE.2000000+MSTP(53)) THEN
20921 CALL PDFSET(PARM,VALUE)
20922 MINT(93)=2000000+MSTP(53)
20925 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20926 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20927 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20943 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
20946 C...Anomalous photon parton distribution call.
20947 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
20950 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
20951 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
20952 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
20953 IF(MSTP(57).EQ.0) Q2MX=P2MX
20954 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20959 ELSEIF(MSTP(56).EQ.1) THEN
20960 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
20961 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
20962 IF(MSTP(57).EQ.0) Q2MX=P2MX
20963 CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GM,XPGA)
20965 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
20968 ELSEIF(MSTP(56).EQ.2) THEN
20969 IF(MSTP(57).EQ.0) Q2MX=P2MX
20970 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20975 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
20976 IF(MSTP(57).EQ.0) Q2MX=P2MX
20977 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
20983 210 RKF=11D0*PYR(0)
20985 IF(RKF.GT.1D0) KFR=2
20986 IF(RKF.GT.5D0) KFR=3
20987 IF(RKF.GT.6D0) KFR=4
20988 IF(RKF.GT.10D0) KFR=5
20989 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
20990 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
20991 IF(MSTP(57).EQ.0) Q2MX=P2MX
20992 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
20999 C...Proton parton distribution call.
21001 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.11) THEN
21002 CALL PYPDPR(X,Q2,XPPR)
21006 ELSEIF(MSTP(52).EQ.2) THEN
21007 C...Call PDFLIB parton distributions.
21011 VALUE(2)=MSTP(51)/1000
21013 VALUE(3)=MOD(MSTP(51),1000)
21014 IF(MINT(93).NE.1000000+MSTP(51)) THEN
21015 CALL PDFSET(PARM,VALUE)
21016 MINT(93)=1000000+MSTP(51)
21019 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21020 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21021 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21037 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
21041 C...Isospin average for pi0/gammaVDM.
21042 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
21043 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
21048 XPS=0.5D0*(XPQ(1)+XPQ(-2))
21049 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
21053 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
21054 XPQ(1)=XPQ(1)+0.2D0*XPV
21055 XPQ(-1)=XPQ(-1)+0.2D0*XPV
21056 XPQ(2)=XPQ(2)+0.8D0*XPV
21057 XPQ(-2)=XPQ(-2)+0.8D0*XPV
21058 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
21060 XPQ(-3)=XPQ(-3)+XPV
21061 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
21063 XPQ(-4)=XPQ(-4)+XPV
21064 IF(MSTP(55).GE.9) THEN
21070 XPQ(1)=XPQ(1)+0.5D0*XPV
21071 XPQ(-1)=XPQ(-1)+0.5D0*XPV
21072 XPQ(2)=XPQ(2)+0.5D0*XPV
21073 XPQ(-2)=XPQ(-2)+0.5D0*XPV
21076 C...Rescale for gammaVDM by effective gamma -> rho coupling.
21077 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
21079 XPQ(KFL)=VINT(281)*XPQ(KFL)
21081 VINT(232)=VINT(281)*XPV
21084 C...Isospin conjugation for neutron.
21085 ELSEIF(KFA.EQ.2112) THEN
21093 C...Simple recipes for hyperon (average valence parton distribution).
21094 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
21095 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
21096 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
21097 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
21102 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
21103 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
21104 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
21107 C...Charge conjugation for antiparticle.
21110 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
21117 C...Allow gluon also in position 21.
21120 C...Check positivity and reset above maximum allowed flavour.
21122 XPQ(KFL)=MAX(0D0,XPQ(KFL))
21123 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
21126 C...Formats for error printouts.
21127 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21128 5100 FORMAT(' Error: illegal particle code for parton distribution;',
21130 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
21136 C*********************************************************************
21139 C...Gives proton parton distribution at small x and/or Q^2 according to
21140 C...correct limiting behaviour.
21142 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
21144 C...Double precision and integer declarations.
21145 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21146 INTEGER PYK,PYCHGE,PYCOMP
21148 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21149 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21150 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21151 COMMON/PYINT1/MINT(400),VINT(400)
21152 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21154 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
21155 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
21157 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
21161 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
21162 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
21163 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
21165 CALL PYPDFU(KF,X,Q2,XPQ)
21169 C...Reset. Check x.
21173 IF(X.LE.0D0.OR.X.GE.1D0) THEN
21174 WRITE(MSTU(11),5000) X
21178 C...Define valence content.
21182 IF(KF.EQ.2212) THEN
21185 ELSEIF(KF.EQ.-2212) THEN
21188 ELSEIF(KF.EQ.2112) THEN
21191 ELSEIF(KF.EQ.-2112) THEN
21194 ELSEIF(KF.EQ.211) THEN
21198 ELSEIF(KF.EQ.-211) THEN
21202 ELSEIF(MINT(105).LE.223) THEN
21207 ELSEIF(MINT(105).EQ.333) THEN
21212 ELSEIF(MINT(105).EQ.443) THEN
21219 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
21220 CALL PYPDFU(KFC,X,Q2,XPA)
21221 Q2MN=MAX(3D0,VINT(231))
21222 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
21223 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
21225 C...Large Q2 and large x: naive call is enough.
21226 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
21232 C...Small Q2 and large x: dampen boundary value.
21233 ELSEIF(X.GT.XMN) THEN
21235 C...Evaluate at boundary and define dampening factors.
21236 CALL PYPDFU(KFC,X,Q2MN,XPA)
21237 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
21238 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
21240 C...Separate valence and sea parts of parton distribution.
21242 XFV1=XPA(KFV1)-XPA(-KFV1)
21243 XPA(KFV1)=XPA(-KFV1)
21244 XFV2=XPA(KFV2)-XPA(-KFV2)
21245 XPA(KFV2)=XPA(-KFV2)
21247 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21248 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21249 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21250 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21253 C...Dampen valence and sea separately. Put back together.
21255 XPQ(KFL)=FS*XPA(KFL)
21258 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
21259 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
21261 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
21262 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
21263 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
21264 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
21268 C...Large Q2 and small x: interpolate behaviour.
21269 ELSEIF(Q2.GT.Q2MN) THEN
21271 C...Evaluate at extremes and define coefficients for interpolation.
21272 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21274 CALL PYPDFU(KFC,X,Q2B,XPB)
21276 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
21277 FVA=(X/XMN)**0.45D0*FLA
21278 FSA=(X/XMN)**(-0.08D0)*FLA
21281 C...Separate valence and sea parts of parton distribution.
21283 XFVA1=XPA(KFV1)-XPA(-KFV1)
21284 XPA(KFV1)=XPA(-KFV1)
21285 XFVA2=XPA(KFV2)-XPA(-KFV2)
21286 XPA(KFV2)=XPA(-KFV2)
21287 XFVB1=XPB(KFV1)-XPB(-KFV1)
21288 XPB(KFV1)=XPB(-KFV1)
21289 XFVB2=XPB(KFV2)-XPB(-KFV2)
21290 XPB(KFV2)=XPB(-KFV2)
21292 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
21293 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
21294 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
21295 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
21296 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
21297 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
21298 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
21299 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
21302 C...Interpolate for valence and sea. Put back together.
21304 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
21307 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
21308 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
21310 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21311 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21312 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21313 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21317 C...Small Q2 and small x: dampen boundary value and add term.
21320 C...Evaluate at boundary and define dampening factors.
21321 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21322 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
21324 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
21325 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
21326 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
21327 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
21328 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
21329 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
21331 C...Separate valence and sea parts of parton distribution.
21333 XFV1=XPA(KFV1)-XPA(-KFV1)
21334 XPA(KFV1)=XPA(-KFV1)
21335 XFV2=XPA(KFV2)-XPA(-KFV2)
21336 XPA(KFV2)=XPA(-KFV2)
21338 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21339 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21340 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21341 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21344 C...Dampen valence and sea separately. Add constant terms.
21345 C...Put back together.
21347 XPQ(KFL)=FSA*XPA(KFL)
21351 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
21353 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
21354 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
21357 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
21359 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21360 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21361 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21362 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21368 C...Format for error printout.
21369 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21374 C*********************************************************************
21377 C...Gives electron parton distribution.
21379 SUBROUTINE PYPDEL(X,Q2,XPEL)
21381 C...Double precision and integer declarations.
21382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21383 INTEGER PYK,PYCHGE,PYCOMP
21385 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21386 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21387 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21388 COMMON/PYINT1/MINT(400),VINT(400)
21389 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21391 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
21393 C...Interface to PDFLIB.
21394 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
21396 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
21397 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
21398 CHARACTER*20 PARM(20)
21399 DATA VALUE/20*0D0/,PARM/20*' '/
21401 C...Some common constants.
21407 XL=LOG(MAX(1D-10,X))
21408 X1L=LOG(MAX(1D-10,1D0-X))
21409 HLE=LOG(MAX(3D0,Q2/PME**2))
21410 HBE2=(AEM/PARU(1))*(HLE-1D0)
21412 C...Electron inside electron, see R. Kleiss et al., in Z physics at
21413 C...LEP 1, CERN 89-08, p. 34
21414 IF(MSTP(59).LE.1) THEN
21415 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
21416 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
21417 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
21418 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
21419 & 4D0*XL/(1D0-X)-5D0-X)
21421 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
21422 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
21423 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
21425 IF(X.GT.0.9999D0.AND.X.LE.0.999999D0) THEN
21426 HEE=HEE*100D0**HBE2/(100D0**HBE2-1D0)
21427 ELSEIF(X.GT.0.999999D0) THEN
21432 C...Photon and (transverse) W- inside electron.
21433 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
21434 IF(MSTP(13).LE.1) THEN
21437 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
21439 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
21440 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
21441 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
21443 C...Electron or positron inside photon inside electron.
21444 IF(MSTP(12).EQ.1) THEN
21445 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
21446 & 2D0*X*(1D0+X)*XL)
21447 XPEL(11)=XPEL(11)+XFSEA
21450 C...Initialize PDFLIB photon parton distributions.
21451 IF(MSTP(56).EQ.2) THEN
21455 VALUE(2)=MSTP(55)/1000
21457 VALUE(3)=MOD(MSTP(55),1000)
21458 IF(MINT(93).NE.3000000+MSTP(55)) THEN
21459 CALL PDFSET(PARM,VALUE)
21460 MINT(93)=3000000+MSTP(55)
21464 C...Quarks and gluons inside photon inside electron:
21465 C...numerical convolution required.
21474 IF(ITER.EQ.0) NSTP=2
21476 SXP(KFL)=0.5D0*SXP(KFL)
21479 IF(ITER.EQ.0) WTSTP=0.5D0
21480 C...Pick grid of x_{gamma} values logarithmically even.
21485 XLE=XL*(ISTP-0.5D0)/NSTP
21487 XE=MIN(0.999999D0,EXP(XLE))
21488 XG=MIN(0.999999D0,X/XE)
21489 C...Evaluate photon inside electron parton distribution for convolution.
21490 XPGP=1D0+(1D0-XE)**2
21491 IF(MSTP(13).LE.1) THEN
21494 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
21496 C...Evaluate photon parton distributions for convolution.
21497 IF(MSTP(56).EQ.1) THEN
21498 CALL PYPDGA(XG,Q2,XPGA)
21500 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
21502 ELSEIF(MSTP(56).EQ.2) THEN
21503 C...Call PDFLIB parton distributions.
21505 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21506 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21507 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21508 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
21509 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
21510 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
21511 SXP(3)=SXP(3)+WTSTP*XPGP*STR
21512 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
21513 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
21514 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
21517 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
21518 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
21519 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
21521 C...Put convolution into output arrays.
21523 XPEL(0)=FCONV*SXP(0)
21525 XPEL(KFL)=FCONV*SXP(KFL)
21526 XPEL(-KFL)=XPEL(KFL)
21533 C*********************************************************************
21536 C...Gives photon parton distribution.
21538 SUBROUTINE PYPDGA(X,Q2,XPGA)
21540 C...Double precision and integer declarations.
21541 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21542 INTEGER PYK,PYCHGE,PYCOMP
21544 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21545 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21546 COMMON/PYINT1/MINT(400),VINT(400)
21547 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
21549 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
21550 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
21551 &DGCS(4,3),DGDS(4,3),DGES(4,3)
21553 C...The following data lines are coefficients needed in the
21554 C...Drees and Grassie photon parton distribution parametrization.
21555 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
21556 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
21557 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
21558 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
21559 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
21560 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
21561 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
21562 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
21563 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
21564 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
21565 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
21566 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
21567 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
21568 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
21569 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
21570 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
21571 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
21572 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
21573 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
21574 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
21575 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
21576 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
21577 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
21578 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
21579 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
21580 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
21582 C...Photon parton distribution from Drees and Grassie.
21583 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
21588 IF(MSTP(57).LE.0) THEN
21591 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
21595 IF(Q2.GT.25D0) NF=4
21596 IF(Q2.GT.300D0) NF=5
21600 C...Evaluate gluon content.
21601 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
21602 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
21603 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
21604 XPGL=DGA*X**DGB*X1**DGC
21606 C...Evaluate up- and down-type quark content.
21607 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
21608 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
21609 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
21610 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
21611 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
21612 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21613 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
21614 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
21615 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
21616 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
21617 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
21619 IF(NF.EQ.4) DGF=10D0
21620 IF(NF.EQ.5) DGF=55D0/6D0
21621 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21623 XPQU=(XPQS+9D0*XPQN)/6D0
21624 XPQD=(XPQS-4.5D0*XPQN)/6D0
21625 ELSEIF(NF.EQ.4) THEN
21626 XPQU=(XPQS+6D0*XPQN)/8D0
21627 XPQD=(XPQS-6D0*XPQN)/8D0
21629 XPQU=(XPQS+7.5D0*XPQN)/10D0
21630 XPQD=(XPQS-5D0*XPQN)/10D0
21633 C...Put into output arrays.
21638 IF(NF.GE.4) XPGA(4)=AEM*XPQU
21639 IF(NF.GE.5) XPGA(5)=AEM*XPQD
21641 XPGA(-KFL)=XPGA(KFL)
21647 C*********************************************************************
21650 C...Constructs the F2 and parton distributions of the photon
21651 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
21652 C...For F2, c and b are included by the Bethe-Heitler formula;
21653 C...in the 'MSbar' scheme additionally a Cgamma term is added.
21654 C...Contains the SaS sets 1D, 1M, 2D and 2M.
21655 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21657 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
21659 C...Double precision and integer declarations.
21660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21661 INTEGER PYK,PYCHGE,PYCOMP
21663 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
21665 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
21666 SAVE /PYINT8/,/PYINT9/
21668 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
21669 C...Charm and bottom masses (low to compensate for J/psi etc.).
21670 DATA PMC/1.3D0/, PMB/4.6D0/
21671 C...alpha_em and alpha_em/(2*pi).
21672 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
21673 C...Lambda value for 4 flavours.
21675 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
21677 C...VMD couplings f_V**2/(4*pi).
21678 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
21679 C...Masses for rho (=omega) and phi.
21680 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
21681 C...Number of points in integration for IP2=1.
21699 C...Set Q0 cut-off parameter as function of set used.
21707 C...Scale choice for off-shell photon; common factors.
21712 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21713 FACNOR=LOG(Q2/Q02)/NSTEP
21714 ELSEIF(IP2.EQ.2) THEN
21716 ELSEIF(IP2.EQ.3) THEN
21718 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21719 ELSEIF(IP2.EQ.4) THEN
21720 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21721 & ((Q2+P2)*(Q02+P2)))
21722 ELSEIF(IP2.EQ.5) THEN
21723 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21724 & ((Q2+P2)*(Q02+P2)))
21725 P2MX=Q0*SQRT(P2MXA)
21726 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
21727 ELSEIF(IP2.EQ.6) THEN
21728 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21729 & ((Q2+P2)*(Q02+P2)))
21730 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21732 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21733 & ((Q2+P2)*(Q02+P2)))
21734 P2MX=Q0*SQRT(P2MXA)
21736 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21737 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
21738 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
21741 C...Call VMD parametrization for d quark and use to give rho, omega,
21742 C...phi. Note dipole dampening for off-shell photon.
21743 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21747 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
21748 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
21750 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
21752 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
21753 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
21754 XPVMD(3)=XPVMD(3)+FACS*XFVAL
21755 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
21756 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
21757 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
21758 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
21759 VXPVMD(2)=FRACU*FACUD*XFVAL
21760 VXPVMD(3)=FACS*XFVAL
21761 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
21762 VXPVMD(-2)=FRACU*FACUD*XFVAL
21763 VXPVMD(-3)=FACS*XFVAL
21766 C...Anomalous parametrizations for different strategies
21767 C...for off-shell photons; except full integration.
21769 C...Call anomalous parametrization for d + u + s.
21770 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21772 XPANL(KFL)=FACNOR*XPGA(KFL)
21773 VXPANL(KFL)=FACNOR*VXPGA(KFL)
21776 C...Call anomalous parametrization for c and b.
21777 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21779 XPANH(KFL)=FACNOR*XPGA(KFL)
21780 VXPANH(KFL)=FACNOR*VXPGA(KFL)
21782 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21784 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
21785 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
21789 C...Special option: loop over flavours and integrate over k2.
21791 DO 160 ISTEP=1,NSTEP
21792 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
21793 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
21794 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
21795 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
21796 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
21797 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
21798 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
21800 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
21801 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
21802 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
21803 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
21809 C...Call Bethe-Heitler term expression for charm and bottom.
21810 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
21813 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
21817 C...For MSbar subtraction call C^gamma term expression for d, u, s.
21818 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
21819 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
21821 XPDIR(KFL)=XPGA(KFL)
21825 C...Store result in output array.
21828 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
21829 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
21830 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
21831 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
21832 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
21838 C*********************************************************************
21841 C...Evaluates the VMD parton distributions of a photon,
21842 C...evolved homogeneously from an initial scale P2 to Q2.
21843 C...Does not include dipole suppression factor.
21844 C...ISET is parton distribution set, see above;
21845 C...additionally ISET=0 is used for the evolution of an anomalous photon
21846 C...which branched at a scale P2 and then evolved homogeneously to Q2.
21847 C...ALAM is the 4-flavour Lambda, which is automatically converted
21848 C...to 3- and 5-flavour equivalents as needed.
21849 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21851 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
21853 C...Double precision and integer declarations.
21854 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21855 INTEGER PYK,PYCHGE,PYCOMP
21856 C...Local arrays and data.
21857 DIMENSION XPGA(-6:6), VXPGA(-6:6)
21858 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
21867 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
21868 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
21869 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
21870 P2EFF=MAX(P2,1.2D0*ALAM3**2)
21871 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
21872 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
21873 Q2EFF=MAX(Q2,P2EFF)
21875 C...Find number of flavours at lower and upper scale.
21877 IF(P2EFF.LT.PMC**2) NFP=3
21878 IF(P2EFF.GT.PMB**2) NFP=5
21880 IF(Q2EFF.LT.PMC**2) NFQ=3
21881 IF(Q2EFF.GT.PMB**2) NFQ=5
21883 C...Find s as sum of 3-, 4- and 5-flavour parts.
21887 IF(NFQ.EQ.3) Q2DIV=Q2EFF
21888 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
21890 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
21892 IF(NFP.EQ.3) P2DIV=PMC**2
21894 IF(NFQ.EQ.5) Q2DIV=PMB**2
21895 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
21899 IF(NFP.EQ.5) P2DIV=P2EFF
21900 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
21903 C...Calculate frequent combinations of x and s.
21910 C...Evaluate homogeneous anomalous parton distributions below or
21911 C...above threshold.
21913 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21914 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21915 XVAL = X * 1.5D0 * (X**2+X1**2)
21919 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
21920 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
21921 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
21922 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
21923 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
21924 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
21925 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
21926 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
21927 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
21928 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
21929 & (2D0*X-1D0)*X*XL**2)
21932 C...Evaluate set 1D parton distributions below or above threshold.
21933 ELSEIF(ISET.EQ.1) THEN
21934 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21935 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21936 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
21937 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
21938 XSEA = 0.100D0 * X1**3.76D0
21940 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
21941 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
21942 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
21943 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
21944 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
21945 & X**0.40D0 * X1**(1.76D0+3D0*S)
21946 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
21947 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
21948 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
21949 XSEA0 = 0.100D0 * X1**3.76D0
21952 C...Evaluate set 1M parton distributions below or above threshold.
21953 ELSEIF(ISET.EQ.2) THEN
21954 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21955 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21956 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
21957 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
21960 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
21961 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
21962 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
21963 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
21964 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
21965 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
21966 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
21967 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
21972 C...Evaluate set 2D parton distributions below or above threshold.
21973 ELSEIF(ISET.EQ.3) THEN
21974 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21975 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21976 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
21977 XGLU = 1.925D0 * X1**2
21978 XSEA = 0.242D0 * X1**4
21980 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
21981 & X**(0.46D0+0.25D0*S) *
21982 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
21983 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
21984 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
21985 & EXP(-18.67D0*S) *
21986 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
21987 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
21988 & XL**(9.3D0*S/(1D0+1.7D0*S))
21989 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
21990 & (1D0-0.607D0*S+21.95D0*S2) *
21991 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
21992 XSEA0 = 0.242D0 * X1**4
21995 C...Evaluate set 2M parton distributions below or above threshold.
21996 ELSEIF(ISET.EQ.4) THEN
21997 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21998 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21999 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
22000 XGLU = 1.808D0 * X1**2
22001 XSEA = 0.209D0 * X1**4
22003 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
22004 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
22005 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
22006 & XL**(5.15D0*S/(1D0+2D0*S)) +
22007 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
22008 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
22009 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
22010 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
22011 & XL**(10.9D0*S/(1D0+2.5D0*S))
22012 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
22013 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
22014 & X1**(4D0+S) * XL**(0.45D0*S)
22015 XSEA0 = 0.209D0 * X1**4
22019 C...Threshold factors for c and b sea.
22020 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22022 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22023 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22025 XCHM=XSEA*(1D0-(SCH/SLL)**2)
22027 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
22031 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22032 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22034 XBOT=XSEA*(1D0-(SBT/SLL)**2)
22036 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
22040 C...Fill parton distributions.
22047 XPGA(KFA)=XPGA(KFA)+XVAL
22049 XPGA(-KFL)=XPGA(KFL)
22057 C*********************************************************************
22060 C...Evaluates the parton distributions of the anomalous photon,
22061 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
22062 C...KF=0 gives the sum over (up to) 5 flavours,
22063 C...KF<0 limits to flavours up to abs(KF),
22064 C...KF>0 is for flavour KF only.
22065 C...ALAM is the 4-flavour Lambda, which is automatically converted
22066 C...to 3- and 5-flavour equivalents as needed.
22067 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22069 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
22071 C...Double precision and integer declarations.
22072 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22073 INTEGER PYK,PYCHGE,PYCOMP
22074 C...Local arrays and data.
22075 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
22076 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
22083 IF(Q2.LE.P2) RETURN
22086 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
22087 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
22089 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
22090 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
22091 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
22092 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
22093 Q2EFF=MAX(Q2,P2EFF)
22096 C...Find number of flavours at lower and upper scale.
22098 IF(P2EFF.LT.PMC**2) NFP=3
22099 IF(P2EFF.GT.PMB**2) NFP=5
22101 IF(Q2EFF.LT.PMC**2) NFQ=3
22102 IF(Q2EFF.GT.PMB**2) NFQ=5
22104 C...Define range of flavour loop.
22108 ELSEIF(KF.LT.0) THEN
22116 C...Loop over flavours the photon can branch into.
22117 DO 110 KFL=KFLMN,KFLMX
22119 C...Light flavours: calculate t range and (approximate) s range.
22120 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
22121 TDIFF=LOG(Q2EFF/P2EFF)
22122 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22123 & LOG(P2EFF/ALAMSQ(NFQ)))
22124 IF(NFQ.GT.NFP) THEN
22126 IF(NFQ.EQ.4) Q2DIV=PMC**2
22127 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22128 & LOG(P2EFF/ALAMSQ(NFQ)))
22129 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22130 & LOG(P2EFF/ALAMSQ(NFQ-1)))
22131 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22133 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
22135 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
22136 & LOG(P2EFF/ALAMSQ(4)))
22137 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
22138 & LOG(P2EFF/ALAMSQ(3)))
22139 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
22142 C...u and s quark do not need a separate treatment when d has been done.
22143 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
22145 C...Charm: as above, but only include range above c threshold.
22146 ELSEIF(KFL.EQ.4) THEN
22147 IF(Q2.LE.PMC**2) GOTO 110
22148 P2EFF=MAX(P2EFF,PMC**2)
22149 Q2EFF=MAX(Q2EFF,P2EFF)
22150 TDIFF=LOG(Q2EFF/P2EFF)
22151 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22152 & LOG(P2EFF/ALAMSQ(NFQ)))
22153 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
22155 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22156 & LOG(P2EFF/ALAMSQ(NFQ)))
22157 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22158 & LOG(P2EFF/ALAMSQ(NFQ-1)))
22159 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22162 C...Bottom: as above, but only include range above b threshold.
22163 ELSEIF(KFL.EQ.5) THEN
22164 IF(Q2.LE.PMB**2) GOTO 110
22165 P2EFF=MAX(P2EFF,PMB**2)
22166 Q2EFF=MAX(Q2,P2EFF)
22167 TDIFF=LOG(Q2EFF/P2EFF)
22168 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22169 & LOG(P2EFF/ALAMSQ(NFQ)))
22172 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
22174 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
22175 FAC=AEM2PI*2D0*CHSQ*TDIFF
22177 C...Evaluate parton distributions (normalized to unit momentum sum).
22178 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
22179 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
22180 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
22181 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
22182 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
22183 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
22184 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
22185 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
22186 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
22187 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
22188 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
22189 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
22191 C...Threshold factors for c and b sea.
22192 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22194 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22195 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22196 XCHM=XSEA*(1D0-(SCH/SLL)**3)
22199 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22200 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22201 XBOT=XSEA*(1D0-(SBT/SLL)**3)
22205 C...Add contribution of each valence flavour.
22206 XPGA(0)=XPGA(0)+FAC*XGLU
22207 XPGA(1)=XPGA(1)+FAC*XSEA
22208 XPGA(2)=XPGA(2)+FAC*XSEA
22209 XPGA(3)=XPGA(3)+FAC*XSEA
22210 XPGA(4)=XPGA(4)+FAC*XCHM
22211 XPGA(5)=XPGA(5)+FAC*XBOT
22212 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
22213 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
22216 XPGA(-KFL)=XPGA(KFL)
22217 VXPGA(-KFL)=VXPGA(KFL)
22223 C*********************************************************************
22226 C...Evaluates the Bethe-Heitler cross section for heavy flavour
22228 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22230 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
22231 C...Double precision and integer declarations.
22232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22233 INTEGER PYK,PYCHGE,PYCOMP
22236 DATA AEM2PI/0.0011614D0/
22242 C...Check kinematics limits.
22243 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
22245 BETA2=1D0-4D0*PM2/W2
22246 IF(BETA2.LT.1D-10) RETURN
22250 C...Simple case: P2 = 0.
22251 IF(P2.LT.1D-4) THEN
22252 IF(BETA.LT.0.99D0) THEN
22253 XBL=LOG((1D0+BETA)/(1D0-BETA))
22255 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
22257 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
22258 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
22260 C...Complicated case: P2 > 0, based on approximation of
22261 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
22263 RPQ=1D0-4D0*X**2*P2/Q2
22264 IF(RPQ.GT.1D-10) THEN
22265 RPBE=SQRT(RPQ*BETA2)
22266 IF(RPBE.LT.0.99D0) THEN
22267 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
22268 XBI=2D0*RPBE/(1D0-RPBE**2)
22270 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
22271 XBL=LOG((1D0+RPBE)**2/RPBESN)
22272 XBI=2D0*RPBE/RPBESN
22274 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
22275 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
22276 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
22280 C...Multiply by charge-squared etc. to get parton distribution.
22282 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
22283 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
22288 C*********************************************************************
22291 C...Evaluates the direct contribution, i.e. the C^gamma term,
22292 C...as needed in MSbar parametrizations.
22293 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22295 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
22297 C...Double precision and integer declarations.
22298 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22299 INTEGER PYK,PYCHGE,PYCOMP
22300 C...Local array and data.
22301 DIMENSION XPGA(-6:6)
22302 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
22309 C...Evaluate common x-dependent expression.
22310 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
22311 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
22313 C...d, u, s part by simple charge factor.
22314 XPGA(1)=(1D0/9D0)*CGAM
22315 XPGA(2)=(4D0/9D0)*CGAM
22316 XPGA(3)=(1D0/9D0)*CGAM
22318 C...Also fill for antiquarks.
22326 C*********************************************************************
22329 C...Gives pi+ parton distribution according to two different
22330 C...parametrizations.
22332 SUBROUTINE PYPDPI(X,Q2,XPPI)
22334 C...Double precision and integer declarations.
22335 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22336 INTEGER PYK,PYCHGE,PYCOMP
22338 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22339 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22340 COMMON/PYINT1/MINT(400),VINT(400)
22341 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
22343 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
22345 C...The following data lines are coefficients needed in the
22346 C...Owens pion parton distribution parametrizations, see below.
22347 C...Expansion coefficients for up and down valence quark distributions.
22348 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
22349 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22350 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22351 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
22352 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
22353 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22354 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22355 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
22356 C...Expansion coefficients for gluon distribution.
22357 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
22358 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
22359 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
22360 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
22361 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
22362 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
22363 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
22364 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
22365 C...Expansion coefficients for (up+down+strange) quark sea distribution.
22366 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
22367 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
22368 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
22369 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
22370 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
22371 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
22372 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
22373 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
22374 C...Expansion coefficients for charm quark sea distribution.
22375 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
22376 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
22377 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
22378 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
22379 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
22380 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
22381 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
22382 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
22384 C...Euler's beta function, requires ordinary Gamma function
22385 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
22387 C...Reset output array.
22392 IF(MSTP(53).LE.2) THEN
22393 C...Pion parton distributions from Owens.
22394 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
22396 C...Determine set, Lambda and s expansion variable.
22398 IF(NSET.EQ.1) ALAM=0.2D0
22399 IF(NSET.EQ.2) ALAM=0.4D0
22401 IF(MSTP(57).LE.0) THEN
22404 Q2IN=MIN(2D3,MAX(4D0,Q2))
22405 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
22408 C...Calculate parton distributions.
22411 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
22412 & COW(3,IS,KFL,NSET)*SD**2
22415 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
22417 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
22422 C...Put into output array.
22425 XPPI(2)=XQ(1)+XQ(3)/6D0
22428 XPPI(-1)=XQ(1)+XQ(3)/6D0
22433 C...Leading order pion parton distributions from Gluck, Reya and Vogt.
22434 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
22438 C...Determine s expansion variable and some x expressions.
22440 IF(MSTP(57).LE.0) THEN
22443 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
22444 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
22450 C...Evaluate valence, gluon and sea distributions.
22451 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
22452 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
22453 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
22455 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
22456 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
22458 & (1D0-X)**(0.390D0+1.053D0*SD)
22459 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
22461 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
22463 & XL**(2.538D0-0.763D0*SD)
22464 IF(SD.LE.0.888D0) THEN
22467 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
22469 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
22472 IF(SD.LE.1.351D0) THEN
22475 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
22476 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
22480 C...Put into output array.
22488 XPPI(-KFL)=XPPI(KFL)
22490 XPPI(2)=XPPI(2)+XFVAL
22491 XPPI(-1)=XPPI(-1)+XFVAL
22497 C*********************************************************************
22500 C...Gives proton parton distributions according to a few different
22501 C...parametrizations.
22503 SUBROUTINE PYPDPR(X,Q2,XPPR)
22505 C...Double precision and integer declarations.
22506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22507 INTEGER PYK,PYCHGE,PYCOMP
22509 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22510 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22512 COMMON/PYINT1/MINT(400),VINT(400)
22513 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
22514 C...Arrays and data.
22515 DIMENSION XPPR(-6:6),Q2MIN(6)
22516 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0/
22518 C...Reset output array.
22523 C...Common preliminaries.
22524 NSET=MAX(1,MIN(6,MSTP(51)))
22525 VINT(231)=Q2MIN(NSET)
22526 IF(MSTP(57).EQ.0) THEN
22529 Q2L=MAX(Q2MIN(NSET),Q2)
22532 IF(NSET.GE.1.AND.NSET.LE.3) THEN
22533 C...Interface to the CTEQ 3 parton distributions.
22534 QRT=SQRT(MAX(1D0,Q2L))
22536 C...Loop over flavours.
22539 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
22540 ELSEIF(I.LE.2) THEN
22541 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
22547 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
22548 C...Interface to the GRV 94 distributions.
22550 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22551 ELSEIF(NSET.EQ.5) THEN
22552 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22554 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22557 C...Put into output array.
22559 XPPR(-1)=0.5D0*(UDB+DEL)
22560 XPPR(-2)=0.5D0*(UDB-DEL)
22564 XPPR(1)=DV+XPPR(-1)
22565 XPPR(2)=UV+XPPR(-2)
22575 C*********************************************************************
22578 C...Gives the CTEQ 3 parton distribution function sets in
22579 C...parametrized form, of October 24, 1994.
22580 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
22581 C...J. Qiu, W.K. Tung and H. Weerts.
22583 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
22585 C...Double precision declaration.
22586 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22588 C...Data on Lambda values of fits, minimum Q and quark masses.
22589 DIMENSION ALM(3), QMS(4:6)
22590 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
22591 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
22593 C....Check flavour thresholds. Set up QI for SB.
22596 IF(Q .LE. QMS(IP)) THEN
22605 C...Use "standard lambda" of parametrization program for expansion.
22607 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
22612 C...Expansion for CTEQ3L.
22613 IF(ISET .EQ. 1) THEN
22614 IF(IPRT .EQ. 2) THEN
22615 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
22617 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
22618 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
22619 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
22620 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
22621 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
22622 ELSEIF(IPRT .EQ. 1) THEN
22623 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
22625 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
22626 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
22627 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
22628 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
22629 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
22630 ELSEIF(IPRT .EQ. 0) THEN
22631 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
22633 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
22634 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
22635 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
22636 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
22637 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
22638 ELSEIF(IPRT .EQ. -1) THEN
22639 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
22641 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
22642 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
22643 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
22644 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
22645 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
22646 ELSEIF(IPRT .EQ. -2) THEN
22647 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
22649 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
22650 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
22651 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
22652 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
22653 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
22654 ELSEIF(IPRT .EQ. -3) THEN
22655 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
22657 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
22658 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
22659 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
22660 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
22661 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
22662 ELSEIF(IPRT .EQ. -4) THEN
22663 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
22665 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
22666 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
22667 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
22668 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
22669 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
22670 ELSEIF(IPRT .EQ. -5) THEN
22671 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
22673 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
22674 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
22675 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
22676 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
22677 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
22678 ELSEIF(IPRT .EQ. -6) THEN
22679 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
22681 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
22682 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
22683 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
22684 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
22685 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
22688 C...Expansion for CTEQ3M.
22689 ELSEIF(ISET .EQ. 2) THEN
22690 IF(IPRT .EQ. 2) THEN
22691 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
22693 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
22694 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
22695 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
22696 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
22697 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
22698 ELSEIF(IPRT .EQ. 1) THEN
22699 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
22701 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
22702 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
22703 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
22704 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
22705 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
22706 ELSEIF(IPRT .EQ. 0) THEN
22707 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
22709 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
22710 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
22711 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
22712 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
22713 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
22714 ELSEIF(IPRT .EQ. -1) THEN
22715 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
22717 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
22718 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
22719 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
22720 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
22721 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
22722 ELSEIF(IPRT .EQ. -2) THEN
22723 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
22725 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
22726 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
22727 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
22728 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
22729 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
22730 ELSEIF(IPRT .EQ. -3) THEN
22731 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
22733 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
22734 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
22735 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
22736 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
22737 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
22738 ELSEIF(IPRT .EQ. -4) THEN
22739 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
22741 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
22742 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
22743 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
22744 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
22745 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
22746 ELSEIF(IPRT .EQ. -5) THEN
22747 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
22749 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
22750 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
22751 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
22752 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
22753 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
22754 ELSEIF(IPRT .EQ. -6) THEN
22755 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
22757 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
22758 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
22759 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
22760 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
22761 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
22764 C...Expansion for CTEQ3D.
22765 ELSEIF(ISET .EQ. 3) THEN
22766 IF(IPRT .EQ. 2) THEN
22767 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
22769 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
22770 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
22771 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
22772 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
22773 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
22774 ELSEIF(IPRT .EQ. 1) THEN
22775 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
22777 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
22778 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
22779 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
22780 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
22781 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
22782 ELSEIF(IPRT .EQ. 0) THEN
22783 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
22785 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
22786 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
22787 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
22788 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
22789 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
22790 ELSEIF(IPRT .EQ. -1) THEN
22791 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
22793 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
22794 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
22795 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
22796 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
22797 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
22798 ELSEIF(IPRT .EQ. -2) THEN
22799 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
22801 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
22802 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
22803 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
22804 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
22805 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
22806 ELSEIF(IPRT .EQ. -3) THEN
22807 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
22809 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
22810 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
22811 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
22812 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
22813 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
22814 ELSEIF(IPRT .EQ. -4) THEN
22815 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
22817 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
22818 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
22819 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
22820 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
22821 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
22822 ELSEIF(IPRT .EQ. -5) THEN
22823 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
22825 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
22826 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
22827 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
22828 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
22829 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
22830 ELSEIF(IPRT .EQ. -6) THEN
22831 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
22833 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
22834 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
22835 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
22836 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
22837 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
22841 C...Calculation of x * f(x, Q).
22842 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
22843 & *(LOG(1D0+1D0/X))**A5 )
22848 C*********************************************************************
22851 C...Gives the GRV 94 L (leading order) parton distribution function set
22852 C...in parametrized form.
22853 C...Authors: M. Glueck, E. Reya and A. Vogt.
22855 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22857 C...Double precision declaration.
22858 IMPLICIT DOUBLE PRECISION (A - Z)
22860 C...Common expressions.
22862 LAM2 = 0.2322D0 * 0.2322D0
22863 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
22869 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
22870 AKU = 0.590D0 - 0.024D0 * S
22871 BKU = 0.131D0 + 0.063D0 * S
22872 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
22873 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
22874 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
22875 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
22876 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
22879 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
22881 BKD = 0.486D0 + 0.062D0 * S
22882 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
22883 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
22884 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
22885 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
22886 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
22889 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
22890 AKE = 0.409D0 - 0.005D0 * S
22891 BKE = 0.799D0 + 0.071D0 * S
22892 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
22893 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
22895 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
22896 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
22901 AKX = 0.410D0 - 0.232D0 * S
22902 BKX = 0.534D0 - 0.457D0 * S
22903 AGX = 0.890D0 - 0.140D0 * S
22905 CX = 0.320D0 + 0.683D0 * S
22906 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
22907 EX = 4.119D0 + 1.713D0 * S
22908 ESX = 0.682D0 + 2.978D0 * S
22909 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
22916 AKS = 1.798D0 - 0.596D0 * S
22917 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
22918 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
22919 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
22920 EST = 3.981D0 + 1.638D0 * S
22922 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
22930 BC = 4.24D0 - 0.804D0 * S
22931 DCT = 3.46D0 - 1.076D0 * S
22932 ECT = 4.61D0 + 1.49D0 * S
22933 ESC = 2.555D0 + 1.961D0 * S
22934 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
22943 DBT = 2.929D0 + 1.396D0 * S
22944 EBT = 4.71D0 + 1.514D0 * S
22945 ESB = 4.02D0 + 1.239D0 * S
22946 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
22951 AKG = 1.742D0 - 0.930D0 * S
22952 BKG = - 0.399D0 * S2
22953 AG = 7.486D0 - 2.185D0 * S
22954 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
22955 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
22956 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
22957 EG = 0.807D0 + 2.005D0 * S
22958 ESG = 3.841D0 + 0.316D0 * S
22959 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
22965 C*********************************************************************
22968 C...Gives the GRV 94 M (MSbar) parton distribution function set
22969 C...in parametrized form.
22970 C...Authors: M. Glueck, E. Reya and A. Vogt.
22972 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22974 C...Double precision declaration.
22975 IMPLICIT DOUBLE PRECISION (A - Z)
22977 C...Common expressions.
22979 LAM2 = 0.248D0 * 0.248D0
22980 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
22986 NU = 1.304D0 + 0.863D0 * S
22987 AKU = 0.558D0 - 0.020D0 * S
22989 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
22990 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
22991 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
22992 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
22993 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
22996 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
22997 AKD = 0.270D0 - 0.019D0 * S
22999 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
23000 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
23001 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
23002 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
23003 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23006 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
23007 AKE = 0.409D0 - 0.007D0 * S
23008 BKE = 0.782D0 + 0.082D0 * S
23009 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
23010 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
23012 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
23013 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23021 BGX = 3.210D0 - 1.866D0 * S
23023 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
23024 EX = 3.077D0 + 1.446D0 * S
23025 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
23026 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23033 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
23034 AS = -4.329D0 + 1.131D0 * S
23035 BS = 9.568D0 - 1.744D0 * S
23036 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
23037 EST = 3.031D0 + 1.639D0 * S
23038 ESS = 5.837D0 + 0.815D0 * S
23039 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23045 AKC = -0.625D0 - 0.523D0 * S
23047 BC = 1.896D0 + 1.616D0 * S
23048 DCT = 4.12D0 + 0.683D0 * S
23049 ECT = 4.36D0 + 1.328D0 * S
23050 ESC = 0.677D0 + 0.679D0 * S
23051 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23057 AKB = - 0.193D0 * S
23060 DBT = 3.447D0 + 0.927D0 * S
23061 EBT = 4.68D0 + 1.259D0 * S
23062 ESB = 1.892D0 + 2.199D0 * S
23063 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23068 AKG = 1.724D0 + 0.157D0 * S
23069 BKG = 0.800D0 + 1.016D0 * S
23070 AG = 7.517D0 - 2.547D0 * S
23071 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
23072 CG = 4.039D0 + 1.491D0 * S
23073 DG = 3.404D0 + 0.830D0 * S
23074 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
23075 ESG = 3.256D0 - 0.436D0 * S
23076 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23081 C*********************************************************************
23084 C...Gives the GRV 94 D (DIS) parton distribution function set
23085 C...in parametrized form.
23086 C...Authors: M. Glueck, E. Reya and A. Vogt.
23088 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
23090 C...Double precision declaration.
23091 IMPLICIT DOUBLE PRECISION (A - Z)
23093 C...Common expressions.
23095 LAM2 = 0.248D0 * 0.248D0
23096 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
23102 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
23103 AKU = 0.563D0 - 0.025D0 * S
23104 BKU = 0.054D0 + 0.154D0 * S
23105 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
23106 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
23107 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
23108 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
23109 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
23112 ND = 0.156D0 - 0.017D0 * S
23113 AKD = 0.299D0 - 0.022D0 * S
23114 BKD = 0.259D0 - 0.015D0 * S
23115 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
23116 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
23117 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
23118 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
23119 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23122 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
23123 AKE = 0.419D0 - 0.013D0 * S
23124 BKE = 1.064D0 - 0.038D0 * S
23125 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
23126 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
23127 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
23128 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
23129 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23134 AKX = 0.326D0 + 0.150D0 * S
23135 BKX = 0.956D0 + 0.405D0 * S
23137 BGX = 3.794D0 - 2.359D0 * DS
23139 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
23140 EX = 3.049D0 + 1.597D0 * S
23141 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
23142 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23149 AKS = 1.415D0 - 0.641D0 * DS
23150 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
23151 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
23152 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
23153 EST = 4.546D0 + 0.372D0 * S2
23154 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
23155 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23161 AKC = -0.625D0 - 0.523D0 * S
23163 BC = 1.896D0 + 1.616D0 * S
23164 DCT = 4.12D0 + 0.683D0 * S
23165 ECT = 4.36D0 + 1.328D0 * S
23166 ESC = 0.677D0 + 0.679D0 * S
23167 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23173 AKB = - 0.193D0 * S
23176 DBT = 3.447D0 + 0.927D0 * S
23177 EBT = 4.68D0 + 1.259D0 * S
23178 ESB = 1.892D0 + 2.199D0 * S
23179 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23185 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
23186 AG = 25.09D0 - 7.935D0 * S
23187 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
23188 CG = 590.3D0 - 173.8D0 * S
23189 DG = 5.196D0 + 1.857D0 * S
23190 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
23191 ESG = 3.232D0 - 0.542D0 * S
23192 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23197 C*********************************************************************
23200 C...Auxiliary for the GRV 94 parton distribution functions
23201 C...for u and d valence and d-u sea.
23202 C...Authors: M. Glueck, E. Reya and A. Vogt.
23204 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
23206 C...Double precision declaration.
23207 IMPLICIT DOUBLE PRECISION (A - Z)
23211 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
23217 C*********************************************************************
23220 C...Auxiliary for the GRV 94 parton distribution functions
23221 C...for d+u sea and gluon.
23222 C...Authors: M. Glueck, E. Reya and A. Vogt.
23224 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
23226 C...Double precision declaration.
23227 IMPLICIT DOUBLE PRECISION (A - Z)
23231 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
23232 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
23237 C*********************************************************************
23240 C...Auxiliary for the GRV 94 parton distribution functions
23241 C...for s, c and b sea.
23242 C...Authors: M. Glueck, E. Reya and A. Vogt.
23244 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
23246 C...Double precision declaration.
23247 IMPLICIT DOUBLE PRECISION (A - Z)
23255 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
23256 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
23262 C*********************************************************************
23265 C...Gives threshold attractive/repulsive factor for heavy flavour
23268 FUNCTION PYHFTH(SH,SQM,FRATT)
23270 C...Double precision and integer declarations.
23271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23272 INTEGER PYK,PYCHGE,PYCOMP
23274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23275 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23276 COMMON/PYINT1/MINT(400),VINT(400)
23277 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23279 C...Value for alpha_strong.
23280 IF(MSTP(35).LE.1) THEN
23285 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
23291 C...Evaluate attractive and repulsive factors.
23292 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23293 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
23294 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23295 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
23296 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
23302 C*********************************************************************
23305 C...Splits a hadron remnant into two (partons or hadron + parton)
23306 C...in case it is more complicated than just a quark or a diquark.
23308 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
23310 C...Double precision and integer declarations.
23311 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23312 INTEGER PYK,PYCHGE,PYCOMP
23314 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23315 COMMON/PYINT1/MINT(400),VINT(400)
23316 SAVE /PYPARS/,/PYINT1/
23320 C...Preliminaries. Parton composition.
23323 KFL(1)=MOD(KFA/1000,10)
23324 KFL(2)=MOD(KFA/100,10)
23325 KFL(3)=MOD(KFA/10,10)
23326 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
23327 KFL(2)=INT(1.5D0+PYR(0))
23328 IF(MINT(105).EQ.333) KFL(2)=3
23329 IF(MINT(105).EQ.443) KFL(2)=4
23331 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
23334 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
23338 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
23345 C...Subdivide lepton.
23346 IF(KFA.GE.11.AND.KFA.LE.18) THEN
23347 IF(KFLR.EQ.KFA) THEN
23349 ELSEIF(KFLR.EQ.22) THEN
23351 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
23353 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
23355 ELSEIF(KFLR.EQ.21) THEN
23363 C...Subdivide photon.
23364 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
23365 IF(KFLR.NE.21) THEN
23370 IF(RAGR.GT.0.125D0) KFLSP=2
23371 IF(RAGR.GT.0.625D0) KFLSP=3
23372 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
23376 C...Subdivide Reggeon or Pomeron.
23377 ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
23378 IF(KFLIN.EQ.21) THEN
23384 C...Subdivide meson.
23385 ELSEIF(KFL(1).EQ.0) THEN
23386 KFL(2)=KFL(2)*(-1)**KFL(2)
23387 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
23388 IF(KFLR.EQ.KFL(2)) THEN
23390 ELSEIF(KFLR.EQ.KFL(3)) THEN
23392 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
23395 ELSEIF(KFLR.EQ.21) THEN
23398 ELSEIF(KFLR*KFL(2).GT.0) THEN
23399 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
23402 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
23406 C...Subdivide baryon.
23410 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
23413 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
23416 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
23417 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
23420 IAGR=1.00001D0+2.99998D0*PYR(0)
23423 IF(IAGR.EQ.1) ID1=2
23424 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
23427 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
23428 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
23429 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
23430 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
23431 ELSEIF(MOD(KFA,10).EQ.2) THEN
23432 IF(IAGR.EQ.1) KSP=1
23433 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
23435 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
23436 IF(KFLR.EQ.21) THEN
23438 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
23439 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
23440 ELSEIF(NAGR.EQ.0) THEN
23441 CALL PYKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
23446 C...Add on correct sign for result.
23453 C*********************************************************************
23456 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
23457 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
23458 C...(Dover, 1965) 6.1.36.
23462 C...Double precision and integer declarations.
23463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23464 INTEGER PYK,PYCHGE,PYCOMP
23465 C...Local array and data.
23467 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
23468 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
23477 PYGAMM=PYGAMM+B(I)*DXP
23483 PYGAMM=(X-IX)*PYGAMM
23490 C***********************************************************************
23493 C...Calculates real and imaginary parts of the auxiliary functions W1
23494 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
23495 C...der Bij, Nucl. Phys. B297 (1988) 221.
23497 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
23499 C...Double precision and integer declarations.
23500 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23501 INTEGER PYK,PYCHGE,PYCOMP
23503 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23506 ASINH(X)=LOG(X+SQRT(X**2+1D0))
23507 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
23509 IF(EPS.LT.0D0) THEN
23510 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
23511 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
23513 ELSEIF(EPS.LT.1D0) THEN
23514 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
23515 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
23516 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
23517 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
23519 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
23520 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
23527 C***********************************************************************
23530 C...Calculates real and imaginary parts of the auxiliary function I3;
23531 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
23532 C...Nucl. Phys. B297 (1988) 221.
23534 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
23536 C...Double precision and integer declarations.
23537 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23538 INTEGER PYK,PYCHGE,PYCOMP
23540 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23543 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
23544 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
23546 IF(EPS.LT.0D0) THEN
23547 IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23548 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23549 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23550 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
23551 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
23552 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
23553 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
23554 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
23556 ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23557 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23558 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23559 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
23560 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
23561 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
23562 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
23563 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
23564 ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23565 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23566 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23567 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
23568 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
23569 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
23570 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
23571 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
23573 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23574 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
23575 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
23576 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
23577 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
23580 ELSEIF(EPS.LT.1D0) THEN
23581 IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23582 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23583 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23584 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
23585 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
23586 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23587 & (0.25D0*(RAT+1D0)*EPS))
23588 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23589 & (0.25D0*(RAT+1D0)*EPS))
23590 ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23591 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23592 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23593 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
23594 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
23595 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
23596 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23597 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23598 ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23599 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23600 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23601 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
23602 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
23603 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
23604 & (1D0+0.25D0*RAT*EPS-GA))
23605 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
23606 & (1D0+0.25D0*RAT*EPS-GA))
23608 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23609 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
23610 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
23611 & LOG((GA+BE-1D0)/(BE-GA))
23612 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
23615 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
23616 RCTHE=RSQ*(1D0-2D0*BE/EPS)
23617 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
23618 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
23619 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
23621 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
23622 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
23623 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
23624 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
23625 & (PHI-THE)*(PHI+THE-PARU(1))
23626 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
23627 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
23630 Y3RE=2D0/(2D0*BE-1D0)*F3RE
23631 Y3IM=2D0/(2D0*BE-1D0)*F3IM
23636 C***********************************************************************
23639 C...Calculates real and imaginary part of Spence function; see
23640 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
23642 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
23644 C...Double precision and integer declarations.
23645 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23646 INTEGER PYK,PYCHGE,PYCOMP
23648 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23650 C...Local array and data.
23653 &1.000000D+00, -5.000000D-01, 1.666667D-01,
23654 &0.000000D+00, -3.333333D-02, 0.000000D+00,
23655 &2.380952D-02, 0.000000D+00, -3.333333D-02,
23656 &0.000000D+00, 7.575757D-02, 0.000000D+00,
23657 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
23661 IF(ABS(1D0-XRE).LT.1.D-6.AND.ABS(XIM).LT.1.D-6) THEN
23662 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
23663 IF(IREIM.EQ.2) PYSPEN=0D0
23667 XMOD=SQRT(XRE**2+XIM**2)
23668 IF(XMOD.LT.1.D-6) THEN
23669 IF(IREIM.EQ.1) PYSPEN=0D0
23670 IF(IREIM.EQ.2) PYSPEN=0D0
23674 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23678 IF(XMOD.GT.1D0) THEN
23680 ALGXIM=XARG-SIGN(PARU(1),XARG)
23681 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
23682 SP0IM=-ALGXRE*ALGXIM
23689 IF(XRE.GT.0.5D0) THEN
23694 XMOD=SQRT(XRE**2+XIM**2)
23695 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23698 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
23699 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
23705 XMOD=SQRT(XRE**2+XIM**2)
23706 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23715 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
23716 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
23717 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
23720 SPRE=SPRE+B(I)*TERMRE
23721 SPIM=SPIM+B(I)*TERMIM
23724 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
23725 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
23730 C***********************************************************************
23733 C...Calculates the matrix element for the processes
23734 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
23735 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
23736 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
23738 SUBROUTINE PYQQBH(WTQQBH)
23740 C...Double precision and integer declarations.
23741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23742 INTEGER PYK,PYCHGE,PYCOMP
23744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23746 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23747 COMMON/PYINT1/MINT(400),VINT(400)
23748 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23749 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
23750 C...Local arrays and function.
23751 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
23752 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
23755 C...Mass parameters.
23758 SHPR=SQRT(VINT(26))*VINT(1)
23759 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
23760 PH=SQRT(VINT(21))*VINT(1)
23764 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
23766 PT=SQRT(MAX(0D0,VINT(197+5*I)))
23767 PP(I,1)=PT*COS(VINT(198+5*I))
23768 PP(I,2)=PT*SIN(VINT(198+5*I))
23770 PP(3,1)=-PP(1,1)-PP(2,1)
23771 PP(3,2)=-PP(1,2)-PP(2,2)
23772 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
23773 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
23774 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
23776 PP(3,3)=PMT3*SINH(VINT(211))
23777 PP(3,4)=PMT3*COSH(VINT(211))
23778 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
23779 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
23780 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
23781 PP(2,3)=-PP(1,3)-PP(3,3)
23782 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
23783 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
23785 C...Set up incoming kinematics and derived momentum combinations.
23789 PP(I,3)=-0.5D0*SHPR*(-1)**I
23790 PP(I,4)=-0.5D0*SHPR
23793 PP(6,J)=PP(1,J)+PP(2,J)
23794 PP(7,J)=PP(1,J)+PP(3,J)
23795 PP(8,J)=PP(1,J)+PP(4,J)
23796 PP(9,J)=PP(1,J)+PP(5,J)
23797 PP(10,J)=-PP(2,J)-PP(3,J)
23798 PP(11,J)=-PP(2,J)-PP(4,J)
23799 PP(12,J)=-PP(2,J)-PP(5,J)
23800 PP(13,J)=-PP(4,J)-PP(5,J)
23803 C...Derived kinematics invariants.
23832 C...Define colour coefficients for g + g -> Q + Qbar + H.
23833 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
23837 CLR(I+3,J+3)=16D0/3D0
23838 CLR(I,J+3)=-2D0/3D0
23839 CLR(I+3,J)=-2D0/3D0
23852 CLR(6+K1,6+K2)=12D0
23856 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
23857 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
23858 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
23859 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
23860 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
23861 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
23862 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
23864 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
23865 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
23866 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
23867 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
23868 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
23869 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
23870 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
23871 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
23872 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
23873 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
23874 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
23875 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
23876 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
23877 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
23878 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
23879 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
23880 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
23881 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
23883 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
23884 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
23885 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
23886 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
23887 & +X4*X9*X5+X4*X5**2)
23888 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
23889 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
23890 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
23891 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
23892 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
23893 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
23894 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
23895 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
23896 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
23897 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
23898 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
23899 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
23900 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
23901 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
23902 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
23903 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
23904 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
23905 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
23906 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
23907 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
23909 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
23910 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
23911 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
23912 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
23913 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
23914 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
23915 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
23917 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
23918 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
23919 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
23920 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
23921 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
23922 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
23924 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
23925 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
23926 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
23927 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
23928 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
23929 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
23930 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
23932 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
23933 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
23934 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
23935 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
23936 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
23937 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
23938 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
23939 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
23940 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
23941 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
23942 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
23943 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
23944 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
23945 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
23946 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
23947 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
23948 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
23949 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
23950 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
23951 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
23952 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
23953 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
23954 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
23955 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
23956 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
23957 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
23958 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
23959 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
23960 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
23961 & +X3*X8*X5+X3*X5**2)
23962 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
23963 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
23964 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
23965 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
23966 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
23967 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
23968 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
23970 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
23971 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
23972 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
23973 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
23974 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
23975 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
23976 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
23977 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
23978 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
23979 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
23980 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
23981 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
23982 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
23983 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
23984 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
23985 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
23986 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
23987 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
23988 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
23989 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
23990 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
23991 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
23992 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
23993 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
23994 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
23995 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
23997 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
23998 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
23999 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
24000 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
24001 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
24002 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
24003 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
24004 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
24005 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
24006 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
24007 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
24008 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
24009 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
24010 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
24011 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
24012 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
24013 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
24014 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
24015 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
24016 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
24017 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
24018 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
24019 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
24020 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
24021 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
24022 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
24024 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24025 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24026 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
24027 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
24028 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
24029 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
24030 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
24031 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
24032 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
24033 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
24034 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
24035 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24036 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24037 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
24038 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
24039 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
24040 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
24041 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
24042 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
24043 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
24044 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
24045 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
24046 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
24047 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
24048 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
24049 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
24050 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
24051 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
24052 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
24053 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
24054 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
24055 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
24056 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
24057 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
24058 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
24059 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
24060 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
24061 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
24062 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
24063 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
24064 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
24065 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
24066 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
24067 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
24069 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
24070 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
24071 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
24072 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
24073 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
24074 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
24075 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
24076 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
24077 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
24078 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
24079 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
24081 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24082 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
24083 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
24084 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24085 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
24086 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
24088 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24089 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
24090 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
24092 FM(9,10)=0.5D0*(FMXX+FM(9,10))
24093 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24094 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
24095 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
24097 C...Repackage matrix elements.
24103 RM(7,7)=FM(7,7)-2D0*FM(9,9)
24104 RM(7,8)=FM(7,8)-2D0*FM(9,10)
24105 RM(8,8)=FM(8,8)-2D0*FM(10,10)
24107 C...Produce final result: matrix elements * colours * propagators.
24112 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
24115 WTQQBH=-WTQQBH/256D0
24118 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
24119 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
24120 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
24122 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
24123 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
24124 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
24126 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
24127 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
24130 C...Produce final result: matrix elements * propagators.
24132 A12=A12/(DX(7)*DX(8))
24134 WTQQBH=-(A11+A22+2D0*A12)/8D0
24140 C*********************************************************************
24143 C...Initializes supersymmetry: finds sparticle masses and
24144 C...branching ratios and stores this information.
24145 C...AUTHOR: STEPHEN MRENNA
24149 C...Double precision and integer declarations.
24150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24151 INTEGER PYK,PYCHGE,PYCOMP
24152 C...Parameter statement to help give large particle numbers.
24153 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24156 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24157 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
24158 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24159 COMMON/PYINT4/MWID(500),WIDS(500,5)
24160 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24161 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24163 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
24166 C...Local variables.
24168 DOUBLE PRECISION ALFA,BETA
24169 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
24170 DOUBLE PRECISION PYALEM
24171 INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
24172 INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
24173 DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
24174 DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
24175 DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
24176 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
24177 DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
24178 DOUBLE PRECISION DELM,XMDIF,BRLIM
24179 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
24180 DOUBLE PRECISION ARG,SGNMU,R,GAM
24181 INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
24182 INTEGER IMSSM,KFHIGG
24186 &1000001,2000001,1000002,2000002,1000003,2000003,
24187 &1000004,2000004,1000005,2000005,1000006,2000006,
24188 &1000011,2000011,1000012,2000012,1000013,2000013,
24189 &1000014,2000014,1000015,2000015,1000016,2000016,
24190 &1000021,1000022,1000023,1000025,1000035,1000024,
24191 &1000037,1000039, 25, 35, 36, 37/
24193 C...Do nothing if SUSY not requested.
24195 IF(IMSSM.EQ.0) RETURN
24197 C...First part of routine: set masses and couplings.
24199 C...Reset mixing values in sfermion sector to pure left/right.
24207 C...Common couplings.
24212 COS2B=COS(2D0*BETA)
24218 C...Define sparticle masses for a general MSSM simulation.
24219 IF(IMSSM.EQ.1) THEN
24220 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
24222 KC=PYCOMP(KSUSY1+I)
24223 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
24224 KC=PYCOMP(KSUSY2+I)
24225 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
24226 KC=PYCOMP(KSUSY1+I+1)
24227 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
24228 KC=PYCOMP(KSUSY2+I+1)
24229 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
24231 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
24232 IF(XARG.LT.0D0) THEN
24233 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24234 & ' FROM THE SUM RULE. '
24235 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24241 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
24242 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
24243 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24244 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24246 IF(IMSS(8).EQ.1) THEN
24251 C...Alternatively derive masses from SUGRA relations.
24252 ELSEIF(IMSSM.EQ.2) THEN
24256 C...Add in extra D-term contributions.
24257 IF(IMSS(7).EQ.1) THEN
24262 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24263 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
24264 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
24265 WRITE(MSTU(11),*) 'C DX = ',DX
24266 WRITE(MSTU(11),*) 'C DY = ',DY
24267 WRITE(MSTU(11),*) 'C DS = ',DS
24268 WRITE(MSTU(11),*) 'C '
24269 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
24270 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
24271 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24272 DQ2=DY/6D0-DX/3D0-DS/3D0
24273 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
24274 DD2=DY/3D0+DX-2D0*DS/3D0
24275 DL2=-DY/2D0+DX-2D0*DS/3D0
24276 DE2=DY-DX/3D0-DS/3D0
24277 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
24278 DHD2=-DY/2D0-2D0*DX/3D0+DS
24279 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
24281 DMA2 = 2D0*DMU2+DHU2+DHD2
24283 KC=PYCOMP(KSUSY1+I)
24284 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24285 KC=PYCOMP(KSUSY2+I)
24286 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
24287 KC=PYCOMP(KSUSY1+I+1)
24288 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24289 KC=PYCOMP(KSUSY2+I+1)
24290 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
24293 KC=PYCOMP(KSUSY1+I)
24294 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24295 KC=PYCOMP(KSUSY2+I)
24296 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
24297 KC=PYCOMP(KSUSY1+I+1)
24298 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24300 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
24301 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
24304 SGNMU=SIGN(1D0,RMSS(4))
24305 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
24306 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
24307 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
24308 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
24309 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
24310 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
24311 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
24312 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
24313 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
24314 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
24315 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
24316 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
24317 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
24320 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
24321 RMSS(6)=SQRT(RMSS(6)**2+DL2)
24322 RMSS(7)=SQRT(RMSS(7)**2+DE2)
24323 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
24324 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
24325 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
24326 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
24327 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
24330 C...Fix the third generation sfermions.
24332 XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
24333 IF(XARG.LT.0D0) THEN
24334 WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
24335 & ' THE SUM RULE. '
24336 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24339 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
24342 C...Fix the neutralino--chargino--gluino sector.
24345 C...Fix the Higgs sector.
24348 C...Choose the Gunion-Haber convention.
24352 C...Print information on mass parameters.
24353 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
24354 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24355 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
24356 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
24357 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
24358 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
24359 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
24360 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
24361 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
24362 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
24363 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24365 IF(IMSS(20).EQ.1) THEN
24366 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24367 WRITE(MSTU(11),*) ' DEBUG MODE '
24368 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
24369 & UMIX(2,1),UMIX(2,2)
24370 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
24371 & VMIX(2,1),VMIX(2,2)
24372 WRITE(MSTU(11),*) ' ZMIX = ',ZMIX
24373 WRITE(MSTU(11),*) ' ALFA = ',ALFA
24374 WRITE(MSTU(11),*) ' BETA = ',BETA
24375 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
24376 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
24377 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24380 C...Set up the Higgs couplings - needed here since initialization
24381 C...in PYINRE did not yet occur when PYWIDT is called below.
24388 C...tanb (used for H+)
24392 C...Coupling to d-type quarks
24393 PARU(161)=SINA/COSB
24394 C...Coupling to u-type quarks
24395 PARU(162)=-COSA/SINB
24396 C...Coupling to leptons
24397 PARU(163)=PARU(161)
24399 PARU(164)=SIN(BE-AL)
24401 PARU(165)=PARU(164)
24403 PARU(168)=-SIN(BE-AL)-COS(2D0*BE)*SIN(BE+AL)/2D0/(1D0-XW)
24406 C...Coupling to d-type quarks
24407 PARU(171)=-COSA/COSB
24408 C...Coupling to u-type quarks
24409 PARU(172)=-SINA/SINB
24410 C...Coupling to leptons
24411 PARU(173)=PARU(171)
24413 PARU(174)=COS(BE-AL)
24415 PARU(175)=PARU(174)
24417 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
24419 PARU(177)=COS(2D0*BE)*COS(BE+AL)
24421 PARU(178)=-COS(BE-AL)+COS(2D0*BE)*COS(BE+AL)/2D0/(1D0-XW)
24424 C...Coupling to d-type quarks
24426 C...Coupling to u-type quarks
24427 PARU(182)=1D0/PARU(181)
24428 C...Coupling to leptons
24429 PARU(183)=PARU(181)
24432 C...Coupling to Z h
24433 PARU(186)=COS(BE-AL)
24434 C...Coupling to Z H
24435 PARU(187)=SIN(BE-AL)
24441 C...Coupling to W h
24442 PARU(195)=COS(BE-AL)
24444 C...Tell that all Higgs couplings have been set.
24447 C...Second part of routine: set decay modes and branching ratios.
24449 C...Allow chi10 -> gravitino + gamma or not.
24450 KC=PYCOMP(KSUSY1+39)
24451 IF( IMSS(11) .NE. 0 ) THEN
24452 PMAS(KC,1)=RMSS(21)/1000000000D0
24453 PMAS(KC,2)=0.0001D0
24455 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
24461 C...Loop over sparticle and Higgs species.
24462 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
24468 C...Sfermion decays.
24470 C...First check to see if sneutrino is lighter than chi10.
24471 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
24472 & PMAS(KC,1).LT.PMCHI1) THEN
24474 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
24478 ELSEIF(I.EQ.25) THEN
24479 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
24481 C...Neutralino decays.
24482 ELSEIF(I.GE.26.AND.I.LE.29) THEN
24483 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
24484 C...chi10 stable or chi10 -> gravitino + gamma.
24485 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
24491 C...Chargino decays.
24492 ELSEIF(I.GE.30.AND.I.LE.31) THEN
24493 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
24495 C...Gravitino is stable.
24496 ELSEIF(I.EQ.32) THEN
24501 ELSEIF(I.GE.33.AND.I.LE.36) THEN
24502 C...Calculate decays to non-SUSY particles.
24503 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
24508 DO 170 I1=1,MDCY(KC,3)
24510 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
24511 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 170
24513 XLAM(0)=XLAM(0)+XLAM(I1)
24515 IDLAM(I1,J1)=KFDP(K1,J1)
24519 C...Add the decays to SUSY particles.
24520 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
24523 C...Set stable particles.
24531 C...Store branching ratios in the standard tables.
24533 IDC=MDCY(KC,2)+MDCY(KC,3)-1
24538 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
24539 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
24540 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
24541 BRAT(IDC)=XLAM(IL)/XLAM(0)
24543 IF(MDME(IDC,1).GE.1) THEN
24544 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
24545 & PMAS(PYCOMP(KFDP(IDC,2)),1)
24546 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
24547 & PMAS(PYCOMP(KFDP(IDC,3)),1)
24550 IF(XMDIF.GE.0D0) THEN
24551 DELM=MIN(DELM,XMDIF)
24553 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
24554 WRITE(MSTU(11),*) ' KF = ',KF
24555 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
24559 ELSEIF(IDC.EQ.IDCSV) THEN
24560 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
24561 & 'channel not recognized:'
24562 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
24569 C...Store width, cutoff and lifetime.
24571 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
24572 PMAS(KC,3)=PMAS(KC,2)*10D0
24574 PMAS(KC,3)=0.95D0*DELM
24576 IF(PMAS(KC,2).NE.0D0) THEN
24577 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
24585 C*********************************************************************
24588 C...Uses approximate analytical formulae to determine the full set of
24589 C...MSSM parameters from SUGRA input.
24590 C...See M. Drees and S.P. Martin, hep-ph/9504124
24594 C...Double precision and integer declarations.
24595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24596 INTEGER PYK,PYCHGE,PYCOMP
24597 C...Parameter statement to help give large particle numbers.
24598 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24600 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24601 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24602 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24603 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
24621 DTERM=XMZ2*COS(2D0*BETA)
24622 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
24623 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
24626 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
24627 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
24628 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
24629 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
24631 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
24632 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
24633 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
24634 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
24636 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
24637 IF(XARG.LT.0D0) THEN
24638 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24639 & ' FROM THE SUM RULE. '
24640 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24646 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
24647 PMAS(PYCOMP(KSUSY2+I),1)=XMER
24648 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24649 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24654 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
24655 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
24657 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
24658 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
24659 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
24660 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
24663 XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
24664 XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
24665 XMU=SIGN(SQRT(XMU2),RMSS(4))
24667 RMSS(19)=SQRT(XMA2)
24668 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
24669 IF(ARG.GT.0D0) THEN
24672 WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
24675 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
24676 IF(ARG.GT.0D0) THEN
24679 WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
24682 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
24683 IF(ARG.GT.0D0) THEN
24686 RMSS(10)=-SQRT(-ARG)
24688 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
24689 IF(ARG.GT.0D0) THEN
24692 RMSS(12)=-SQRT(-ARG)
24694 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
24695 IF(ARG.GT.0D0) THEN
24698 RMSS(11)=-SQRT(-ARG)
24704 C*********************************************************************
24707 C...Determines the running mass of quarks.
24709 FUNCTION PYRNMQ(ID,DTERM)
24711 C...Double precision and integer declarations.
24712 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24713 INTEGER PYK,PYCHGE,PYCOMP
24715 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24718 C...Local variables.
24719 DOUBLE PRECISION PI,R
24720 DOUBLE PRECISION TOL
24721 DOUBLE PRECISION CI(3)
24724 DATA PI,R/3.141592654D0,.61803399D0/
24725 DATA CI/0.47D0,0.07D0,0.02D0/
24729 AG=(0.71D0)**2/4D0/PI
24736 AS=PYALPS(XM02+6D0*XMG2)
24737 CG=8D0/9D0*((AS/AG)**2-1D0)
24738 BX=XM02+(CA+CG)*XMG2+DTERM
24739 AX=MIN(50D0**2,0.5D0*BX)
24740 CX=MAX(2000D0**2,2D0*BX)
24744 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24752 CG=8D0/9D0*((AS1/AG)**2-1D0)
24753 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24755 CG=8D0/9D0*((AS2/AG)**2-1D0)
24756 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24757 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24764 CG=8D0/9D0*((AS2/AG)**2-1D0)
24765 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24772 CG=8D0/9D0*((AS1/AG)**2-1D0)
24773 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24788 C*********************************************************************
24791 C...Determines the running mass of the top quark.
24793 FUNCTION PYRNMT(XMT)
24795 C...Double precision and integer declarations.
24796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24797 INTEGER PYK,PYCHGE,PYCOMP
24799 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24802 C...Local variables.
24803 DOUBLE PRECISION XMT
24804 DOUBLE PRECISION PI,R
24805 DOUBLE PRECISION TOL
24808 DATA PI,R/3.141592654D0,0.61803399D0/
24813 AX=MIN(50D0,BX*0.5D0)
24814 CX=MAX(300D0,2D0*BX)
24818 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24825 AS1=PYALPS(X1**2)/PI
24826 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24827 AS2=PYALPS(X2**2)/PI
24828 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24829 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24835 AS2=PYALPS(X2**2)/PI
24836 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24842 AS1=PYALPS(X1**2)/PI
24843 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24858 C*********************************************************************
24861 C...Calculates the mass eigenstates of the third generation sfermions.
24862 C...Created: 5-31-96
24866 C...Double precision and integer declarations.
24867 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24868 INTEGER PYK,PYCHGE,PYCOMP
24869 C...Parameter statement to help give large particle numbers.
24870 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24874 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24875 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24877 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
24879 C...Local variables.
24880 DOUBLE PRECISION BETA
24881 DOUBLE PRECISION PYRNMT
24882 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
24883 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
24884 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
24885 DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
24886 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
24887 INTEGER IF,I,J,II,JJ,IT,L
24901 COS2B=COS(2D0*BETA)
24903 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
24913 XMQL2=CTT2*XM12+STT2*XM22
24914 XMQR2=STT2*XM12+CTT2*XM22
24916 XMF2=PYRNMT(XMFR)**2
24917 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
24918 ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
24919 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
24920 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
24922 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
24925 C......SUBTRACT OUT D-TERM AND FERMION MASS
24926 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
24927 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
24928 IF(XMQL2.GE.0D0) THEN
24929 RMSS(10)=SQRT(XMQL2)
24931 RMSS(10)=-SQRT(-XMQL2)
24933 IF(XMQR2.GE.0D0) THEN
24934 RMSS(12)=SQRT(XMQR2)
24936 RMSS(12)=-SQRT(-XMQR2)
24938 C SAME FOR SBOTTOM SQUARK
24942 STT=MAX(SQRT(STT2),1D-6)
24946 XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
24947 IF(ABS(CTT).EQ.1D0) THEN
24951 ELSEIF(CTT.EQ.0D0) THEN
24955 XM22=(XMQL2-CTT2*XM12)/STT2
24956 XMQR2=STT2*XM12+CTT2*XM22
24958 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
24959 ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
24960 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
24961 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
24963 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
24966 C......SUBTRACT OUT D-TERM AND FERMION MASS
24967 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
24968 IF(XMQR2.GE.0D0) THEN
24969 RMSS(11)=SQRT(XMQR2)
24971 RMSS(11)=-SQRT(-XMQR2)
24977 IF(AMQL.LT.0D0) THEN
24985 IF(L.EQ.2) XMF=PYRNMT(XMF)
24989 IF(AMQR.LT.0D0) THEN
24994 AM2(1,1)=XMQL2+XMF2
24995 AM2(2,2)=XMQR2+XMF2
24998 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
24999 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
25000 AM2(1,2)=XMF*(ATR+XMU*TANB)
25001 ELSEIF(L.EQ.2) THEN
25002 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
25003 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
25004 AM2(1,2)=XMF*(ATR+XMU/TANB)
25005 ELSEIF(L.EQ.3) THEN
25006 IF(IMSS(8).EQ.1) THEN
25007 AM2(1,1)=RMSS(6)**2
25008 AM2(2,2)=RMSS(7)**2
25013 AM2(1,2)=XMF*(ATR+XMU*TANB)
25018 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
25019 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
25022 IF(XMF12.LT.0D0) THEN
25023 WRITE(MSTU(11),*) ' NEGATIVE**2 MASS FOR SFERMION '
25027 IF(XMF22-XMF12.GT.0D0) THEN
25028 RT(1,1) = SQRT((XMF22-AM2(1,1))/(XMF22-XMF12))
25030 RT(1,2) = -SIGN(SQRT(1D0-RT(1,1)**2),AM2(1,2)/(XMF22-XMF12))
25046 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
25052 IF(DI(1,1).GT.DI(2,2)) THEN
25053 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
25054 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
25055 WRITE(MSTU(11),*) AM2
25056 WRITE(MSTU(11),*) DI
25057 WRITE(MSTU(11),*) RT
25068 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
25069 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25070 & ' OFF DIAGONAL ELEMENTS '
25071 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
25072 WRITE(MSTU(11),*) DI
25073 WRITE(MSTU(11),*) ' ROTATION = ',RT
25075 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
25076 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25077 & ' NEGATIVE MASSES '
25080 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
25081 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
25082 SFMIX(IF,1)=RT(1,1)
25083 SFMIX(IF,2)=RT(1,2)
25084 SFMIX(IF,3)=RT(2,1)
25085 SFMIX(IF,4)=RT(2,2)
25091 C*********************************************************************
25094 C...Finds the mass eigenstates and mixing matrices for neutralinos
25099 C...Double precision and integer declarations.
25100 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25101 INTEGER PYK,PYCHGE,PYCOMP
25102 C...Parameter statement to help give large particle numbers.
25103 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25105 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25106 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25107 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25108 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25110 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
25112 C...Local variables.
25113 DOUBLE PRECISION XMW,XMZ
25114 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
25115 DOUBLE PRECISION ZP(4,4)
25116 DOUBLE PRECISION DETX,XI(2,2)
25117 DOUBLE PRECISION XXX,YYY,XMH,XML
25118 DOUBLE PRECISION COSW,SINW
25119 DOUBLE PRECISION XMU
25120 DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
25121 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
25122 DOUBLE PRECISION XM1,XM2,XM3,BETA
25123 DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
25124 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
25125 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
25126 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
25127 DOUBLE PRECISION PYALPS,PYALEM
25128 DOUBLE PRECISION PYRNM3
25129 INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
25130 DATA KFNCHI/1000022,1000023,1000025,1000035/
25133 IF(IMSS(1).EQ.2) THEN
25136 C...M1, M2, AND M3 ARE INDEPENDENT
25141 ELSEIF(IOPT.GE.1) THEN
25145 A1=AEM/(1D0-PARU(102))
25148 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
25150 XM2=XM1*A2/A1*3D0/5D0
25151 ELSEIF(IOPT.EQ.3) THEN
25152 XM1=XM2*5D0/3D0*A1/A2
25155 IF(XM3.LE.0D0) THEN
25156 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
25162 IF(IMSS(3).EQ.1) THEN
25163 PMAS(PYCOMP(KSUSY1+21),1)=XM3
25168 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25169 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
25170 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
25176 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25177 RM2=PMAS(I,1)**2/XM3**2
25178 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
25179 IF(ARG.GE.0D0) THEN
25180 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
25182 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
25187 ELSEIF(X0.EQ.0D0) THEN
25191 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
25192 & 0.5D0*X0**2*LOG(AX0)
25193 BT=(-1D0-2D0*X0)/4D0
25198 ELSEIF(X1.EQ.0D0) THEN
25202 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
25203 & X1**2*LOG(AX1)+AT
25204 BT=(-1D0-2D0*X1)/4D0+BT
25208 X0=0.5D0*(1D0+RM2-RM1)
25209 Y0=-0.5D0*SQRT(-ARG)
25210 AMGX0=SQRT(X0**2+Y0**2)
25211 AM1X0=SQRT((1D0-X0)**2+Y0**2)
25212 ARGX0=ATAN2(-X0,-Y0)
25213 AR1X0=ATAN2(1D0-X0,Y0)
25218 ARGX1=ATAN2(-X1,-Y1)
25219 AR1X1=ATAN2(1D0-X1,Y1)
25220 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
25221 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
25222 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
25223 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
25224 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
25225 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
25230 PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
25234 C...NEUTRALINO MASSES
25238 SINW=SQRT(PARU(102))
25239 COSW=SQRT(1D0-PARU(102))
25250 AR(1,3) = -XMZ*SINW*COSB
25252 AR(1,4) = XMZ*SINW*SINB
25254 AR(2,3) = XMZ*COSW*COSB
25256 AR(2,4) = -XMZ*COSW*SINB
25260 CALL PYEIG4(AR,WR,ZR)
25263 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
25266 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
25270 C...CHARGINO MASSES
25273 AR(1,2) = SQRT(2D0)*XMW*SINB
25274 AR(2,1) = SQRT(2D0)*XMW*COSB
25275 TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2
25276 TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2
25277 TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)*
25278 &(AR(1,2)**2+AR(2,1)**2)+
25279 &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1)
25281 IF(DISCR.LT.0D0) THEN
25282 WRITE(MSTU(11),*) ' PROBLEM WITH DISCR '
25286 XML2=0.5D0*(TERMB-DISCR)
25287 XMH2=0.5D0*(TERMB+DISCR)
25290 PMAS(PYCOMP(KSUSY1+24),1)=XML
25291 PMAS(PYCOMP(KSUSY1+37),1)=XMH
25294 XXX=AR(1,1)**2+AR(2,1)**2
25295 YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1)
25296 VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2)
25297 VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25298 VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2)
25299 VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25304 DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1)
25305 XI(1,1) = AR(2,2)/DETX
25306 XI(2,2) = AR(1,1)/DETX
25307 XI(1,2) = -AR(1,2)/DETX
25308 XI(2,1) = -AR(2,1)/DETX
25314 UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J)
25323 C*********************************************************************
25326 C...Calculates the running of M3, the SU(3) gluino mass parameter.
25328 FUNCTION PYRNM3(RGUT)
25330 C...Double precision and integer declarations.
25331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25332 INTEGER PYK,PYCHGE,PYCOMP
25334 C...Local variables.
25335 DOUBLE PRECISION PI,R
25336 DOUBLE PRECISION TOL
25339 DATA PI,R/3.141592654D0,0.61803399D0/
25343 BX=RGUT*PYALPS(RGUT**2)
25344 AX=MIN(50D0,BX*0.5D0)
25345 CX=MAX(2000D0,2D0*BX)
25349 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
25357 F1=ABS(X1-RGUT*AS1)
25359 F2=ABS(X2-RGUT*AS2)
25360 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
25367 F2=ABS(X2-RGUT*AS2)
25374 F1=ABS(X1-RGUT*AS1)
25389 C*********************************************************************
25392 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
25393 C...Specific application: mixing in neutralino sector.
25395 SUBROUTINE PYEIG4(A,W,Z)
25396 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25397 INTEGER PYK,PYCHGE,PYCOMP
25399 C...Arrays: in call and local.
25400 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
25402 C...Coefficients of fourth-degree equation from matrix.
25403 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
25404 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
25408 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
25417 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
25418 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
25419 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
25420 B0=B0+(-1D0)**(I+1)*A(1,I)*(
25421 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
25422 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
25423 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
25426 C...Coefficients of third-degree equation needed for
25427 C...separation into two second-degree equations.
25428 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
25431 C0=-B1**2-B0*B3**2+4D0*B0*B2
25432 CQ=C1/3D0-C2**2/9D0
25433 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
25436 C...Cases with one or three real roots.
25437 IF(CQR.GE.0D0) THEN
25438 S1=(CR+SQRT(CQR))**(1D0/3D0)
25439 S2=(CR-SQRT(CQR))**(1D0/3D0)
25443 THE=ACOS(CR/SABS**3)/3D0
25448 C...Find and solve two second-degree equations.
25449 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
25450 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
25451 Q1=U/2D0+SQRT(U**2/4D0-B0)
25452 Q2=U/2D0-SQRT(U**2/4D0-B0)
25453 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
25458 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
25459 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
25460 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
25461 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
25463 C...Order eigenvalues in asceding mass.
25466 DO 130 I2=I1-1,1,-1
25467 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
25473 C...Find equation system for eigenvectors.
25476 D(J1,J1)=A(J1,J1)-W(I)
25483 C...Find largest element in matrix.
25487 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
25490 DAMAX=ABS(D(J1,J2))
25494 C...Subtract others by multiple of row selected above.
25496 DO 210 J3=JA+1,JA+3
25498 RL=D(J1,JB)/D(JA,JB)
25500 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
25501 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
25504 DAMAX=ABS(D(J1,J2))
25508 C...Do one more subtraction of a row.
25510 DO 230 J3=JC+1,JC+3
25512 IF(J1.EQ.JA) GOTO 230
25513 RL=D(J1,JD)/D(JC,JD)
25515 IF(J2.EQ.JB) GOTO 220
25516 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
25517 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
25519 DAMAX=ABS(D(J1,J2))
25523 C...Construct unnormalized eigenvector.
25525 JF2=JD+2-4*((JD+1)/4)
25526 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
25527 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
25530 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
25531 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
25534 C...Normalize and fill in final array.
25535 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
25536 SGN=(-1D0)**INT(PYR(0)+0.5D0)
25545 C*********************************************************************
25548 C...Determines the Higgs boson mass spectrum using several inputs.
25550 SUBROUTINE PYHGGM(ALPHA)
25552 C...Double precision and integer declarations.
25553 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25554 INTEGER PYK,PYCHGE,PYCOMP
25555 C...Parameter statement to help give large particle numbers.
25556 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25558 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25559 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25561 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25562 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
25564 C...Local variables.
25565 DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
25566 DOUBLE PRECISION ALPHA
25567 INTEGER I,J,IHOPT,II,JJ,IT
25568 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
25569 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
25570 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
25571 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
25574 IF(IHOPT.EQ.2) THEN
25589 DMC=PMAS(PYCOMP(KSUSY1+37),1)
25594 IF(IHOPT.EQ.0) THEN
25595 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25596 & DMHCH,DSA,DCA,DTANBA)
25597 ELSEIF(IHOPT.EQ.1) THEN
25598 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25599 & DMHCH,DSA,DCA,DTANBA)
25600 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
25601 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
25602 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA)
25606 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.1D-1) THEN
25607 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
25608 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
25609 & PMAS(PYCOMP(1000006),1),DSTOP2
25611 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.1D-1) THEN
25612 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
25613 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
25614 & PMAS(PYCOMP(2000006),1),DSTOP1
25616 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.1D-1) THEN
25617 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
25618 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
25619 & PMAS(PYCOMP(1000005),1),DSBOT2
25621 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.1D-1) THEN
25622 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
25623 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
25624 & PMAS(PYCOMP(2000005),1),DSBOT1
25639 C*********************************************************************
25642 C...This routine computes the renormalization group improved
25643 C...values of Higgs masses and couplings in the MSSM.
25645 C...Program based on the work by M. Carena, J.R. Espinosa,
25646 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
25648 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
25649 C...All masses in GeV units. MA is the CP-odd Higgs mass,
25650 C...MTOP is the physical top mass, MQ and MUR are the soft
25651 C...supersymmetry breaking mass parameters of left handed
25652 C...and right handed stops respectively, AU and AD are the
25653 C...stop and sbottom trilinear soft breaking terms,
25654 C...respectively, and MU is the supersymmetric
25655 C...Higgs mass parameter. We use the conventions from
25656 C...the physics report of Haber and Kane: left right
25657 C...stop mixing term proportional to (AU - MU/TANB)
25658 C...We use as input TANB defined at the scale MTOP
25660 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
25661 C...where MH and HM are the lightest and heaviest CP-even
25662 C...Higgs masses, MHCH is the charged Higgs mass and
25663 C...ALPHA is the Higgs mixing angle
25664 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
25666 C...Range of validity:
25667 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
25668 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
25669 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
25670 C...are the sbottom mass eigenvalues, respectively. This
25671 C...range automatically excludes the existence of tachyons.
25672 C...For the charged Higgs mass computation, the method is
25674 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
25675 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
25676 C...where M_SUSY**2 is the average of the squared stop mass
25677 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
25678 C...masses have been assumed to be of order of the stop ones
25679 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
25681 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
25682 &XMHCH,SA,CA,TANBA)
25684 C...Double precision and integer declarations.
25685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25686 INTEGER PYK,PYCHGE,PYCOMP
25687 C...Parameter statement to help give large particle numbers.
25688 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25691 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25692 SAVE /PYDAT1/,/PYDAT2/
25694 C...Local variables.
25695 DOUBLE PRECISION PYALEM,PYALPS
25696 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
25697 DOUBLE PRECISION XMHCH,SA,CA
25698 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
25699 DOUBLE PRECISION Q02
25700 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
25701 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
25702 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
25703 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
25704 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
25705 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
25706 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
25707 DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
25712 ALP1=AEM/(1D0-PARU(102))
25725 C...MBOTTOM(MTOP) = 3. GEV
25727 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
25728 &LOG(XMTOP**2/XMZ**2))
25730 C...RMTOP= RUNNING TOP QUARK MASS
25731 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
25732 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
25733 T = LOG(XMS**2/XMTOP**2)
25734 SINB = TANB/((1D0 + TANB**2)**0.5D0)
25736 C...IF(MA.LE.XMTOP) TANBA = TANBT
25738 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
25739 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
25740 &LOG(XMA**2/XMTOP**2))
25742 SINBT = TANBT/SQRT(1D0 + TANBT**2)
25743 COSBT = 1D0/SQRT(1D0 + TANBT**2)
25744 COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
25745 G1 = SQRT(ALP1*4D0*PI)
25746 G2 = SQRT(ALP2*4D0*PI)
25747 G3 = SQRT(ALP3*4D0*PI)
25762 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
25763 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
25764 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
25765 &+ 3D0*(AU + AD)**2/XMS2)/6D0
25766 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
25767 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
25768 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
25769 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
25770 &- 16D0*G3**2) *T/16D0/PI2)
25771 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
25772 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
25773 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
25774 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
25775 &- 16D0*G3**2) *T/16D0/PI2)
25776 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
25777 &(HU2 + HD2)*T/16D0/PI2)
25778 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25779 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25780 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25781 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
25782 &- 16D0*G3**2) *T/16D0/PI2)
25783 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25784 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
25785 &- 16D0*G3**2) *T/16D0/PI2)
25786 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
25787 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25788 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25789 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25791 &(1+ (6D0*HU2 -2D0* HD2
25792 &- 16D0*G3**2) *T/16D0/PI2)
25793 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25795 &(1+ (6D0*HD2 -2D0* HU2/2D0
25796 &- 16D0*G3**2) *T/16D0/PI2)
25797 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
25798 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
25799 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
25800 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
25801 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
25802 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25803 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
25804 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25805 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
25806 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25807 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
25808 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25809 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
25810 &2D0* XLAM6*SINBT*COSBT
25811 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
25813 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
25815 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
25816 &2D0* XLAM6* COSBT*SINBT
25817 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25818 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
25819 &((XLAM1* COSBT**2 +2D0*
25820 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
25821 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
25823 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
25824 &+ XLAM4) + XLAM6*COSBT**2
25825 &+ XLAM7* SINBT**2))
25827 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
25828 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
25831 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
25832 XMHCH = SQRT(XMHCH2)
25834 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25835 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25836 &XLAM6* COSBT*SINBT
25837 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25838 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25839 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
25840 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
25842 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
25843 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
25844 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
25845 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
25846 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25847 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25848 &XLAM6* COSBT*SINBT
25849 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25850 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25851 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
25861 C*********************************************************************
25864 C...This subroutine computes the CP-even higgs and CP-odd pole
25865 c...Higgs masses and mixing angles.
25867 C...Program based on the work by M. Carena, M. Quiros
25868 C...and C.E.M. Wagner, "Effective potential methods and
25869 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
25871 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
25873 C...where MCHI is the largest chargino mass, MA is the running
25874 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
25875 C...expectaion values at the scale MTOP, MQ is the third generation
25876 C...left handed squark mass parameter, MUR is the third generation
25877 C...right handed stop mass parameter, MDR is the third generation
25878 C...right handed sbottom mass parameter, MTOP is the pole top quark
25879 C...mass; AT,AB are the soft supersymmetry breaking trilinear
25880 C...couplings of the stop and sbottoms, respectively, and MU is the
25881 C...supersymmetric mass parameter
25883 C...The parameter IHIGGS=0,1,2,3 corresponds to the
25884 c...number of Higgses whose pole mass is computed
25885 c...by the subroutine PYVACU(...). If IHIGGS=0 only running
25886 c...masses are given, what makes the running of the program
25887 c...much faster and it is quite generally a good approximation
25888 c...(for a theoretical discussion see ref. below).
25889 c...If IHIGGS=1, only the pole
25890 c...mass for H is computed. If IHIGGS=2, then h and H, and
25891 c...if IHIGGS=3, then h,H,A polarizations are computed
25893 C...Output: MH and MHP which are the lightest CP-even Higgs running
25894 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
25895 C...Higgs running and pole masses, repectively; SA and CA are the
25896 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
25897 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
25898 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
25899 C...the value of TANB at the CP-odd Higgs mass scale
25901 C...This subroutine makes use of CERN library subroutine
25902 C...integration package, which makes the computation of the
25903 C...pole Higgs masses somewhat faster. We thank P. Janot for this
25904 C...improvement. Those who are not able to call the CERN
25905 C...libraries, please use the subroutine SUBHPOLE2.F, which
25906 C...although somewhat slower, gives identical results
25908 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
25909 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
25911 C...Double precision and integer declarations.
25912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25913 INTEGER PYK,PYCHGE,PYCOMP
25915 CALL PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
25916 &XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,SBOT1,SBOT2,
25917 &SA,CA,STOP1W,STOP2W,TANBA)
25918 SINB = TANB/(TANB**2+1D0)**0.5D0
25919 COSB = 1D0/(TANB**2+1D0)**0.5D0
25920 SINBMA = SINB*CA - COSB*SA
25925 C*********************************************************************
25928 C...Computes Higgs masses and mixing angles, see PYPOLE above.
25930 SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
25931 &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
25932 &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
25934 C...Double precision and integer declarations.
25935 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25937 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25938 INTEGER PYK,PYCHGE,PYCOMP
25940 C...Local variables.
25941 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
25942 &SSBOT2(2),B(2,2),COUPB(2,2),
25943 &HCOUPT(2,2),HCOUPB(2,2),
25944 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
25954 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
25956 C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
25960 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
25961 &XMU,XMH,HM,SA,CA,TANBA)
25962 SINB = TANB/(TANB**2+1D0)**0.5D0
25963 COSB = 1D0/(TANB**2+1D0)**0.5D0
25964 COS2B = SINB**2 - COSB**2
25965 SINBPA = SINB*CA + COSB*SA
25966 COSBPA = COSB*CA - SINB*SA
25970 IF(XMUR.LT.0D0) XMUR2=-XMUR2
25972 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
25973 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
25974 IF(XMST11.LT.0D0) GOTO 500
25975 IF(XMST22.LT.0D0) GOTO 500
25976 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
25977 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
25978 IF(XMSB11.LT.0D0) GOTO 500
25979 IF(XMSB22.LT.0D0) GOTO 500
25980 WMST11 = RXMT**2 + XMQ2
25981 WMST22 = RXMT**2 + XMUR2
25982 XMST12 = RXMT*(AT - XMU/TANB)
25983 XMSB12 = RMBOT*(AB - XMU*TANB)
25985 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25986 C...STOP EIGENVALUES CALCULATION
25987 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25989 STOP12 = 0.5D0*(XMST11+XMST22) +
25990 &0.5D0*((XMST11+XMST22)**2 -
25991 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
25992 STOP22 = 0.5D0*(XMST11+XMST22) -
25993 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
25994 &XMST12**2))**0.5D0
25996 IF(STOP22.LT.0D0) GOTO 500
25999 STOP1 = STOP12**0.5D0
26000 STOP2 = STOP22**0.5D0
26004 IF(XMST12.EQ.0D0) XST11 = 1D0
26005 IF(XMST12.EQ.0D0) XST12 = 0D0
26006 IF(XMST12.EQ.0D0) XST21 = 0D0
26007 IF(XMST12.EQ.0D0) XST22 = 1D0
26009 IF(XMST12.EQ.0D0) GOTO 110
26011 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26012 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26013 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26014 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26021 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
26022 &0.5D0*((XMSB11+XMSB22)**2 -
26023 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
26024 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
26025 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
26026 &XMSB12**2))**0.5D0
26027 IF(SBOT22.LT.0D0) GOTO 500
26028 SBOT1 = SBOT12**0.5D0
26029 SBOT2 = SBOT22**0.5D0
26034 IF(XMSB12.EQ.0D0) XSB11 = 1D0
26035 IF(XMSB12.EQ.0D0) XSB12 = 0D0
26036 IF(XMSB12.EQ.0D0) XSB21 = 0D0
26037 IF(XMSB12.EQ.0D0) XSB22 = 1D0
26039 IF(XMSB12.EQ.0D0) GOTO 130
26041 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26042 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26043 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26044 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26056 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26057 C...STARTING OF LIGHT HIGGS
26058 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26060 IF(IHIGGS.EQ.0) GOTO 490
26065 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
26066 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26067 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
26068 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
26077 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
26078 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26079 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
26080 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
26088 180 ITER = ITER + 1
26091 PR(I3)=PRUN+(I3-2)*EPS/2
26096 POLT = POLT + COUPT(I,J)**2*3D0*
26097 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26103 POLB = POLB + COUPB(I,J)**2*3D0*
26104 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26111 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26113 & (-2D0*XMT**2+0.5D0*P2)*
26114 & PYFINT(P2,XMT2,XMT2)
26116 POL = POLT + POLB + POLTT
26117 POLAR(I3) = P2 - XMH**2 - POL
26119 DERIV = (POLAR(3)-POLAR(1))/EPS
26120 DRUN = - POLAR(2)/DERIV
26123 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240
26129 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26130 C...END OF LIGHT HIGGS
26131 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26133 250 IF(IHIGGS.EQ.1) GOTO 490
26135 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26136 C... STARTING OF HEAVY HIGGS
26137 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26142 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
26143 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26144 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
26145 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
26153 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
26154 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26155 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
26156 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
26165 300 ITER = ITER + 1
26167 PR(I3)=PRUN+(I3-2)*EPS/2
26173 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
26174 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26181 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
26182 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26190 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26192 & (-2D0*XMT**2+0.5D0*HP2)*
26193 & PYFINT(HP2,XMT2,XMT2)
26195 HPOL = HPOLT + HPOLB + HPOLTT
26196 POLAR(I3) =HP2-HM**2-HPOL
26198 DERIV = (POLAR(3)-POLAR(1))/EPS
26199 DRUN = - POLAR(2)/DERIV
26202 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360
26210 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26211 C... END OF HEAVY HIGGS
26212 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26214 IF(IHIGGS.EQ.2) GOTO 490
26216 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26217 C...BEGINNING OF PSEUDOSCALAR HIGGS
26218 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26223 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
26224 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
26230 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
26231 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
26238 420 ITER = ITER + 1
26240 PR(I3)=PRUN+(I3-2)*EPS/2
26245 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
26246 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26252 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
26253 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26259 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26260 & COSB**2/SINB**2 *
26262 & PYFINT(AP2,XMT2,XMT2)
26263 APOL = APOLT + APOLB + APOLTT
26264 POLAR(I3) = AP2 - XMA**2 -APOL
26266 DERIV = (POLAR(3)-POLAR(1))/EPS
26267 DRUN = - POLAR(2)/DERIV
26270 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480
26276 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26277 C...END OF PSEUDOSCALAR HIGGS
26278 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26280 IF(IHIGGS.EQ.3) GOTO 490
26285 WRITE(MSTU(11),*) ' EXITING IN PYVACU '
26286 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
26287 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
26288 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
26292 C*********************************************************************
26295 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26297 SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
26298 &XMHP,HMP,SA,CA,TANBA)
26300 C...Double precision and integer declarations.
26301 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26302 INTEGER PYK,PYCHGE,PYCOMP
26304 C...Local variables.
26305 DIMENSION VH(2,2),XM2(2,2),XM2P(2,2)
26316 C...MBOTTOM(XMT) = 3. GEV
26318 ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z*
26319 &LOG(XMT**2/XMZ**2))
26321 C...RXMT= RUNNING TOP QUARK MASS
26322 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26323 TQ = LOG((XMQ**2+XMT**2)/XMT**2)
26324 TU = LOG((XMUR**2 + XMT**2)/XMT**2)
26325 TD = LOG((XMDL**2 + XMT**2)/XMT**2)
26326 SINB = TANB/((1D0 + TANB**2)**0.5D0)
26329 &TANBA = TANB*(1D0-3D0/32D0/PI**2*
26330 &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
26331 &LOG(XMA**2/XMT**2))
26332 IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA
26333 SINB = TANBT/((1D0 + TANBT**2)**0.5D0)
26334 COSB = 1D0/((1D0 + TANBT**2)**0.5D0)
26335 COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
26336 G1 = (ALP1*4D0*PI)**0.5D0
26337 G2 = (ALP2*4D0*PI)**0.5D0
26338 G3 = (ALP3*4D0*PI)**0.5D0
26342 CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD,
26343 &XMU,VH,STOP1,STOP2)
26345 IF(XMQ.GT.XMUR) TP = TQ - TU
26346 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ
26347 IF(XMQ.GT.XMUR) TDP = TU
26348 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ
26349 IF(XMQ.GT.XMDL) TPD = TQ - TD
26350 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ
26351 IF(XMQ.GT.XMDL) TDPD = TD
26352 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ
26354 IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
26355 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2*
26356 &HD**2*(G1**2/3D0+G2**2)*TPD
26358 IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP
26359 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2*
26360 &HU**2*(-G1**2/3D0+G2**2)*TP
26365 IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
26366 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2*
26367 &(G2**2-G1**2/3D0)*TPD
26369 IF(XMQ.GT.XMUR) DLAM3 = DLAM3 -
26370 &1D0/16D0/PI**2*G1**2*HU**2*TP
26371 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 +
26372 &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
26374 IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
26375 IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2*
26378 XLAM1 = ((G1**2 + G2**2)/4D0)*
26379 &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
26380 &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0
26381 &+ (3D0*HD**2/2D0 + HU**2/2D0
26382 &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
26383 &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
26384 &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1
26385 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
26386 &(TP + TDP)/8D0/PI**2)
26387 &+(3D0*HU**4/16D0/PI**2) *TP*(1D0
26388 &+ (3D0*HU**2/2D0 + HD**2/2D0
26389 &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
26390 &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
26391 &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2
26392 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
26393 &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
26394 &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3
26395 XLAM4 = (- G2**2/2D0)*(1D0
26396 &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
26397 &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4
26403 XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6*
26404 &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2
26406 XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7*
26407 &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2
26408 XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)*
26409 &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB
26411 XM2(2,1) = XM2(1,2)
26413 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26414 C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
26415 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26417 XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0
26419 IF(XMC.GT.XMSSU) GOTO 100
26420 IF(XMC.LT.XMT) XMC=XMT
26422 TCHAR=LOG(XMSSU**2/XMC**2)
26424 DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
26425 DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
26426 &+4D0/32/PI**2*G1**2*G2**2)*TCHAR
26428 DEM112=2D0*DEL12*V**2*COSB**2
26429 DEM222=2D0*DEL12*V**2*SINB**2
26430 DEM122=2D0*DEL3P4*V**2*SINB*COSB
26432 XM2(1,1)=XM2(1,1)+DEM112
26433 XM2(2,2)=XM2(2,2)+DEM222
26434 XM2(1,2)=XM2(1,2)+DEM122
26435 XM2(2,1)=XM2(2,1)+DEM122
26439 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26440 C...END OF CHARGINOS/NEUTRALINOS
26441 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26445 XM2P(I,J) = XM2(I,J) + VH(I,J)
26449 TRM2P = XM2P(1,1) + XM2P(2,2)
26450 DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1)
26452 XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26453 HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26455 IF(XMH2P.LT.0D0) GOTO 130
26456 XMHP = XMH2P**0.5D0
26457 S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0
26458 C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0
26459 IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0
26460 IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0
26463 SQBMA = (SINB*CA - COSB*SA)**2
26470 C*********************************************************************
26473 C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
26475 SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
26478 C...Double precision and integer declarations.
26479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26480 INTEGER PYK,PYCHGE,PYCOMP
26482 C...Local variables.
26483 DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
26484 &VH3T(2,2),VH3B(2,2),
26485 &HMIX(2,2),AL(2,2),XM2(2,2)
26487 C...Statement function.
26488 G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y)
26490 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
26495 SINBA = TANBA/(TANBA**2+1D0)**0.5D0
26496 COSBA = SINBA/TANBA
26498 SINB = TANB/(TANB**2+1D0)**0.5D0
26501 G2 = (0.0336D0*4D0*PI)**0.5D0
26502 G12 = (0.0101D0*4D0*PI)
26506 MW = (G2**2*V**2/2D0)**0.5D0
26507 ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2))
26510 IF(XMQ.GT.XMUR) XMST = XMQ
26511 IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR
26513 XMSUT = (XMST**2 + XMT**2)**0.5D0
26515 IF(XMQ.GT.XMDL) XMSB = XMQ
26516 IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL
26518 XMSUB = (XMSB**2 + XMB**2)**0.5D0
26520 TT = LOG(XMSUT**2/XMT**2)
26521 TB = LOG(XMSUB**2/XMT**2)
26523 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26524 HT = RXMT/(174.1D0*SINB)
26525 HTST = RXMT/174.1D0
26526 HB = XMB/174.1D0/COSB
26528 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
26529 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
26530 AL2 = 3D0/8D0/PI**2*HT**2
26531 BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2
26532 ALST = 3D0/8D0/PI**2*HTST**2
26533 AL1 = 3D0/8D0/PI**2*HB**2
26536 AL(1,2) = (AL2+AL1)/2D0
26537 AL(2,1) = (AL2+AL1)/2D0
26540 XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT)
26542 XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB)
26543 XMBOT2 = SQRT(XMBOT4)
26545 IF(XMA.GT.XMT) THEN
26546 VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2*
26547 & LOG(XMT**2/XMA**2))
26550 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0
26551 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0
26552 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0
26553 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0
26558 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0
26559 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0
26560 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0
26561 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0
26565 SINBT = TANBST/(1D0+TANBST**2)**0.5D0
26566 COSBT = SINBT/TANBST
26569 SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0
26570 COSBB = SINBB/TANBSB
26572 STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26573 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26574 &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26575 &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0
26576 STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26577 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26578 &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26579 &XMQ2 - XMUR2)**2*0.25D0
26580 &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0
26581 IF(STOP22.LT.0D0) GOTO 120
26582 SBOT12 = (XMQ2 + XMDL2)*0.5D0
26583 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26584 &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26585 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26586 SBOT22 = (XMQ2 + XMDL2)*0.5D0
26587 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26588 &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26589 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26590 IF(SBOT22.LT.0D0) GOTO 120
26592 STOP1 = STOP12**0.5D0
26593 STOP2 = STOP22**0.5D0
26594 SBOT1 = SBOT12**0.5D0
26595 SBOT2 = SBOT22**0.5D0
26597 VH1(1,1) = 1D0/TANBST
26604 VH2(2,2) = 1D0/TANBST
26606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26608 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26611 F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)*
26613 &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2))
26614 &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2))
26616 F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)*
26618 &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2))
26619 &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2))
26621 F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)*
26622 &(-0.5D0*LOG(STOP12/STOP22)
26623 &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)*
26626 F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
26627 &(0.5D0*LOG(SBOT12/SBOT22)
26628 &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)*
26631 VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
26632 &(XMQ2+XMBOT2)/(XMDL2+XMBOT2))
26633 &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
26634 &LOG(SBOT1**2/SBOT2**2)) +
26635 &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
26636 &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
26639 &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
26640 &-STOP2**2))**2*G(STOP12,STOP22)
26642 VH3B(1,1)=VH3B(1,1)+
26643 &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B)
26645 VH3T(1,1) = VH3T(1,1) +
26646 &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T)
26648 VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
26649 &(XMQ2+XMT2)/(XMUR2+XMT2))
26650 &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
26651 &LOG(STOP1**2/STOP2**2)) +
26652 &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
26653 &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
26656 &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
26657 &-SBOT2**2))**2*G(SBOT12,SBOT22)
26659 VH3T(2,2)=VH3T(2,2)+
26660 &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T)
26662 VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B
26665 &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
26666 &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
26667 &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
26670 &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/
26671 &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
26672 &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
26674 VH3T(1,2)=VH3T(1,2) +
26675 &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T)
26677 VH3B(1,2)=VH3B(1,2)
26678 &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B)
26680 VH3T(2,1) = VH3T(1,2)
26681 VH3B(2,1) = VH3B(1,2)
26683 TQ = LOG((XMQ2 + XMT2)/XMT2)
26684 TU = LOG((XMUR2+XMT2)/XMT2)
26685 TQD = LOG((XMQ2 + XMB**2)/XMB**2)
26686 TD = LOG((XMDL2+XMB**2)/XMB**2)
26692 & 6D0/(8D0*PI**2*(H1T**2+H2T**2))
26693 & *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
26694 & 6D0/(8D0*PI**2*(H1B**2+H2B**2))
26695 & *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
26712 C*********************************************************************
26715 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26717 FUNCTION PYFINT(A,B,C)
26719 C...Double precision and integer declarations.
26720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26721 INTEGER PYK,PYCHGE,PYCOMP
26723 COMMON/PYINTS/XXM(20)
26726 C...Local variables.
26734 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
26739 C*********************************************************************
26742 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
26746 C...Double precision and integer declarations.
26747 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26748 INTEGER PYK,PYCHGE,PYCOMP
26750 COMMON/PYINTS/XXM(20)
26753 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
26754 &(X*(XXM(2)-XXM(3))+XXM(3)))
26759 C*********************************************************************
26762 C...Calculates decays of sfermions.
26764 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
26766 C...Double precision and integer declarations.
26767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26768 INTEGER PYK,PYCHGE,PYCOMP
26769 C...Parameter statement to help give large particle numbers.
26770 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
26772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26774 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
26775 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
26777 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
26779 C...Local variables.
26781 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
26783 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
26784 DOUBLE PRECISION PYLAMF,XL
26785 DOUBLE PRECISION TANW,XW,AEM,C1,AS
26786 DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
26787 DOUBLE PRECISION CH1,CH2,CH3,CH4
26788 DOUBLE PRECISION XMBOT,XMTOP
26789 DOUBLE PRECISION XLAM(0:200)
26790 INTEGER IDLAM(200,3)
26791 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
26792 DOUBLE PRECISION SR2
26793 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
26794 DOUBLE PRECISION CW
26795 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
26796 DOUBLE PRECISION COSA,SINA,TANB
26797 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
26798 DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
26799 INTEGER IG,KF1,KF2,ILR2,IDP
26800 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
26801 DATA IGG/23,25,35,36/
26802 DATA PI/3.141592654D0/
26803 DATA SR2/1.4142136D0/
26804 DATA KFNCHI/1000022,1000023,1000025,1000035/
26805 DATA KFCCHI/1000024,1000037/
26807 C...COUNT THE NUMBER OF DECAY MODES
26811 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
26812 &KFIN.EQ.KSUSY2+16) RETURN
26819 TANW = SQRT(XW/(1D0-XW))
26824 C...ILR is 1 for left and 2 for right.
26826 C...IFL is matching non-SUSY flavour.
26827 IFL=MOD(KFIN,KSUSY1)
26828 C...IDU is weak isospin, 1 for down and 2 for up.
26840 XMTOP=PYRNMT(PMAS(6,1))
26855 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
26857 IF(IMSS(11).EQ.1) THEN
26860 XMGR=PMAS(PYCOMP(IDG),1)
26861 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
26864 ELSEIF(IFL.EQ.6) THEN
26869 IF(XMI.GT.XMGR+XMF) THEN
26874 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
26878 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
26880 C...CHARGED DECAYS:
26882 C...DI -> U CHI1-,CHI2-
26886 C...UI -> D CHI1+,CHI2+
26893 IF(XMI.GE.AXMJ+XMFP) THEN
26900 ELSEIF(IFL.LT.6) THEN
26905 AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA
26906 BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA
26912 ELSEIF(IFL.LT.5) THEN
26917 AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA
26918 BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA
26922 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
26923 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
26924 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
26925 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
26941 XL=PYLAMF(XMI2,XMA2,XMB2)
26942 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
26943 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
26944 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP)
26947 IDLAM(LKNT,1)=-KFCCHI(IX)
26948 IDLAM(LKNT,2)=IFL+1
26950 IDLAM(LKNT,1)=KFCCHI(IX)
26951 IDLAM(LKNT,2)=IFL-1
26962 IF(XMI.GE.AXMJ+XMF) THEN
26968 ELSEIF(IFL.LT.5) THEN
26971 BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1)
26972 AL=XMF*ZMIX(IX,3)/XMW/CBETA
26973 AR=-2D0*EI*TANW*ZMIX(IX,1)
26978 ELSEIF(IFL.LT.5) THEN
26981 BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1)
26982 AL=XMF*ZMIX(IX,4)/XMW/SBETA
26983 AR=-2D0*EI*TANW*ZMIX(IX,1)
26987 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
26988 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
26989 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
26990 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
27006 XL=PYLAMF(XMI2,XMA2,XMB2)
27007 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
27008 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27009 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27010 IDLAM(LKNT,1)=KFNCHI(IX)
27016 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
27020 IF(ILR.EQ.1) GOTO 120
27022 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
27023 IF(XMI.LT.XMSF1+XMB) GOTO 120
27025 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
27028 ELSEIF(IG.EQ.25) THEN
27031 ELSEIF(IFL.EQ.6) THEN
27033 ELSEIF(IFL.LT.5) THEN
27039 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27040 & XMF**2/XMW*COSA/SBETA
27041 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27042 & XMF**2/XMW*COSA/SBETA
27044 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27045 & XMF**2/XMW*(-SINA)/CBETA
27046 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27047 & XMF**2/XMW*(-SINA)/CBETA
27051 ELSEIF(IFL.EQ.6) THEN
27053 ELSEIF(IFL.EQ.15) THEN
27059 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
27062 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
27068 ELSEIF(IG.EQ.35) THEN
27071 ELSEIF(IFL.EQ.6) THEN
27073 ELSEIF(IFL.LT.5) THEN
27079 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27080 & XMF**2/XMW*SINA/SBETA
27081 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27082 & XMF**2/XMW*SINA/SBETA
27084 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27085 & XMF**2/XMW*COSA/CBETA
27086 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27087 & XMF**2/XMW*COSA/CBETA
27091 ELSEIF(IFL.EQ.6) THEN
27093 ELSEIF(IFL.EQ.15) THEN
27099 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
27102 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
27108 ELSEIF(IG.EQ.36) THEN
27113 ELSEIF(IFL.EQ.6) THEN
27115 ELSEIF(IFL.LT.5) THEN
27122 ELSEIF(IFL.EQ.6) THEN
27124 ELSEIF(IFL.EQ.15) THEN
27130 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
27132 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
27138 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
27139 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
27140 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
27141 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27144 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27146 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
27149 IDLAM(LKNT,1)=KFIN-KSUSY1
27155 IF(MOD(IFL,2).EQ.0) THEN
27161 XMSF1=PMAS(PYCOMP(KF1),1)
27162 XMSF2=PMAS(PYCOMP(KF2),1)
27163 IF(XMI.GT.XMB+XMSF1) THEN
27164 IF(MOD(IFL,2).EQ.0) THEN
27166 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
27168 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
27172 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
27174 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
27177 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27179 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27182 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27184 IF(XMI.GT.XMB+XMSF2) THEN
27185 IF(MOD(IFL,2).EQ.0) THEN
27187 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
27189 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
27193 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
27195 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
27198 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
27200 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27203 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27208 IF(MOD(IFL,2).EQ.0) THEN
27214 XMSF1=PMAS(PYCOMP(KF1),1)
27215 XMSF2=PMAS(PYCOMP(KF2),1)
27216 IF(XMI.GT.XMB+XMSF1) THEN
27221 IF(MOD(IFL,2).EQ.0) THEN
27224 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
27225 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
27226 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
27227 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
27230 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
27231 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
27232 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
27233 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
27244 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
27245 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
27246 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
27247 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
27250 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
27251 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
27252 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
27253 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
27262 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27264 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27265 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27266 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27267 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27270 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27272 IF(XMI.GT.XMB+XMSF2) THEN
27277 IF(MOD(IFL,2).EQ.0) THEN
27280 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
27281 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
27282 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
27283 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
27286 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
27287 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
27288 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
27289 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
27300 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
27301 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
27302 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
27303 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
27306 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
27307 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
27308 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
27309 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
27318 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27320 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27321 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27322 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27323 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27326 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27329 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
27334 IF(IFL.EQ.6) XMF=PMAS(6,1)
27335 IF(IFL.EQ.5) XMF=PMAS(5,1)
27336 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
27338 IF(XMI.GE.AXMJ+XMF) THEN
27355 XL=PYLAMF(XMI2,XMA2,XMB2)
27356 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27357 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27358 IDLAM(LKNT,1)=KSUSY1+21
27364 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
27365 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
27366 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
27367 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
27368 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
27369 C...M*M = C1**2 * G**2/(16PI**2)
27370 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
27372 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
27373 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
27374 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
27375 IDLAM(LKNT,1)=KSUSY1+22
27383 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27384 XLAM(0)=XLAM(0)+XLAM(I)
27386 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
27391 C*********************************************************************
27394 C...Calculates gluino decay modes.
27396 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
27398 C...Double precision and integer declarations.
27399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27400 INTEGER PYK,PYCHGE,PYCOMP
27401 C...Parameter statement to help give large particle numbers.
27402 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27404 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27405 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27406 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27407 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27409 COMMON/PYINTS/XXM(20)
27410 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
27412 C...Local variables.
27413 INTEGER KFIN,KCIN,KF
27414 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
27415 &XMZ,XMZ2,AXMJ,AXMI
27416 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
27417 DOUBLE PRECISION C1L,C1R,D1L,D1R
27418 DOUBLE PRECISION C2L,C2R,D2L,D2R
27419 DOUBLE PRECISION PYLAMF,XL
27420 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
27421 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
27422 DOUBLE PRECISION ALFA,BETA
27423 DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
27424 DOUBLE PRECISION XLAM(0:200)
27425 INTEGER IDLAM(200,3)
27426 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
27427 DOUBLE PRECISION SR2
27428 DOUBLE PRECISION GAM
27429 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
27430 DOUBLE PRECISION PYGAUS
27431 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
27432 DOUBLE PRECISION PREC
27433 INTEGER KFNCHI(4),KFCCHI(2)
27434 DATA PI/3.141592654D0/
27435 DATA SR2/1.4142136D0/
27437 DATA KFNCHI/1000022,1000023,1000025,1000035/
27438 DATA KFCCHI/1000024,1000037/
27440 C...COUNT THE NUMBER OF DECAY MODES
27442 IF(KFIN.NE.KSUSY1+21) RETURN
27450 TANW = SQRT(XW/(1D0-XW))
27461 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
27463 IF(IMSS(11).EQ.1) THEN
27466 XMGR=PMAS(PYCOMP(IDG),1)
27467 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
27468 IF(AXMI.GT.XMGR) THEN
27477 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
27481 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
27484 IDU=3-(1+MOD(IFL,2))
27485 IF(XMI.GE.AXMJ+XMF) THEN
27502 XL=PYLAMF(XMI2,XMA2,XMB2)
27503 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
27504 & (CA**2+CB**2)+4D0*CA*CB*XMI*XMF)
27505 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
27509 XLAM(LKNT)=XLAM(LKNT-1)
27510 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27511 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27517 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
27518 C...GLUINO -> NI Q QBAR
27522 IF(XMI.GE.AXMJ) THEN
27527 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
27528 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
27534 S12MAX=(XMI-AXMJ)**2
27539 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27541 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
27542 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120
27543 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
27545 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27546 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27547 IDLAM(LKNT,1)=KFNCHI(IX)
27551 IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
27553 XLAM(LKNT)=XLAM(LKNT-1)
27554 IDLAM(LKNT,1)=KFNCHI(IX)
27559 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130
27560 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
27561 CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
27564 IDLAM(LKNT,1)=KFNCHI(IX)
27570 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
27571 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
27573 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27575 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
27576 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140
27577 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
27579 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27580 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27581 IDLAM(LKNT,1)=KFNCHI(IX)
27585 IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
27587 XLAM(LKNT)=XLAM(LKNT-1)
27588 IDLAM(LKNT,1)=KFNCHI(IX)
27593 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
27594 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
27595 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150
27597 IF(XMI.GE.AXMJ+2D0*XMF) THEN
27598 CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
27601 IDLAM(LKNT,1)=KFNCHI(IX)
27609 C...GLUINO -> CI Q QBAR'
27613 IF(XMI.GE.AXMJ) THEN
27615 S12MAX=(AXMI-AXMJ)**2
27624 XXM(7)=UMIX(IX,1)*SR2
27625 XXM(8)=VMIX(IX,1)*SR2
27626 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
27627 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
27628 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170
27629 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
27631 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
27632 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
27633 IDLAM(LKNT,1)=KFCCHI(IX)
27637 XLAM(LKNT)=XLAM(LKNT-1)
27638 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27639 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27640 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27642 IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
27644 XLAM(LKNT)=XLAM(LKNT-1)
27645 IDLAM(LKNT,1)=KFCCHI(IX)
27649 XLAM(LKNT)=XLAM(LKNT-1)
27650 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27651 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27652 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27656 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180
27657 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180
27660 IF(XMI.GE.AXMJ+XMF+XMFP) THEN
27661 CALL PYTBBC(IX,80,AXMI,GAM)
27664 IDLAM(LKNT,1)=KFCCHI(IX)
27668 XLAM(LKNT)=XLAM(LKNT-1)
27669 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27670 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27671 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27680 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27681 XLAM(0)=XLAM(0)+XLAM(I)
27683 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
27688 C*********************************************************************
27691 C...Calculates the three-body decay of gluinos into
27692 C...neutralinos and third generation fermions.
27694 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
27696 C...Double precision and integer declarations.
27697 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27698 INTEGER PYK,PYCHGE,PYCOMP
27699 C...Parameter statement to help give large particle numbers.
27700 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27702 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27704 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27705 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27707 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
27709 C...Local variables.
27710 EXTERNAL PYSIMP,PYLAMF
27712 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
27713 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
27714 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
27715 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
27716 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
27717 DOUBLE PRECISION XLN1,XLN2,B1,B2
27718 DOUBLE PRECISION E,XMGLU,GAM
27719 DOUBLE PRECISION PYSIMP,PYLAMF
27720 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
27721 SAVE HRB,HLB,FLB,FRB
27722 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
27723 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
27724 SAVE HLT,HRT,FLT,FRT
27725 DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
27727 SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD
27728 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
27729 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
27731 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
27732 DOUBLE PRECISION ROT1(4,4)
27735 DATA IFIRST/.TRUE./
27738 SINB=TANB/SQRT(1D0+TANB**2)
27750 AMTOP=PYRNMT(PMAS(6,1))
27752 FAKT1=AMBOT/W2/AMW/COSB
27753 FAKT2=AMTOP/W2/AMW/SINB
27764 ROT1(2,1)=-ROT1(1,2)
27765 ROT1(2,2)=ROT1(1,1)
27768 ROT1(4,3)=-ROT1(3,4)
27769 ROT1(4,4)=ROT1(3,3)
27773 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
27778 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
27779 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27780 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
27782 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
27783 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
27784 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
27785 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
27788 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
27789 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27790 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
27791 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
27792 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
27793 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
27794 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
27798 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
27799 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
27800 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
27801 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
27805 IF(NINT(3D0*E).EQ.2) THEN
27812 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
27813 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
27822 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
27823 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
27829 SIN2D=SIND*COSD*2D0
27843 ALPHAW=PYALEM(XMG2)
27844 ALPHAS=PYALPS(XMG2)
27848 XM24=(XMG2+XM2)*(XM2+XMR2)
27850 SMAX=(XMG-ABS(XMR))**2
27851 XMQA=XMG2+2D0*XM2+XMR2
27853 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
27855 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
27857 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
27858 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
27859 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
27860 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
27861 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
27862 & +2D0*(FF*SIND2-HH*COSD2))*W
27863 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
27864 & +4D0*HFL*XM*XMR)*XLN1
27865 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
27866 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
27867 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
27868 & +8D0*HFL*XMQ4*SIN2D)*B1
27869 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
27870 & +4D0*HFR*XMR*XM)*XLN2
27871 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
27872 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
27873 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
27874 & -8D0*HFR*XMQ4*SIN2D)*B2
27875 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
27876 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
27877 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
27878 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
27879 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
27880 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
27881 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
27882 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
27883 G(5)=(2D0*(HH*COSD2-FF*SIND2)
27884 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
27885 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
27886 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
27887 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
27888 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
27889 & +COS2D*XM*(SBAR+XMG2-XMR2))
27890 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
27891 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
27892 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
27893 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
27894 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
27895 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
27896 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
27899 SUMME(LIN)=SUMME(LIN)+G(J)
27904 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
27905 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
27910 C*********************************************************************
27913 C...Calculates the three-body decay of gluinos into
27914 C...charginos and third generation fermions.
27916 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
27918 C...Double precision and integer declarations.
27919 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27920 INTEGER PYK,PYCHGE,PYCOMP
27921 C...Parameter statement to help give large particle numbers.
27922 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27924 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27925 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27926 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27927 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27929 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
27931 C...Local variables.
27932 EXTERNAL PYSIMP,PYLAMF
27934 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
27935 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
27936 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
27937 DOUBLE PRECISION SUMME(0:100),A(4,8)
27938 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
27939 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
27940 DOUBLE PRECISION XMGLU,GAM
27941 DOUBLE PRECISION PYSIMP,PYLAMF
27942 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
27943 &DDD(2),EEE(2),FFF(2)
27944 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
27945 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
27946 DOUBLE PRECISION AMC(2),AMN(4)
27948 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
27949 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
27951 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
27954 DATA IFIRST/.TRUE./
27957 SINB=TANB/SQRT(1D0+TANB**2)
27968 AMTOP=PYRNMT(PMAS(6,1))
27971 FAKT1=AMBOT/W2/AMW/COSB
27972 FAKT2=AMTOP/W2/AMW/SINB
27977 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
27978 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
27979 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
27980 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
27981 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
27982 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
27983 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
27984 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
27986 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
27987 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
27988 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
27989 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
27994 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
27995 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
27996 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
27997 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
27999 COS2A=COSA**2-SINA**2
28000 SIN2A=SINA*COSA*2D0
28001 COS2C=COSC**2-SINC**2
28002 SIN2C=SINC*COSC*2D0
28009 ALPHAW=PYALEM(XMG2)
28010 ALPHAS=PYALPS(XMG2)
28014 XMQ2=XMG2+XMT2+XMB2+XMR2
28015 XMQ4=XMG*XMT*XMB*XMR
28016 XMQ3=XMG2*XMR2+XMT2*XMB2
28017 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
28018 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
28020 XMST(1)=AMST(1)*AMST(1)
28021 XMST(2)=AMST(1)*AMST(1)
28022 XMST(3)=AMST(2)*AMST(2)
28023 XMST(4)=AMST(2)*AMST(2)
28024 XMSB(1)=AMSB(1)*AMSB(1)
28025 XMSB(2)=AMSB(2)*AMSB(2)
28026 XMSB(3)=AMSB(1)*AMSB(1)
28027 XMSB(4)=AMSB(2)*AMSB(2)
28029 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
28030 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
28031 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
28032 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
28033 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
28034 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
28035 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
28036 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
28038 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
28039 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
28040 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
28041 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
28042 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
28043 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
28044 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
28045 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
28047 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
28048 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
28049 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
28050 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
28051 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
28052 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
28053 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
28054 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
28056 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
28057 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
28058 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
28059 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
28060 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
28061 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
28062 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
28063 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
28065 SMAX=(XMG-ABS(XMR))**2
28066 SMIN=(XMB+XMT)**2+0.1D0
28069 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
28070 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
28072 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
28073 W=DSQRT(W)/2D0/SBAR
28074 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
28075 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
28076 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
28077 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
28078 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
28079 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
28080 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
28081 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
28082 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
28083 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
28084 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
28085 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
28086 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
28087 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
28088 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
28089 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
28090 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
28091 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
28092 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
28093 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
28094 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
28095 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
28096 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
28097 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
28098 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
28099 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
28100 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
28101 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
28102 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
28103 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
28104 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
28105 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
28106 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
28107 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
28108 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
28109 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
28110 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
28111 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
28112 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
28113 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
28114 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
28115 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
28116 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
28118 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
28119 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
28120 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
28121 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
28122 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
28123 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
28124 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
28125 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
28126 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
28127 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
28128 & -A(J,6)*(XMG2+XMR2-SBAR)
28129 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
28130 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
28131 & /(GRS+XMSB(J)+XMST(J))
28135 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
28136 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
28141 C*********************************************************************
28144 C...Calculates decay widths for the neutralinos (admixtures of
28145 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
28147 C...Input: KCIN = KF code for particle
28148 C...Output: XLAM = widths
28149 C... IDLAM = KF codes for decay particles
28150 C... IKNT = number of decay channels defined
28151 C...AUTHOR: STEPHEN MRENNA
28153 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
28154 C...when CHIGAMMA .NE. 0
28155 C...10 FEB 96: Calculate this decay for small tan(beta)
28157 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
28159 C...Double precision and integer declarations.
28160 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28161 INTEGER PYK,PYCHGE,PYCOMP
28162 C...Parameter statement to help give large particle numbers.
28163 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28165 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28166 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28167 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28168 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28170 COMMON/PYINTS/XXM(20)
28171 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
28173 C...Local variables.
28175 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
28176 &XMZ,XMZ2,AXMJ,AXMI
28177 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
28178 DOUBLE PRECISION S12MIN,S12MAX
28179 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
28180 DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
28181 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
28182 DOUBLE PRECISION PYX2XH,PYX2XG
28183 DOUBLE PRECISION XLAM(0:200)
28184 INTEGER IDLAM(200,3)
28185 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
28186 INTEGER ITH(3),KF1,KF2
28188 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
28189 DOUBLE PRECISION SR2
28190 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
28191 DOUBLE PRECISION GAMCON,XMT1,XMT2
28192 DOUBLE PRECISION PYALEM,PI,PYALPS
28193 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
28194 DOUBLE PRECISION RAT1,RAT2
28195 DOUBLE PRECISION T3T,CA,CB,FCOL
28196 DOUBLE PRECISION ALFA,BETA,TANB
28197 DOUBLE PRECISION PYGAUS,PYXXGA
28198 EXTERNAL PYXXW5,PYGAUS,PYXXZ5
28199 DOUBLE PRECISION PREC
28200 INTEGER KFNCHI(4),KFCCHI(2)
28201 DATA ETAH/1D0,1D0,-1D0/
28205 DATA PI/3.141592654D0/
28206 DATA SR2/1.4142136D0/
28207 DATA KFNCHI/1000022,1000023,1000025,1000035/
28208 DATA KFCCHI/1000024,1000037/
28210 C...COUNT THE NUMBER OF DECAY MODES
28218 TANW = SQRT(XW/(1D0-XW))
28220 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
28223 IF(KFIN.EQ.KFNCHI(2)) IX=2
28224 IF(KFIN.EQ.KFNCHI(3)) IX=3
28225 IF(KFIN.EQ.KFNCHI(4)) IX=4
28243 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
28244 IF(IX.EQ.1.AND.IMSS(11).EQ.0) THEN
28248 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
28249 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
28253 GAMCON=AEM**3/8D0/PI/XMW2/XW
28254 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28255 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28256 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28257 IDLAM(LKNT,1)=KSUSY1+22
28260 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
28264 C...GRAVITINO DECAY MODES
28266 IF(IMSS(11).EQ.1) THEN
28269 XMGR=PMAS(PYCOMP(IDG),1)
28272 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
28273 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
28278 XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2
28280 IF(AXMI.GT.XMGR+XMZ) THEN
28285 XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 +
28286 $ .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4
28288 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
28293 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)*
28294 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
28296 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
28301 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)*
28302 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
28304 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
28309 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)*
28310 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
28319 C...CHI0_I -> CHI0_J + GAMMA
28320 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
28321 RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2
28322 RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 )
28323 RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2
28324 RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 )
28325 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
28326 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
28328 IDLAM(LKNT,1)=KFNCHI(IJ)
28331 GAMCON=AEM**3/8D0/PI/XMW2/XW
28332 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28333 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28334 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28338 C...CHI0_I -> CHI0_J + Z0
28339 IF(AXMI.GE.AXMJ+XMZ) THEN
28341 GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28343 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
28344 IDLAM(LKNT,1)=KFNCHI(IJ)
28347 ELSEIF(AXMI.GE.AXMJ) THEN
28355 XXM(5)=PMAS(PYCOMP(KSUSY1+11),1)
28356 XXM(6)=PMAS(PYCOMP(KSUSY2+11),1)
28359 XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28361 XXM(11)=(T3-EI*XW)/(1D0-XW)
28362 XXM(12)=-EI*XW/(1D0-XW)
28363 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28364 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28365 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28366 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28368 S12MAX=(AXMI-AXMJ)**2
28370 C...CHARGED LEPTONS
28371 IF( XXM(5).LT.AXMI ) THEN
28374 IF(XXM(6).LT.AXMI ) THEN
28377 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
28379 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28380 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28381 IDLAM(LKNT,1)=KFNCHI(IJ)
28384 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
28386 XLAM(LKNT)=XLAM(LKNT-1)
28387 IDLAM(LKNT,1)=KFNCHI(IJ)
28393 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28394 XXM(5)=PMAS(PYCOMP(KSUSY1+15),1)
28395 XXM(6)=PMAS(PYCOMP(KSUSY2+15),1)
28397 XXM(6)=PMAS(PYCOMP(KSUSY1+15),1)
28398 XXM(5)=PMAS(PYCOMP(KSUSY2+15),1)
28400 IF( XXM(5).LT.AXMI ) THEN
28403 IF(XXM(6).LT.AXMI ) THEN
28407 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
28409 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28410 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28411 IDLAM(LKNT,1)=KFNCHI(IJ)
28421 XXM(5)=PMAS(PYCOMP(KSUSY1+12),1)
28423 XXM(11)=(T3-EI*XW)/(1D0-XW)
28424 XXM(12)=-EI*XW/(1D0-XW)
28425 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28426 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28427 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28428 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28430 IF( XXM(5).LT.AXMI ) THEN
28435 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28436 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28437 IDLAM(LKNT,1)=KFNCHI(IJ)
28441 XLAM(LKNT)=XLAM(LKNT-1)
28442 IDLAM(LKNT,1)=KFNCHI(IJ)
28446 XXM(5)=PMAS(PYCOMP(KSUSY1+16),1)
28447 IF( XXM(5).LT.AXMI ) THEN
28451 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28452 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28453 IDLAM(LKNT,1)=KFNCHI(IJ)
28459 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28460 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28465 XXM(11)=(T3-EI*XW)/(1D0-XW)
28466 XXM(12)=-EI*XW/(1D0-XW)
28467 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28468 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28469 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28470 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28472 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140
28473 IF( XXM(5).LT.AXMI ) THEN
28475 ELSEIF( XXM(6).LT.AXMI ) THEN
28478 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
28480 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28481 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28482 IDLAM(LKNT,1)=KFNCHI(IJ)
28485 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
28487 XLAM(LKNT)=XLAM(LKNT-1)
28488 IDLAM(LKNT,1)=KFNCHI(IJ)
28494 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
28495 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
28496 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
28498 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
28499 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
28501 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150
28502 IF(XXM(5).LT.AXMI) THEN
28504 ELSEIF(XXM(6).LT.AXMI) THEN
28507 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
28509 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28510 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28511 IDLAM(LKNT,1)=KFNCHI(IJ)
28518 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
28519 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
28524 XXM(11)=(T3-EI*XW)/(1D0-XW)
28525 XXM(12)=-EI*XW/(1D0-XW)
28526 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28527 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28528 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28529 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28531 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160
28532 IF(XXM(5).LT.AXMI) THEN
28534 ELSEIF(XXM(6).LT.AXMI) THEN
28537 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
28539 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28540 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28541 IDLAM(LKNT,1)=KFNCHI(IJ)
28544 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
28546 XLAM(LKNT)=XLAM(LKNT-1)
28547 IDLAM(LKNT,1)=KFNCHI(IJ)
28555 C...CHI0_I -> CHI0_J + H0_K
28563 QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)-
28564 & TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1))
28565 RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)-
28566 & TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1))
28569 XMH=PMAS(ITH(IH),1)
28571 IF(AXMI.GE.AXMJ+XMH) THEN
28573 XL=PYLAMF(XMI2,XMJ2,XMH2)
28574 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
28576 C...SIGN OF MASSES I,J
28578 IF(IH.EQ.3) XMK=-XMK
28579 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
28580 IDLAM(LKNT,1)=KFNCHI(IJ)
28581 IDLAM(LKNT,2)=ITH(IH)
28587 C...CHI0_I -> CHI+_J + W-
28592 IF(AXMI.GE.AXMJ+XMW) THEN
28594 GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28595 GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28596 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
28597 IDLAM(LKNT,1)=KFCCHI(IJ)
28601 XLAM(LKNT)=XLAM(LKNT-1)
28602 IDLAM(LKNT,1)=-KFCCHI(IJ)
28605 ELSEIF(AXMI.GE.AXMJ) THEN
28607 S12MAX=(AXMI-AXMJ)**2
28608 XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28609 XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28615 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28619 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28627 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
28628 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
28629 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190
28630 IF(XXM(11).LT.AXMI) THEN
28632 ELSEIF(XXM(12).LT.AXMI) THEN
28635 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
28637 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28638 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28639 IDLAM(LKNT,1)=KFCCHI(IJ)
28643 XLAM(LKNT)=XLAM(LKNT-1)
28644 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28645 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28646 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28647 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
28649 XLAM(LKNT)=XLAM(LKNT-1)
28650 IDLAM(LKNT,1)=KFCCHI(IJ)
28654 XLAM(LKNT)=XLAM(LKNT-1)
28655 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28656 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28657 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28661 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28662 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
28663 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28665 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
28666 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28669 IF(XXM(11).LT.AXMI) THEN
28672 IF(XXM(12).LT.AXMI) THEN
28675 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
28677 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28678 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28679 XLAM(LKNT)=XLAM(LKNT-1)
28680 IDLAM(LKNT,1)=KFCCHI(IJ)
28684 XLAM(LKNT)=XLAM(LKNT-1)
28685 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28686 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28687 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28690 C...NOW, DO THE QUARKS
28695 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28699 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28701 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
28702 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
28703 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210
28704 IF(XXM(11).LT.AXMI) THEN
28706 ELSEIF(XXM(12).LT.AXMI) THEN
28709 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
28711 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
28712 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28713 IDLAM(LKNT,1)=KFCCHI(IJ)
28717 XLAM(LKNT)=XLAM(LKNT-1)
28718 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28719 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28720 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28721 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
28723 XLAM(LKNT)=XLAM(LKNT-1)
28724 IDLAM(LKNT,1)=KFCCHI(IJ)
28728 XLAM(LKNT)=XLAM(LKNT-1)
28729 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28730 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28731 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28739 C...CHI0_I -> CHI+_I + H-
28746 IF(AXMI.GE.AXMJ+XMHP) THEN
28748 GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+
28749 & ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2)
28750 GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+
28751 & ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2)
28752 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
28753 IDLAM(LKNT,1)=KFCCHI(IJ)
28754 IDLAM(LKNT,2)=-ITHC
28757 XLAM(LKNT)=XLAM(LKNT-1)
28758 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28759 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28760 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28766 C...2-BODY DECAYS TO FERMION SFERMION
28768 IF(J.GE.7.AND.J.LE.10) GOTO 250
28771 XMSF1=PMAS(PYCOMP(KF1),1)
28772 XMSF2=PMAS(PYCOMP(KF2),1)
28782 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
28783 IF(MOD(J,2).EQ.0) THEN
28784 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28785 AL=XMF*ZMIX(IX,4)/XMW/SBETA
28786 AR=-2D0*EI*TANW*ZMIX(IX,1)
28789 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28790 AL=XMF*ZMIX(IX,3)/XMW/CBETA
28791 AR=-2D0*EI*TANW*ZMIX(IX,1)
28796 IF(AXMI.GE.XMF+XMSF1) THEN
28800 XL=PYLAMF(XMI2,XMA2,XMB2)
28801 CA=AL*SFMIX(J,1)+AR*SFMIX(J,2)
28802 CB=BL*SFMIX(J,1)+BR*SFMIX(J,2)
28803 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28804 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28809 XLAM(LKNT)=XLAM(LKNT-1)
28810 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28811 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28816 IF(AXMI.GE.XMF+XMSF2) THEN
28820 CA=AL*SFMIX(J,3)+AR*SFMIX(J,4)
28821 CB=BL*SFMIX(J,3)+BR*SFMIX(J,4)
28822 XL=PYLAMF(XMI2,XMA2,XMB2)
28823 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28824 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28829 XLAM(LKNT)=XLAM(LKNT-1)
28830 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28831 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28836 C...3-BODY DECAY TO Q Q~ GLUINO
28837 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
28838 IF(AXMI.GE.XMJ) THEN
28844 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28845 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28851 S12MAX=(AXMI-AXMJ)**2
28852 C...ALL QUARKS BUT T
28856 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
28858 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
28859 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 260
28860 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
28862 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
28863 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28864 IDLAM(LKNT,1)=KSUSY1+21
28867 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
28869 XLAM(LKNT)=XLAM(LKNT-1)
28870 IDLAM(LKNT,1)=KSUSY1+21
28876 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
28877 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
28878 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
28880 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
28881 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
28883 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270
28884 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
28886 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
28887 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28888 IDLAM(LKNT,1)=KSUSY1+21
28894 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
28895 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
28897 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
28899 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
28900 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280
28901 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
28903 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
28904 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28905 IDLAM(LKNT,1)=KSUSY1+21
28908 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
28910 XLAM(LKNT)=XLAM(LKNT-1)
28911 IDLAM(LKNT,1)=KSUSY1+21
28922 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
28923 XLAM(0)=XLAM(0)+XLAM(I)
28925 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
28930 C*********************************************************************
28933 C...Calculate decay widths for the charginos (admixtures of
28934 C...charged Wino and charged Higgsino.
28936 C...Input: KCIN = KF code for particle
28937 C...Output: XLAM = widths
28938 C... IDLAM = KF codes for decay particles
28939 C... IKNT = number of decay channels defined
28940 C...AUTHOR: STEPHEN MRENNA
28942 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
28943 C...when CHIENU .NE. 0
28945 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
28947 C...Double precision and integer declarations.
28948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28949 INTEGER PYK,PYCHGE,PYCOMP
28950 C...Parameter statement to help give large particle numbers.
28951 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28954 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28955 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28956 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28958 COMMON/PYINTS/XXM(20)
28959 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
28961 C...Local variables.
28963 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
28964 &XMZ,XMZ2,AXMJ,AXMI
28965 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
28966 DOUBLE PRECISION S12MIN,S12MAX
28967 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
28968 DOUBLE PRECISION PYLAMF,XL
28969 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
28970 DOUBLE PRECISION PYX2XH,PYX2XG
28971 DOUBLE PRECISION XLAM(0:200)
28972 INTEGER IDLAM(200,3)
28973 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
28976 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
28977 DOUBLE PRECISION SR2
28978 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
28980 DOUBLE PRECISION PYALEM,PI,PYALPS
28981 DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
28982 DOUBLE PRECISION CA,CB,FCOL
28983 INTEGER KF1,KF2,ISF
28984 INTEGER KFNCHI(4),KFCCHI(2)
28986 DOUBLE PRECISION TEMP
28987 DOUBLE PRECISION PYGAUS
28988 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
28989 DOUBLE PRECISION PREC
28992 DATA ETAH/1D0,1D0,-1D0/
28993 DATA SR2/1.4142136D0/
28994 DATA PI/3.141592654D0/
28996 DATA KFNCHI/1000022,1000023,1000025,1000035/
28997 DATA KFCCHI/1000024,1000037/
28999 C...COUNT THE NUMBER OF DECAY MODES
29006 TANW = SQRT(XW/(1D0-XW))
29008 C...1 OR 2 DEPENDING ON CHARGINO TYPE
29010 IF(KFIN.EQ.KFCCHI(2)) IX=2
29026 C...GRAVITINO DECAY MODES
29028 IF(IMSS(11).EQ.1) THEN
29031 XMGR=PMAS(PYCOMP(IDG),1)
29034 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
29035 IF(AXMI.GT.XMGR+XMW) THEN
29040 XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+
29041 & .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))*
29042 & (1D0-XMW2/XMI2)**4
29044 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
29049 XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+
29050 & (UMIX(IX,2)*SBETA)**2))
29051 & *(1D0-PMAS(37,1)**2/XMI2)**4
29055 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
29056 IF(IX.EQ.1) GOTO 150
29061 C...CHI_2+ -> CHI_1+ + Z0
29062 IF(AXMI.GE.AXMJ+XMZ) THEN
29064 GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)
29065 GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)
29066 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
29067 IDLAM(LKNT,1)=KFCCHI(1)
29071 C...CHARGED LEPTONS
29072 ELSEIF(AXMI.GE.AXMJ) THEN
29073 XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2))
29074 XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2))
29082 S12MAX=(AXMJ-AXMI)**2
29083 XXM(7)= (-0.5D0+XW)/(1D0-XW)
29084 XXM(8)= XW/(1D0-XW)
29085 XXM(11)=PMAS(PYCOMP(KSUSY1+12),1)
29086 XXM(12)=VMIX(2,1)*VMIX(1,1)
29087 IF( XXM(11).LT.AXMI ) THEN
29090 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
29092 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29093 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29094 IDLAM(LKNT,1)=KFCCHI(1)
29097 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
29099 XLAM(LKNT)=XLAM(LKNT-1)
29100 IDLAM(LKNT,1)=KFCCHI(1)
29103 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
29105 XLAM(LKNT)=XLAM(LKNT-1)
29106 IDLAM(LKNT,1)=KFCCHI(1)
29115 XXM(7)= (0.5D0)/(1D0-XW)
29117 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29118 XXM(12)=UMIX(2,1)*UMIX(1,1)
29119 IF( XXM(11).LT.AXMI ) THEN
29122 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
29124 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29125 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29126 IDLAM(LKNT,1)=KFCCHI(1)
29130 XLAM(LKNT)=XLAM(LKNT-1)
29131 IDLAM(LKNT,1)=KFCCHI(1)
29135 XLAM(LKNT)=XLAM(LKNT-1)
29136 IDLAM(LKNT,1)=KFCCHI(1)
29143 XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW)
29144 XXM(8)= XW/3D0/(1D0-XW)
29145 XXM(11)=PMAS(PYCOMP(KSUSY1+2),1)
29146 XXM(12)=VMIX(2,1)*VMIX(1,1)
29147 IF( XXM(11).LT.AXMI ) GOTO 120
29148 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
29150 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29151 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29152 IDLAM(LKNT,1)=KFCCHI(1)
29155 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
29157 XLAM(LKNT)=XLAM(LKNT-1)
29158 IDLAM(LKNT,1)=KFCCHI(1)
29161 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
29163 XLAM(LKNT)=XLAM(LKNT-1)
29164 IDLAM(LKNT,1)=KFCCHI(1)
29173 XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW)
29174 XXM(8)= -2D0*XW/3D0/(1D0-XW)
29175 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29176 XXM(12)=UMIX(2,1)*UMIX(1,1)
29177 IF( XXM(11).LT.AXMI ) GOTO 130
29178 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
29180 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29181 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29182 IDLAM(LKNT,1)=KFCCHI(1)
29185 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
29187 XLAM(LKNT)=XLAM(LKNT-1)
29188 IDLAM(LKNT,1)=KFCCHI(1)
29196 C...CHI_2+ -> CHI_1+ + H0_K
29204 XMH=PMAS(ITH(IH),1)
29206 C...NO 3-BODY OPTION
29207 IF(AXMI.GE.AXMJ+XMH) THEN
29209 XL=PYLAMF(XMI2,XMJ2,XMH2)
29210 F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) -
29211 & VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2
29212 F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) -
29213 & VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2
29215 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
29216 IDLAM(LKNT,1)=KFCCHI(1)
29217 IDLAM(LKNT,2)=ITH(IH)
29222 C...CHI1 JUMPS TO HERE
29225 C...CHI+_I -> CHI0_J + W+
29230 IF(AXMI.GE.AXMJ+XMW) THEN
29232 GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2
29233 GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2
29234 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
29235 IDLAM(LKNT,1)=KFNCHI(IJ)
29240 ELSEIF(AXMI.GE.AXMJ) THEN
29243 S12MIN=(XMF1+XMF2)**2
29244 S12MAX=(AXMJ-AXMI)**2
29245 XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1)
29246 XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1)
29250 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29254 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29262 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29263 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
29265 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
29266 C...--> 1/(16PI)/M**3*(AEM/XW)**2
29268 IF(XXM(11).LT.AXMI) THEN
29271 IF(XXM(12).LT.AXMI) THEN
29274 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
29276 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29277 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29278 IDLAM(LKNT,1)=KFNCHI(IJ)
29282 C...ONLY DECAY CHI+1 -> E+ NU_E
29283 IF( IMSS(12).NE. 0 ) GOTO 220
29284 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
29286 XXM(11)=PMAS(PYCOMP(KSUSY1+13),1)
29287 XXM(12)=PMAS(PYCOMP(KSUSY1+14),1)
29288 IF(XXM(11).LT.AXMI) THEN
29290 ELSEIF(XXM(12).LT.AXMI) THEN
29293 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29294 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29295 IDLAM(LKNT,1)=KFNCHI(IJ)
29298 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
29300 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
29301 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
29303 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
29305 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
29306 IF(XXM(11).LT.AXMI) THEN
29309 IF(XXM(12).LT.AXMI) THEN
29312 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29313 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29314 IDLAM(LKNT,1)=KFNCHI(IJ)
29321 C...NOW, DO THE QUARKS
29326 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29330 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29332 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29333 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29334 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170
29335 IF(XXM(11).LT.AXMI) THEN
29337 ELSEIF(XXM(12).LT.AXMI) THEN
29340 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29342 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29343 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29344 IDLAM(LKNT,1)=KFNCHI(IJ)
29347 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29349 XLAM(LKNT)=XLAM(LKNT-1)
29350 IDLAM(LKNT,1)=KFNCHI(IJ)
29359 C...CHI+_I -> CHI0_J + H+
29366 IF(AXMI.GE.AXMJ+XMHP) THEN
29368 GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+
29369 & ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2)
29370 GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+
29371 & ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2)
29372 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
29373 IDLAM(LKNT,1)=KFNCHI(IJ)
29381 C...2-BODY DECAYS TO FERMION SFERMION
29383 IF(J.GE.7.AND.J.LE.10) GOTO 200
29384 IF(MOD(J,2).EQ.0) THEN
29390 XMSF1=PMAS(PYCOMP(KF1),1)
29391 XMSF2=PMAS(PYCOMP(KF2),1)
29400 IF(MOD(J,2).EQ.0) THEN
29403 BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2
29404 AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2
29410 BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2
29412 AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2
29417 IF(AXMI.GE.XMF+XMSF1) THEN
29421 XL=PYLAMF(XMI2,XMA2,XMB2)
29422 CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2)
29423 CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2)
29424 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29425 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29427 IF(MOD(J,2).EQ.0) THEN
29437 IF(AXMI.GE.XMF+XMSF2) THEN
29441 CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4)
29442 CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4)
29443 XL=PYLAMF(XMI2,XMA2,XMB2)
29444 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29445 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29447 IF(MOD(J,2).EQ.0) THEN
29457 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
29458 C...A 2-BODY -- 2-BODY CHAIN
29459 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
29460 IF(AXMI.GE.XMJ) THEN
29463 S12MAX=(AXMI-AXMJ)**2
29472 XXM(7)=UMIX(IX,1)*SR2
29473 XXM(8)=VMIX(IX,1)*SR2
29474 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29475 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29476 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210
29477 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29479 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
29480 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29481 IDLAM(LKNT,1)=KSUSY1+21
29484 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29486 XLAM(LKNT)=XLAM(LKNT-1)
29487 IDLAM(LKNT,1)=KSUSY1+21
29498 XLAM(0)=XLAM(0)+XLAM(I)
29499 IF(XLAM(I).LT.0D0) THEN
29500 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
29501 & (IDLAM(I,J),J=1,3)
29505 IF(XLAM(0).EQ.0D0) THEN
29507 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
29508 WRITE(MSTU(11),*) LKNT
29509 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
29515 C*********************************************************************
29518 C...Calculates chi0 -> chi0 + f + ~f.
29522 C...Double precision and integer declarations.
29523 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29524 INTEGER PYK,PYCHGE,PYCOMP
29525 C...Parameter statement to help give large particle numbers.
29526 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29528 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29529 COMMON/PYINTS/XXM(20)
29530 SAVE /PYDAT1/,/PYINTS/
29532 C...Local variables.
29533 DOUBLE PRECISION PYXXZ5,X
29534 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
29535 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
29536 DOUBLE PRECISION SIJ
29537 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
29538 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
29539 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29541 DATA SR2/1.4142136D0/
29543 C...Statement functions.
29544 C...Integral from x to y of (t-a)(b-t) dt.
29545 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29546 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29547 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29548 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29549 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29550 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29551 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29552 C...Integral from x to y of (t-a)/(b-t) dt.
29553 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29554 C...Integral from x to y of 1/(t-a) dt.
29555 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29563 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29564 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29565 &( (X-XM22-S)**2 -4D0*XM22*S ) )
29567 S23MIN=(S23AVE-S23DEL)
29568 S23MAX=(S23AVE+S23DEL)
29587 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
29588 SIJ=2D0*XXM(2)*XXM(4)*S13
29590 IF(XMV.LE.1000D0) THEN
29591 WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S)
29592 & +SIJ*(S23MAX-S23MIN) )/WPROP2
29593 IF(XXM(5).LE.10000D0) THEN
29594 WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29595 & + SIJ*TPROP(S23MAX,S23MIN,XMSD) )
29596 WFL1=WFL1*(S13-XMV**2)/WPROP2
29600 IF(XXM(6).LE.10000D0) THEN
29601 WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29602 & + SIJ*TPROP(S23MAX,S23MIN,XMSU) )
29603 WFL2=WFL2*(S13-XMV**2)/WPROP2
29612 IF(XXM(5).LE.10000D0) THEN
29613 WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29614 & + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) )
29618 IF(XXM(6).LE.10000D0) THEN
29619 WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29620 & + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) )
29627 PYXXZ5=(WW+WF1+WF2+WFL1+WFL2)
29628 IF(PYXXZ5.LT.0D0) THEN
29629 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 '
29630 WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4)
29631 WRITE(MSTU(11),*) (XXM(I),I=5,8)
29632 WRITE(MSTU(11),*) (XXM(I),I=9,12)
29633 WRITE(MSTU(11),*) (XXM(I),I=13,16)
29634 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
29635 WRITE(MSTU(11),*) S23MIN,S23MAX
29642 C*********************************************************************
29645 C...Calculates chi0(+) -> chi+(0) + f + ~f'.
29649 C...Double precision and integer declarations.
29650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29651 INTEGER PYK,PYCHGE,PYCOMP
29652 C...Parameter statement to help give large particle numbers.
29653 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29655 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29656 COMMON/PYINTS/XXM(20)
29657 SAVE /PYDAT1/,/PYINTS/
29659 C...Local variables.
29660 DOUBLE PRECISION PYXXW5,X
29661 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
29662 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
29663 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
29664 DOUBLE PRECISION SIJ
29665 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29669 DATA SR2/1.4142136D0/
29671 C...Statement functions.
29672 C...Integral from x to y of (t-a)(b-t) dt.
29673 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29674 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29675 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29676 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29677 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29678 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29679 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29680 C...Integral from x to y of (t-a)/(b-t) dt.
29681 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29682 C...Integral from x to y of 1/(t-a) dt.
29683 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29690 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
29691 S23AVE=0.5D0*(XM22+S-S13)
29692 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
29694 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29695 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29696 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
29698 S23MIN=(S23AVE-S23DEL)
29699 S23MAX=(S23AVE+S23DEL)
29700 IF(S23DEL.LT.1D-3) THEN
29713 WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2)
29714 SIJ=S13*XXM(2)*XXM(4)
29715 IF(XMV.LE.1000D0) THEN
29716 WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S)
29717 & -2D0*OL*OR*SIJ*(S23MAX-S23MIN)
29719 IF(XXM(11).LE.10000D0) THEN
29720 WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD)
29721 & -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29723 WWD=WWD*(S13-XMV**2)/WPROP2
29727 IF(XXM(12).LE.10000D0) THEN
29728 WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU)
29729 & -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29731 WWU=WWU*(S13-XMV**2)/WPROP2
29740 IF(XXM(12).LE.10000D0) THEN
29741 WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29745 IF(XXM(11).LE.10000D0) THEN
29746 WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29750 IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN
29751 WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU)
29756 PYXXW5=WW+WU+WD+WWU+WWD+WUD
29758 IF(PYXXW5.LT.0D0) THEN
29760 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 '
29761 WRITE(MSTU(11),*) WW,WU,WD
29762 WRITE(MSTU(11),*) WWD,WWU,WUD
29763 WRITE(MSTU(11),*) SQRT(S13)
29764 WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S)
29773 C*********************************************************************
29776 C...Calculates chi0_i -> chi0_j + gamma.
29778 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
29780 C...Double precision and integer declarations.
29781 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29782 INTEGER PYK,PYCHGE,PYCOMP
29784 C...Local variables.
29785 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
29786 DOUBLE PRECISION F1,F2
29788 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
29789 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
29790 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
29791 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
29796 C*********************************************************************
29799 C...Calculates the decay rate for ino -> ino + gauge boson.
29801 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
29803 C...Double precision and integer declarations.
29804 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29805 INTEGER PYK,PYCHGE,PYCOMP
29807 C...Local variables.
29808 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
29809 DOUBLE PRECISION XL,PYLAMF,C1
29810 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
29816 XL=PYLAMF(XMI2,XMJ2,XMV2)
29817 PYX2XG=C1/8D0/XMI3*SQRT(XL)
29818 &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
29819 &12D0*GL*GR*XM1*XM2*XMV2)
29824 C*********************************************************************
29827 C...Calculates the decay rate for ino -> ino + H.
29829 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR)
29831 C...Double precision and integer declarations.
29832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29833 INTEGER PYK,PYCHGE,PYCOMP
29835 C...Local variables.
29836 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
29837 DOUBLE PRECISION XL,PYLAMF,C1
29838 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
29844 XL=PYLAMF(XMI2,XMJ2,XMV2)
29845 PYX2XH=C1/8D0/XMI3*SQRT(XL)
29846 &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+
29847 &4D0*GL*GR*XM1*XM2)
29852 C*********************************************************************
29855 C...Calculates chi+ -> chi+ + f + ~f.
29859 C...Double precision and integer declarations.
29860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29861 INTEGER PYK,PYCHGE,PYCOMP
29862 C...Parameter statement to help give large particle numbers.
29863 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29865 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29866 COMMON/PYINTS/XXM(20)
29867 SAVE /PYDAT1/,/PYINTS/
29869 C...Local variables.
29870 DOUBLE PRECISION PYXXZ2,X
29871 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
29872 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
29873 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
29874 DOUBLE PRECISION SIJ
29875 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
29876 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29878 DATA SR2/1.4142136D0/
29880 C...Statement functions.
29881 C...Integral from x to y of (t-a)(b-t) dt.
29882 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29883 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29884 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29885 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29886 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29887 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29888 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29889 C...Integral from x to y of 1/(t-a) dt.
29890 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29897 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
29898 S23AVE=0.5D0*(XM22+S-S13)
29899 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
29901 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29902 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29903 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
29905 S23MIN=(S23AVE-S23DEL)
29906 S23MAX=(S23AVE+S23DEL)
29907 IF(S23DEL.LT.1D-3) THEN
29925 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
29926 SIJ=XXM(2)*XXM(4)*S13
29927 WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S)
29928 &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN)
29930 IF(XMSL.GT.1D4*S) THEN
29934 WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL)
29935 WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)-
29936 & OR*SIJ*TPROP(S23MAX,S23MIN,XMSL)
29937 WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2
29941 IF(PYXXZ2.LT.0D0) THEN
29942 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 '
29943 WRITE(MSTU(11),*) WW,WD,WWD
29944 WRITE(MSTU(11),*) S23MIN,S23MAX
29945 WRITE(MSTU(11),*) (XXM(I),I=1,4)
29946 WRITE(MSTU(11),*) (XXM(I),I=5,8)
29947 WRITE(MSTU(11),*) (XXM(I),I=9,12)
29954 C*********************************************************************
29957 C...Calculates the non-standard decay modes of the Higgs boson.
29959 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
29961 C...Double precision and integer declarations.
29962 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29963 INTEGER PYK,PYCHGE,PYCOMP
29964 C...Parameter statement to help give large particle numbers.
29965 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29967 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29968 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29969 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29970 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29971 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29973 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
29975 C...Local variables.
29977 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
29978 &XMZ,XMZ2,AXMJ,AXMI
29979 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
29980 DOUBLE PRECISION S12MIN,S12MAX
29981 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
29982 DOUBLE PRECISION PYLAMF,XL,CF,EI
29983 INTEGER IDU,IC,ILR,IFL
29984 DOUBLE PRECISION TANW,XW,AEM,C1,AS
29985 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
29986 DOUBLE PRECISION XLAM(0:200)
29987 INTEGER IDLAM(200,3)
29988 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
29990 INTEGER KFNCHI(4),KFCCHI(2)
29991 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
29992 DOUBLE PRECISION SR2
29993 DOUBLE PRECISION BETA,ALFA
29994 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
29995 DOUBLE PRECISION PYALEM,PI,PYALPS
29996 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
29997 DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
29998 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
29999 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
30000 DATA ITH/25,35,36,37/
30001 DATA ETAH/1D0,1D0,-1D0/
30002 DATA SR2/1.4142136D0/
30003 DATA PI/3.141592654D0/
30004 DATA KFNCHI/1000022,1000023,1000025,1000035/
30005 DATA KFCCHI/1000024,1000037/
30007 C...COUNT THE NUMBER OF DECAY MODES
30015 TANW = SQRT(XW/(1D0-XW))
30018 C...1 - 4 DEPENDING ON Higgs species.
30020 IF(KFIN.EQ.ITH(2)) IH=2
30021 IF(KFIN.EQ.ITH(3)) IH=3
30022 IF(KFIN.EQ.ITH(4)) IH=4
30044 IF(IH.EQ.4) GOTO 180
30046 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
30047 C...H0_K -> CHI0_I + CHI0_J
30060 IF(AXMI.GE.AXMJ+AXMK) THEN
30063 & EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2)
30064 & -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+
30065 & 0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2)
30066 & -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) )
30068 & EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2)
30069 & -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+
30070 & 0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2)
30071 & -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) )
30072 C...SIGN OF MASSES I,J
30074 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30075 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
30076 IDLAM(LKNT,1)=KFNCHI(IJ)
30077 IDLAM(LKNT,2)=KFNCHI(IK)
30083 C...H0_K -> CHI+_I CHI-_J
30090 IF(AXMI.GE.AXMJ+AXMK) THEN
30092 F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) -
30093 & VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2
30094 F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) -
30095 & VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2
30097 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30098 IDLAM(LKNT,1)=KFCCHI(IJ)
30099 IDLAM(LKNT,2)=-KFCCHI(IK)
30105 C...HIGGS TO SFERMION SFERMION
30107 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160
30109 XMJL=PMAS(PYCOMP(IJ),1)
30110 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
30111 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
30114 XL=PYLAMF(XMI2,XMJ2,XMJ2)
30121 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
30122 & XMF**2/XMW*SINA/CBETA
30123 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
30124 & XMF**2/XMW*SINA/CBETA
30126 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30128 ELSEIF(IFL.EQ.15) THEN
30129 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30135 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
30136 & XMF**2/XMW*COSA/SBETA
30137 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
30138 & XMF**2/XMW*COSA/SBETA
30140 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
30147 ELSEIF(IH.EQ.2) THEN
30149 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
30150 & XMF**2/XMW*COSA/CBETA
30151 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30152 & XMF**2/XMW*COSA/CBETA
30154 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30156 ELSEIF(IFL.EQ.15) THEN
30157 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30163 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
30164 & XMF**2/XMW*SINA/SBETA
30165 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30166 & XMF**2/XMW*SINA/SBETA
30168 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
30175 ELSEIF(IH.EQ.3) THEN
30181 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
30182 ELSEIF(IFL.EQ.15) THEN
30183 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
30187 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
30191 IF(IH.EQ.3) GOTO 140
30195 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
30202 IF(AXMI.GE.2D0*XMJ) THEN
30204 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30206 & +2D0*GHLR*ALR)**2
30212 IF(AXMI.GE.2D0*XMJR) THEN
30216 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
30219 XL=PYLAMF(XMI2,XMJ2,XMJ2)
30220 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30222 & +2D0*GHLR*ALR)**2
30223 IDLAM(LKNT,1)=IJ+KSUSY1
30224 IDLAM(LKNT,2)=-(IJ+KSUSY1)
30229 IF(AXMI.GE.XMJL+XMJR) THEN
30231 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
30232 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
30233 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
30236 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
30237 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30238 & (GHLL*AL+GHRR*AR)**2
30240 IDLAM(LKNT,2)=-(IJ+KSUSY1)
30244 IDLAM(LKNT,2)=IJ+KSUSY1
30246 XLAM(LKNT)=XLAM(LKNT-1)
30256 C...H+ -> CHI+_I + CHI0_J
30265 IF(AXMI.GE.AXMJ+AXMK) THEN
30267 GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)*
30268 & TANW)*VMIX(IK,2)/SR2)
30269 GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)*
30270 & TANW)*UMIX(IK,2)/SR2)
30271 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR)
30272 IDLAM(LKNT,1)=KFNCHI(IJ)
30273 IDLAM(LKNT,2)=KFCCHI(IK)
30279 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
30280 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
30286 XM1=PMAS(PYCOMP(KSUSY1+6),1)
30287 XM2=PMAS(PYCOMP(KSUSY1+5),1)
30288 IF(XMI.GE.XM1+XM2) THEN
30289 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30291 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30292 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
30293 IDLAM(LKNT,1)=KSUSY1+6
30294 IDLAM(LKNT,2)=-(KSUSY1+5)
30299 XM1=PMAS(PYCOMP(KSUSY2+6),1)
30300 XM2=PMAS(PYCOMP(KSUSY1+5),1)
30301 IF(XMI.GE.XM1+XM2) THEN
30302 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30304 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30305 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
30306 IDLAM(LKNT,1)=KSUSY2+6
30307 IDLAM(LKNT,2)=-(KSUSY1+5)
30312 XM1=PMAS(PYCOMP(KSUSY1+6),1)
30313 XM2=PMAS(PYCOMP(KSUSY2+5),1)
30314 IF(XMI.GE.XM1+XM2) THEN
30315 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30317 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30318 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
30319 IDLAM(LKNT,1)=KSUSY1+6
30320 IDLAM(LKNT,2)=-(KSUSY2+5)
30325 XM1=PMAS(PYCOMP(KSUSY2+6),1)
30326 XM2=PMAS(PYCOMP(KSUSY2+5),1)
30327 IF(XMI.GE.XM1+XM2) THEN
30328 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30330 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30331 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
30332 IDLAM(LKNT,1)=KSUSY2+6
30333 IDLAM(LKNT,2)=-(KSUSY2+5)
30338 GL=-XMW/SR2*SIN(2D0*BETA)
30340 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30341 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30342 IF(XMI.GE.XM1+XM2) THEN
30343 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30345 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30346 IDLAM(LKNT,1)=-(KSUSY1+IJ)
30347 IDLAM(LKNT,2)=KSUSY1+IJ+1
30355 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30356 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30357 IF(XMI.GE.XM1+XM2) THEN
30358 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30360 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30361 IDLAM(LKNT,1)=-(KSUSY1+IJ)
30362 IDLAM(LKNT,2)=KSUSY1+IJ+1
30367 C...H+ -> TAU1 NUTAUL
30368 XM1=PMAS(PYCOMP(KSUSY1+15),1)
30369 XM2=PMAS(PYCOMP(KSUSY1+16),1)
30370 IF(XMI.GE.XM1+XM2) THEN
30371 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30373 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2
30374 IDLAM(LKNT,1)=-(KSUSY1+15)
30375 IDLAM(LKNT,2)= KSUSY1+16
30379 C...H+ -> TAU2 NUTAUL
30380 XM1=PMAS(PYCOMP(KSUSY2+15),1)
30381 XM2=PMAS(PYCOMP(KSUSY1+16),1)
30382 IF(XMI.GE.XM1+XM2) THEN
30383 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30385 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2
30386 IDLAM(LKNT,1)=-(KSUSY2+15)
30387 IDLAM(LKNT,2)= KSUSY1+16
30395 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
30396 XLAM(0)=XLAM(0)+XLAM(I)
30398 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
30403 C*********************************************************************
30406 C...Calculates the decay rate for a Higgs to an ino pair.
30408 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR)
30410 C...Double precision and integer declarations.
30411 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30412 INTEGER PYK,PYCHGE,PYCOMP
30414 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30417 C...Local variables.
30418 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
30419 DOUBLE PRECISION XL,PYLAMF,C1
30420 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
30426 XL=PYLAMF(XMI2,XMJ2,XMK2)
30427 PYH2XX=C1/4D0/XMI3*SQRT(XL)
30428 &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)-
30429 &4D0*GL*GR*XM3*XM2)
30430 IF(PYH2XX.LT.0D0) THEN
30431 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
30432 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3
30439 C*********************************************************************
30442 C...Integration by adaptive Gaussian quadrature.
30443 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
30445 FUNCTION PYGAUS(F, A, B, EPS)
30447 C...Double precision and integer declarations.
30448 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30449 INTEGER PYK,PYCHGE,PYCOMP
30451 C...Local declarations.
30453 DOUBLE PRECISION W(12), X(12)
30454 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
30455 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
30456 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
30457 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
30458 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
30459 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
30460 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
30461 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
30462 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
30463 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
30464 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
30465 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
30467 C...The Gaussian quadrature algorithm.
30469 IF(B .EQ. A) GO TO 140
30470 CONST = 5D-3 / ABS(B-A)
30481 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
30486 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
30489 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
30491 IF(BB .NE. B) GO TO 100
30494 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110
30496 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
30505 C*********************************************************************
30508 C...Simpson formula for an integral.
30510 FUNCTION PYSIMP(Y,X0,X1,N)
30512 C...Double precision and integer declarations.
30513 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30514 INTEGER PYK,PYCHGE,PYCOMP
30516 C...Local variables.
30517 DOUBLE PRECISION Y,X0,X1,H,S
30523 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
30530 C*********************************************************************
30533 C...The standard lambda function.
30535 FUNCTION PYLAMF(X,Y,Z)
30537 C...Double precision and integer declarations.
30538 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30539 INTEGER PYK,PYCHGE,PYCOMP
30541 C...Local variables.
30542 DOUBLE PRECISION PYLAMF,X,Y,Z
30544 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
30545 IF(PYLAMF.LT.0D0) PYLAMF=0D0
30550 C*********************************************************************
30553 C...Generates 3-body decays of gauginos.
30555 SUBROUTINE PYTBDY(XM)
30557 C...Double precision and integer declarations.
30558 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30559 INTEGER PYK,PYCHGE,PYCOMP
30560 C...Parameter statement to help give large particle numbers.
30561 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30563 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30564 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30565 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30566 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
30567 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30568 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/
30570 C...Local variables.
30571 DOUBLE PRECISION XM(5)
30572 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
30573 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
30574 DOUBLE PRECISION CPHI1,SPHI1
30575 DOUBLE PRECISION S23DEL,EPS
30576 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
30577 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
30578 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
30582 S12MIN=(XM(1)+XM(2))**2
30583 S12MAX=(XM(5)-XM(3))**2
30584 YJACO1=S12MAX-S12MIN
30589 BX=S12MIN+0.5D0*YJACO1
30592 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
30600 C...SOLVE FOR F1 AND F2
30601 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30602 &-(2D0*XM(1)*XM(2))**2
30603 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30604 &-(2D0*XM(3)*XM(5))**2
30607 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30609 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30610 &-(2D0*XM(1)*XM(2))**2
30611 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30612 &-(2D0*XM(3)*XM(5))**2
30615 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30618 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
30624 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30625 & -(2D0*XM(1)*XM(2))**2
30626 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30627 & -(2D0*XM(3)*XM(5))**2
30630 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30637 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30638 & -(2D0*XM(1)*XM(2))**2
30639 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30640 & -(2D0*XM(3)*XM(5))**2
30643 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30648 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
30658 110 S12=S12MIN+PYR(0)*YJACO1
30661 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
30662 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
30663 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
30664 &-(2D0*XM(1)*XM(2))**2
30665 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
30666 &-(2D0*XM(3)*XM(5))**2
30669 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12)
30671 S23MIN=S23AVE-S23DEL
30672 S23MAX=S23AVE+S23DEL
30673 YJACO2=S23MAX-S23MIN
30674 S23=S23MIN+PYR(0)*YJACO2
30676 C...CHECK THE SAMPLING
30677 IF(IKNT.GT.100) THEN
30678 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
30681 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110
30682 120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
30683 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
30685 P1=SQRT(D1*D1-XM(1)**2)
30686 P2=SQRT(D2*D2-XM(2)**2)
30687 P3=SQRT(D3*D3-XM(3)**2)
30688 CTHE1=2D0*PYR(0)-1D0
30689 ANG1=2D0*PYR(0)*PARU(1)
30693 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30695 P(N+1,1)=P1*STHE1*CPHI1
30696 P(N+1,2)=P1*STHE1*SPHI1
30701 ANG3=2D0*PYR(0)*PARU(1)
30704 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
30706 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30708 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
30709 &+P3*STHE3*SPHI3*SPHI1
30710 &+P3*CTHE3*STHE1*CPHI1
30711 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
30712 &-P3*STHE3*SPHI3*CPHI1
30713 &+P3*CTHE3*STHE1*SPHI1
30714 P(N+3,3)=P3*STHE3*CPHI3*STHE1
30719 P(N+2,I)=-P(N+1,I)-P(N+3,I)
30726 C*********************************************************************
30729 C...Stores one parton/particle in commonblock PYJETS.
30731 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
30733 C...Double precision and integer declarations.
30734 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30735 INTEGER PYK,PYCHGE,PYCOMP
30737 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30738 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30739 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30740 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30742 C...Standard checks.
30744 IF(MSTU(12).GE.1) CALL PYLIST(0)
30745 IPA=MAX(1,IABS(IP))
30746 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
30747 &'(PY1ENT:) writing outside PYJETS memory')
30749 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
30751 C...Find mass. Reset K, P and V vectors.
30753 IF(MSTU(10).EQ.1) PM=P(IPA,5)
30754 IF(MSTU(10).GE.2) PM=PYMASS(KF)
30761 C...Store parton/particle in K and P vectors.
30763 IF(IP.LT.0) K(IPA,1)=2
30766 P(IPA,4)=MAX(PE,PM)
30767 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
30768 P(IPA,1)=PA*SIN(THE)*COS(PHI)
30769 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
30770 P(IPA,3)=PA*COS(THE)
30772 C...Set N. Optionally fragment/decay.
30774 IF(IP.EQ.0) CALL PYEXEC
30779 C*********************************************************************
30782 C...Stores two partons/particles in their CM frame,
30783 C...with the first along the +z axis.
30785 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
30787 C...Double precision and integer declarations.
30788 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30789 INTEGER PYK,PYCHGE,PYCOMP
30791 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30792 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30793 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30794 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30796 C...Standard checks.
30798 IF(MSTU(12).GE.1) CALL PYLIST(0)
30799 IPA=MAX(1,IABS(IP))
30800 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
30801 &'(PY2ENT:) writing outside PYJETS memory')
30804 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
30805 &'(PY2ENT:) unknown flavour code')
30807 C...Find masses. Reset K, P and V vectors.
30809 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
30810 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
30812 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
30813 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
30822 C...Check flavours.
30823 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
30824 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
30825 IF(MSTU(19).EQ.1) THEN
30828 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
30829 & '(PY2ENT:) unphysical flavour combination')
30834 C...Store partons/particles in K vectors for normal case.
30837 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
30840 C...Store partons in K vectors for parton shower evolution.
30844 K(IPA,4)=MSTU(5)*(IPA+1)
30846 K(IPA+1,4)=MSTU(5)*IPA
30847 K(IPA+1,5)=K(IPA+1,4)
30850 C...Check kinematics and store partons/particles in P vectors.
30851 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
30852 &'(PY2ENT:) energy smaller than sum of masses')
30853 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
30856 P(IPA,4)=SQRT(PM1**2+PA**2)
30859 P(IPA+1,4)=SQRT(PM2**2+PA**2)
30862 C...Set N. Optionally fragment/decay.
30864 IF(IP.EQ.0) CALL PYEXEC
30869 C*********************************************************************
30872 C...Stores three partons or particles in their CM frame,
30873 C...with the first along the +z axis and the third in the (x,z)
30874 C...plane with x > 0.
30876 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
30878 C...Double precision and integer declarations.
30879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30880 INTEGER PYK,PYCHGE,PYCOMP
30882 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30883 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30884 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30885 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30887 C...Standard checks.
30889 IF(MSTU(12).GE.1) CALL PYLIST(0)
30890 IPA=MAX(1,IABS(IP))
30891 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
30892 &'(PY3ENT:) writing outside PYJETS memory')
30896 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
30897 &'(PY3ENT:) unknown flavour code')
30899 C...Find masses. Reset K, P and V vectors.
30901 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
30902 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
30904 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
30905 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
30907 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
30908 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
30917 C...Check flavours.
30918 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
30919 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
30920 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
30921 IF(MSTU(19).EQ.1) THEN
30923 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
30924 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
30925 & KQ1+KQ3.EQ.4)) THEN
30927 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
30933 C...Store partons/particles in K vectors for normal case.
30936 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
30938 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
30941 C...Store partons in K vectors for parton shower evolution.
30947 IF(KQ1.EQ.-1) KCS=5
30948 K(IPA,KCS)=MSTU(5)*(IPA+1)
30949 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
30950 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
30951 K(IPA+1,9-KCS)=MSTU(5)*IPA
30952 K(IPA+2,KCS)=MSTU(5)*IPA
30953 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
30956 C...Check kinematics.
30958 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
30959 &0.5D0*X3*PECM.LE.PM3) MKERR=1
30960 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
30961 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
30962 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
30963 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
30964 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
30965 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
30966 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
30967 IF(MKERR.NE.0) CALL PYERRM(13,
30968 &'(PY3ENT:) unphysical kinematical variable setup')
30970 C...Store partons/particles in P vectors.
30972 P(IPA,4)=SQRT(PA1**2+PM1**2)
30974 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
30975 P(IPA+2,3)=PA3*CTHE3
30976 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
30978 P(IPA+1,1)=-P(IPA+2,1)
30979 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
30980 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
30983 C...Set N. Optionally fragment/decay.
30985 IF(IP.EQ.0) CALL PYEXEC
30990 C*********************************************************************
30993 C...Stores four partons or particles in their CM frame, with
30994 C...the first along the +z axis, the last in the xz plane with x > 0
30995 C...and the second having y < 0 and y > 0 with equal probability.
30997 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
30999 C...Double precision and integer declarations.
31000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31001 INTEGER PYK,PYCHGE,PYCOMP
31003 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31004 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31005 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31006 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31008 C...Standard checks.
31010 IF(MSTU(12).GE.1) CALL PYLIST(0)
31011 IPA=MAX(1,IABS(IP))
31012 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
31013 &'(PY4ENT:) writing outside PYJETS momory')
31018 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
31019 &'(PY4ENT:) unknown flavour code')
31021 C...Find masses. Reset K, P and V vectors.
31023 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
31024 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
31026 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
31027 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31029 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
31030 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
31032 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
31033 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
31042 C...Check flavours.
31043 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31044 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31045 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
31046 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
31047 IF(MSTU(19).EQ.1) THEN
31049 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
31050 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
31051 & KQ1+KQ4.EQ.4)) THEN
31052 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
31055 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
31062 C...Store partons/particles in K vectors for normal case.
31065 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
31067 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
31070 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
31073 C...Store partons for parton shower evolution from q-g-g-qbar or
31075 ELSEIF(KQ1+KQ2.NE.0) THEN
31081 IF(KQ1.EQ.-1) KCS=5
31082 K(IPA,KCS)=MSTU(5)*(IPA+1)
31083 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
31084 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
31085 K(IPA+1,9-KCS)=MSTU(5)*IPA
31086 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
31087 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
31088 K(IPA+3,KCS)=MSTU(5)*IPA
31089 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
31091 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
31097 K(IPA,4)=MSTU(5)*(IPA+1)
31099 K(IPA+1,4)=MSTU(5)*IPA
31100 K(IPA+1,5)=K(IPA+1,4)
31101 K(IPA+2,4)=MSTU(5)*(IPA+3)
31102 K(IPA+2,5)=K(IPA+2,4)
31103 K(IPA+3,4)=MSTU(5)*(IPA+2)
31104 K(IPA+3,5)=K(IPA+3,4)
31107 C...Check kinematics.
31109 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
31110 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
31112 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
31113 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
31114 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
31115 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
31116 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
31117 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
31118 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
31119 STHE4=SQRT(1D0-CTHE4**2)
31120 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
31121 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
31122 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
31123 STHE2=SQRT(1D0-CTHE2**2)
31124 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
31125 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
31126 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
31127 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
31128 IF(MKERR.EQ.1) CALL PYERRM(13,
31129 &'(PY4ENT:) unphysical kinematical variable setup')
31131 C...Store partons/particles in P vectors.
31133 P(IPA,4)=SQRT(PA1**2+PM1**2)
31135 P(IPA+3,1)=PA4*STHE4
31136 P(IPA+3,3)=PA4*CTHE4
31137 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
31139 P(IPA+1,1)=PA2*STHE2*CPHI2
31140 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
31141 P(IPA+1,3)=PA2*CTHE2
31142 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
31144 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
31145 P(IPA+2,2)=-P(IPA+1,2)
31146 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
31147 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
31150 C...Set N. Optionally fragment/decay.
31152 IF(IP.EQ.0) CALL PYEXEC
31157 C*********************************************************************
31160 C...Connects a sequence of partons with colour flow indices,
31161 C...as required for subsequent shower evolution (or other operations).
31163 SUBROUTINE PYJOIN(NJOIN,IJOIN)
31165 C...Double precision and integer declarations.
31166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31167 INTEGER PYK,PYCHGE,PYCOMP
31169 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31170 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31171 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31172 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31176 C...Check that partons are of right types to be connected.
31177 IF(NJOIN.LT.2) GOTO 120
31181 IF(I.LE.0.OR.I.GT.N) GOTO 120
31182 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
31184 IF(KC.EQ.0) GOTO 120
31185 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
31186 IF(KQ.EQ.0) GOTO 120
31187 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
31188 IF(KQ.NE.2) KQSUM=KQSUM+KQ
31189 IF(IJN.EQ.1) KQS=KQ
31191 IF(KQSUM.NE.0) GOTO 120
31193 C...Connect the partons sequentially (closing for gluon loop).
31195 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
31199 IF(IJN.NE.1) IP=IJOIN(IJN-1)
31200 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
31201 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
31202 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
31203 K(I,KCS)=MSTU(5)*IN
31204 K(I,9-KCS)=MSTU(5)*IP
31205 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
31206 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
31209 C...Error exit: no action taken.
31211 120 CALL PYERRM(12,
31212 &'(PYJOIN:) given entries can not be joined by one string')
31217 C*********************************************************************
31220 C...Sets values of commonblock variables.
31222 SUBROUTINE PYGIVE(CHIN)
31224 C...Double precision and integer declarations.
31225 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31226 INTEGER PYK,PYCHGE,PYCOMP
31228 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31231 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31232 COMMON/PYDAT4/CHAF(500,2)
31234 COMMON/PYDATR/MRPY(6),RRPY(100)
31235 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31236 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31237 COMMON/PYINT1/MINT(400),VINT(400)
31238 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31239 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31240 COMMON/PYINT4/MWID(500),WIDS(500,5)
31241 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
31242 COMMON/PYINT6/PROC(0:500)
31244 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
31245 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
31247 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31248 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
31249 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
31250 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/
31251 C...Local arrays and character variables.
31252 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
31253 &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10,
31255 DIMENSION MSVAR(49,8)
31257 C...For each variable to be translated give: name,
31258 C...integer/real/character, no. of indices, lower&upper index bounds.
31259 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
31260 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
31261 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
31262 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
31263 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
31264 &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
31265 DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
31266 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
31267 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31268 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
31269 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
31270 &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
31271 &1,1,1,6,4*0, 2,1,1,100,4*0,
31272 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
31273 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31274 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
31275 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
31276 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
31277 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
31278 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
31279 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
31280 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
31281 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
31282 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
31284 C...Length of character variable. Subdivide it into instructions.
31285 IF(MSTU(12).GE.1) CALL PYLIST(0)
31289 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
31292 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
31294 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
31299 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
31301 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
31303 C...Identify commonblock variable.
31306 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
31307 &LNAM.LE.6) GOTO 140
31308 CHNAM=CHBIT(1:LNAM-1)//' '
31309 DO 160 LCOM=1,LNAM-1
31311 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
31312 & CHALP(2)(LALP:LALP)
31317 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
31320 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
31322 IF(LLOW.LT.LTOT) GOTO 120
31326 C...Identify any indices.
31331 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
31334 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
31336 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
31337 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17))
31339 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
31340 READ(CHIND,'(I8)') KF
31342 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
31344 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
31347 IF(LLOW.LT.LTOT) GOTO 120
31350 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31351 READ(CHIND,'(I8)') I1
31354 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31357 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31360 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
31362 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31363 READ(CHIND,'(I8)') I2
31365 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31368 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31371 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
31373 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31374 READ(CHIND,'(I8)') I3
31379 C...Check that indices allowed.
31381 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
31382 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
31384 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
31386 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
31388 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
31390 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
31393 IF(LLOW.LT.LTOT) GOTO 120
31397 C...Save old value of variable.
31400 ELSEIF(IVAR.EQ.2) THEN
31402 ELSEIF(IVAR.EQ.3) THEN
31404 ELSEIF(IVAR.EQ.4) THEN
31406 ELSEIF(IVAR.EQ.5) THEN
31408 ELSEIF(IVAR.EQ.6) THEN
31410 ELSEIF(IVAR.EQ.7) THEN
31412 ELSEIF(IVAR.EQ.8) THEN
31414 ELSEIF(IVAR.EQ.9) THEN
31416 ELSEIF(IVAR.EQ.10) THEN
31418 ELSEIF(IVAR.EQ.11) THEN
31420 ELSEIF(IVAR.EQ.12) THEN
31422 ELSEIF(IVAR.EQ.13) THEN
31424 ELSEIF(IVAR.EQ.14) THEN
31426 ELSEIF(IVAR.EQ.15) THEN
31428 ELSEIF(IVAR.EQ.16) THEN
31430 ELSEIF(IVAR.EQ.17) THEN
31432 ELSEIF(IVAR.EQ.18) THEN
31434 ELSEIF(IVAR.EQ.19) THEN
31436 ELSEIF(IVAR.EQ.20) THEN
31438 ELSEIF(IVAR.EQ.21) THEN
31440 ELSEIF(IVAR.EQ.22) THEN
31442 ELSEIF(IVAR.EQ.23) THEN
31444 ELSEIF(IVAR.EQ.24) THEN
31446 ELSEIF(IVAR.EQ.25) THEN
31448 ELSEIF(IVAR.EQ.26) THEN
31450 ELSEIF(IVAR.EQ.27) THEN
31452 ELSEIF(IVAR.EQ.28) THEN
31454 ELSEIF(IVAR.EQ.29) THEN
31456 ELSEIF(IVAR.EQ.30) THEN
31458 ELSEIF(IVAR.EQ.31) THEN
31460 ELSEIF(IVAR.EQ.32) THEN
31462 ELSEIF(IVAR.EQ.33) THEN
31463 IOLD=ICOL(I1,I2,I3)
31464 ELSEIF(IVAR.EQ.34) THEN
31466 ELSEIF(IVAR.EQ.35) THEN
31468 ELSEIF(IVAR.EQ.36) THEN
31470 ELSEIF(IVAR.EQ.37) THEN
31472 ELSEIF(IVAR.EQ.38) THEN
31474 ELSEIF(IVAR.EQ.39) THEN
31476 ELSEIF(IVAR.EQ.40) THEN
31478 ELSEIF(IVAR.EQ.41) THEN
31480 ELSEIF(IVAR.EQ.42) THEN
31481 ROLD=SIGT(I1,I2,I3)
31482 ELSEIF(IVAR.EQ.43) THEN
31484 ELSEIF(IVAR.EQ.44) THEN
31486 ELSEIF(IVAR.EQ.45) THEN
31488 ELSEIF(IVAR.EQ.46) THEN
31490 ELSEIF(IVAR.EQ.47) THEN
31492 ELSEIF(IVAR.EQ.48) THEN
31494 ELSEIF(IVAR.EQ.49) THEN
31498 C...Print current value of variable. Loop back.
31499 IF(LNAM.GE.LBIT) THEN
31501 CHBIT(15:60)=' has the value '
31502 IF(MSVAR(IVAR,1).EQ.1) THEN
31503 WRITE(CHBIT(51:60),'(I10)') IOLD
31504 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31505 WRITE(CHBIT(47:60),'(F14.5)') ROLD
31506 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31511 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31513 IF(LLOW.LT.LTOT) GOTO 120
31517 C...Read in new variable value.
31518 IF(MSVAR(IVAR,1).EQ.1) THEN
31520 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
31521 READ(CHINI,'(I10)') INEW
31522 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31524 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
31526 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31527 CHNEW=CHBIT(LNAM+1:LBIT)//' '
31529 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
31532 C...Store new variable value.
31535 ELSEIF(IVAR.EQ.2) THEN
31537 ELSEIF(IVAR.EQ.3) THEN
31539 ELSEIF(IVAR.EQ.4) THEN
31541 ELSEIF(IVAR.EQ.5) THEN
31543 ELSEIF(IVAR.EQ.6) THEN
31545 ELSEIF(IVAR.EQ.7) THEN
31547 ELSEIF(IVAR.EQ.8) THEN
31549 ELSEIF(IVAR.EQ.9) THEN
31551 ELSEIF(IVAR.EQ.10) THEN
31553 ELSEIF(IVAR.EQ.11) THEN
31555 ELSEIF(IVAR.EQ.12) THEN
31557 ELSEIF(IVAR.EQ.13) THEN
31559 ELSEIF(IVAR.EQ.14) THEN
31561 ELSEIF(IVAR.EQ.15) THEN
31563 ELSEIF(IVAR.EQ.16) THEN
31565 ELSEIF(IVAR.EQ.17) THEN
31567 ELSEIF(IVAR.EQ.18) THEN
31569 ELSEIF(IVAR.EQ.19) THEN
31571 ELSEIF(IVAR.EQ.20) THEN
31573 ELSEIF(IVAR.EQ.21) THEN
31575 ELSEIF(IVAR.EQ.22) THEN
31577 ELSEIF(IVAR.EQ.23) THEN
31579 ELSEIF(IVAR.EQ.24) THEN
31581 ELSEIF(IVAR.EQ.25) THEN
31583 ELSEIF(IVAR.EQ.26) THEN
31585 ELSEIF(IVAR.EQ.27) THEN
31587 ELSEIF(IVAR.EQ.28) THEN
31589 ELSEIF(IVAR.EQ.29) THEN
31591 ELSEIF(IVAR.EQ.30) THEN
31593 ELSEIF(IVAR.EQ.31) THEN
31595 ELSEIF(IVAR.EQ.32) THEN
31597 ELSEIF(IVAR.EQ.33) THEN
31598 ICOL(I1,I2,I3)=INEW
31599 ELSEIF(IVAR.EQ.34) THEN
31601 ELSEIF(IVAR.EQ.35) THEN
31603 ELSEIF(IVAR.EQ.36) THEN
31605 ELSEIF(IVAR.EQ.37) THEN
31607 ELSEIF(IVAR.EQ.38) THEN
31609 ELSEIF(IVAR.EQ.39) THEN
31611 ELSEIF(IVAR.EQ.40) THEN
31613 ELSEIF(IVAR.EQ.41) THEN
31615 ELSEIF(IVAR.EQ.42) THEN
31616 SIGT(I1,I2,I3)=RNEW
31617 ELSEIF(IVAR.EQ.43) THEN
31619 ELSEIF(IVAR.EQ.44) THEN
31621 ELSEIF(IVAR.EQ.45) THEN
31623 ELSEIF(IVAR.EQ.46) THEN
31625 ELSEIF(IVAR.EQ.47) THEN
31627 ELSEIF(IVAR.EQ.48) THEN
31629 ELSEIF(IVAR.EQ.49) THEN
31633 C...Write old and new value. Loop back.
31635 CHBIT(15:60)=' changed from to '
31636 IF(MSVAR(IVAR,1).EQ.1) THEN
31637 WRITE(CHBIT(33:42),'(I10)') IOLD
31638 WRITE(CHBIT(51:60),'(I10)') INEW
31639 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31640 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31641 WRITE(CHBIT(29:42),'(F14.5)') ROLD
31642 WRITE(CHBIT(47:60),'(F14.5)') RNEW
31643 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31644 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31647 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31649 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
31650 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
31653 IF(LLOW.LT.LTOT) GOTO 120
31655 C...Format statement for output on unit MSTU(11) (by default 6).
31656 5000 FORMAT(5X,A60)
31657 5100 FORMAT(5X,A88)
31662 C*********************************************************************
31665 C...Administrates the fragmentation and decay chain.
31669 C...Double precision and integer declarations.
31670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31671 INTEGER PYK,PYCHGE,PYCOMP
31673 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31676 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31677 COMMON/PYINT4/MWID(500),WIDS(500,5)
31678 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
31680 DIMENSION PS(2,6),IJOIN(100)
31682 C...Initialize and reset.
31684 IF(MSTU(12).GE.1) CALL PYLIST(0)
31685 MSTU(31)=MSTU(31)+1
31689 IF(MSTU(17).LE.0) MSTU(90)=0
31692 C...Sum up momentum, energy and charge for starting entries.
31700 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
31702 PS(1,J)=PS(1,J)+P(I,J)
31704 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
31708 C...Prepare system for subsequent fragmentation/decay.
31711 C...Loop through jet fragmentation and particle decays.
31717 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
31720 C...Deal with any remaining undecayed resonance
31721 C...(normally the task of PYEVNT, so seldom used).
31722 ELSEIF(MWID(KC).NE.0) THEN
31724 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
31727 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
31728 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
31731 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
31732 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
31735 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
31744 C...Particle decay if unstable and allowed. Save long-lived particle
31745 C...decays until second pass after Bose-Einstein effects.
31746 ELSEIF(KCHG(KC,2).EQ.0) THEN
31747 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
31748 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
31751 C...Decay products may develop a shower.
31752 IF(MSTJ(92).GT.0) THEN
31754 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
31755 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
31756 CALL PYSHOW(IP1,IP1+1,QMAX)
31759 ELSEIF(MSTJ(92).LT.0) THEN
31761 CALL PYSHOW(IP1,-3,P(IP,5))
31766 C...Jet fragmentation: string or independent fragmentation.
31767 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
31769 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
31770 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
31771 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
31772 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
31773 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
31776 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
31777 IF(MFRAG.EQ.2) CALL PYINDF(IP)
31778 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
31779 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
31782 C...Loop back if enough space left in PYJETS and no error abort.
31783 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
31784 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
31786 ELSEIF(IP.LT.N) THEN
31787 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
31790 C...Include simple Bose-Einstein effect parametrization if desired.
31791 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
31796 C...Check that momentum, energy and charge were conserved.
31798 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
31800 PS(2,J)=PS(2,J)+P(I,J)
31802 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
31804 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
31805 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
31806 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
31807 &'(PYEXEC:) four-momentum was not conserved')
31808 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
31809 &'(PYEXEC:) charge was not conserved')
31814 C*********************************************************************
31817 C...Rearranges partons along strings. Allows small systems
31818 C...to collapse into one or two particles and checks flavours.
31820 SUBROUTINE PYPREP(IP)
31822 C...Double precision and integer declarations.
31823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31824 INTEGER PYK,PYCHGE,PYCOMP
31826 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31827 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31828 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31829 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31830 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
31832 DIMENSION DPS(5),DPC(5),UE(3)
31834 C...Rearrange parton shower product listing along strings: begin loop.
31837 DO 120 I=MAX(1,IP),N
31838 IF(K(I,1).NE.3) GOTO 120
31840 IF(KC.EQ.0) GOTO 120
31842 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
31844 C...Pick up loose string end.
31846 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
31850 IF(NSTP.GT.4*N) THEN
31851 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
31855 C...Copy undecayed parton.
31856 IF(K(IA,1).EQ.3) THEN
31857 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
31858 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
31863 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
31873 IF(K(I1,1).EQ.1) GOTO 120
31876 C...Go to next parton in colour space.
31878 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
31880 IA=MOD(K(IB,KCS),MSTU(5))
31881 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
31884 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
31885 & MSTU(5)).EQ.0) KCS=9-KCS
31886 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
31887 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
31890 IF(IA.LE.0.OR.IA.GT.N) THEN
31891 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
31894 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
31895 & MSTU(5)).EQ.IB) THEN
31896 IF(MREV.EQ.1) KCS=9-KCS
31897 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
31898 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
31900 IF(MREV.EQ.0) KCS=9-KCS
31901 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
31902 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
31904 IF(IA.NE.I) GOTO 100
31909 IF(MSTJ(14).LT.0) RETURN
31911 C...Find lowest-mass colour singlet jet system, OK if above threshold.
31912 IF(MSTJ(14).EQ.0) GOTO 320
31917 DO 190 I=MAX(1,IP),NS
31918 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
31919 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
31926 DPS(5)=PYMASS(K(I,2))
31927 ELSEIF(K(I,1).EQ.2) THEN
31929 DPS(J)=DPS(J)+P(I,J)
31931 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
31933 DPS(J)=DPS(J)+P(I,J)
31936 DPS(5)=DPS(5)+PYMASS(K(I,2))
31937 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
31952 IF(PDM.GE.PARJ(32)) GOTO 320
31954 C...Fill small-mass system as cluster.
31956 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
31968 C...Form two particles from flavours of lowest-mass system, if feasible.
31971 IF(MSTU(16).NE.2) THEN
31982 IF(IABS(K(IC1,2)).NE.21) THEN
31983 KC1=PYCOMP(K(IC1,2))
31984 KC2=PYCOMP(K(IC2,2))
31985 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
31986 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
31987 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
31988 IF(KQ1+KQ2.NE.0) GOTO 320
31989 C.. Start with qq, if there is one. Only allow for rank 1 popcorn meson
31991 IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
31993 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
31994 CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
31995 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
31997 IF(IABS(K(IC2,2)).NE.21) GOTO 320
31998 C.. No room for popcorn mesons in closed string -> 2 hadrons.
32000 210 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
32001 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
32002 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
32003 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
32005 P(N+2,5)=PYMASS(K(N+2,2))
32006 P(N+3,5)=PYMASS(K(N+3,2))
32007 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
32008 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
32010 C...Perform two-particle decay of jet system, if possible.
32011 IF(PECM.GE.0.02D0*DPC(4)) THEN
32012 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
32013 & (P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
32014 UE(3)=2D0*PYR(0)-1D0
32016 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
32017 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
32022 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
32023 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
32025 CALL PYROBO(N+2,N+3,0D0,0D0,DPC(1)/DPC(4),DPC(2)/DPC(4),
32030 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
32032 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
32033 & P(IC1,3)*P(IC2,3)
32034 IF(NP.GE.3.OR.HA.LE.1.25D0*P(IC1,5)*P(IC2,5)) GOTO 260
32035 HD1=0.5D0*(P(N+2,5)**2-P(IC1,5)**2)
32036 HD2=0.5D0*(P(N+3,5)**2-P(IC2,5)**2)
32037 HR=SQRT(MAX(0D0,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
32038 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1D0
32039 HC=P(IC1,5)**2+2D0*HA+P(IC2,5)**2
32040 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
32041 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
32043 P(N+2,J)=(1D0+HK1)*P(IC1,J)-HK2*P(IC2,J)
32044 P(N+3,J)=(1D0+HK2)*P(IC2,J)-HK1*P(IC1,J)
32058 C...Else form one particle from the flavours available, if possible.
32060 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
32062 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
32063 CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
32065 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
32066 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
32068 IF(K(N+2,2).EQ.0) GOTO 260
32069 P(N+2,5)=PYMASS(K(N+2,2))
32071 C...Find parton/particle which combines to largest extra mass.
32076 IF(IR.NE.0) GOTO 280
32077 DO 270 I=MAX(1,IP),N
32078 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
32079 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
32080 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
32081 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
32082 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
32083 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
32085 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
32086 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
32087 IF(HSR.GT.HSM) THEN
32095 C...Shuffle energy and momentum to put new particle on mass shell.
32100 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
32101 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
32102 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
32104 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
32105 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
32113 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
32117 C...Mark collapsed system and store daughter pointers. Iterate.
32118 300 DO 310 I=IC1,IC2
32119 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(PYCOMP(K(I,2)),2).NE.0)
32122 IF(MSTU(16).NE.2) THEN
32131 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
32133 C...Check flavours and invariant masses in parton systems.
32140 DO 360 I=MAX(1,IP),N
32141 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
32143 IF(KC.EQ.0) GOTO 360
32144 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32145 IF(KQ.EQ.0) GOTO 360
32151 DPS(5)=DPS(5)+PYMASS(K(I,2))
32154 DPS(J)=DPS(J)+P(I,J)
32156 IF(K(I,1).EQ.1) THEN
32157 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
32158 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
32159 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32160 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
32161 & '(PYPREP:) too small mass in jet system')
32163 C IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32164 C & (0.9D0*PARJ(32)+DPS(5))**2)
32165 C & WRITE(*,*) 'I,DPS',I,DPS
32179 C*********************************************************************
32182 C...Handles the fragmentation of an arbitrary colour singlet
32183 C...jet system according to the Lund string fragmentation model.
32185 SUBROUTINE PYSTRF(IP)
32187 C...Double precision and integer declarations.
32188 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32189 INTEGER PYK,PYCHGE,PYCOMP
32191 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
32192 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32193 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32194 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
32195 C...Local arrays. All MOPS variables ends with MO
32196 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
32197 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
32198 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
32199 &INMO(9),PM2QMO(2),XTMO(2)
32201 C...Function: four-product of two vectors.
32202 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)
32203 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
32206 C...Reset counters. Identify parton system.
32219 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
32220 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
32221 IF(MSTU(21).GE.1) RETURN
32223 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
32225 IF(KC.EQ.0) GOTO 110
32226 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32227 IF(KQ.EQ.0) GOTO 110
32228 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
32229 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32230 IF(MSTU(21).GE.1) RETURN
32233 C...Take copy of partons to be considered. Check flavour sum.
32238 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
32240 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
32242 IF(KQ.NE.2) KQSUM=KQSUM+KQ
32243 IF(K(I,1).EQ.41) THEN
32245 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
32246 IF(KQSUM.NE.KQ) MJU(2)=N+NP
32248 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
32249 IF(KQSUM.NE.0) THEN
32250 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32251 IF(MSTU(21).GE.1) RETURN
32254 C...Boost copied system to CM frame (for better numerical precision).
32255 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
32258 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
32262 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
32264 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
32265 IF(P(I,3).GT.0D0) THEN
32266 HHPEZ=(P(I,4)+P(I,3))/HHBZ
32267 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
32268 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32270 HHPEZ=(P(I,4)-P(I,3))*HHBZ
32271 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
32272 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32277 C...Search for very nearby partons that may be recombined.
32284 140 IF(NR.GE.3) THEN
32287 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
32289 IF(I.EQ.N+NR) I1=N+1
32290 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
32291 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
32293 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
32295 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
32296 & P(I1,2)**2+P(I1,3)**2))
32297 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
32298 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
32299 IF(PDR.LT.PDRMIN) THEN
32305 C...Recombine very nearby partons to avoid machine precision problems.
32306 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
32308 P(N+1,J)=P(N+1,J)+P(N+NR,J)
32310 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
32314 ELSEIF(PDRMIN.LT.PARU12) THEN
32316 P(IR,J)=P(IR,J)+P(IR+1,J)
32318 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
32320 DO 190 I=IR+1,N+NR-1
32326 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
32328 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
32329 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
32335 C...Reset particle counter. Skip ahead if no junctions are present;
32336 C...this is usually the case!
32337 NRS=MAX(5*NR+11,NP)
32340 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32344 ELSEIF(NTRY.GT.100) THEN
32345 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32346 IF(MSTU(21).GE.1) RETURN
32350 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
32351 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
32352 & ' junction strings not handled by MSTJ(12)>3 options')
32355 IF(MJU(JT).EQ.0) GOTO 570
32358 C...Find and sum up momentum on three sides of junction. Check flavours.
32366 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
32367 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
32372 PJU(IU,J)=PJU(IU,J)+P(I1,J)
32376 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
32378 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
32379 & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
32380 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32381 IF(MSTU(21).GE.1) RETURN
32384 C...Calculate (approximate) boost to rest frame of junction.
32385 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
32386 & (PJU(1,5)*PJU(2,5))
32387 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
32388 & (PJU(1,5)*PJU(3,5))
32389 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
32390 & (PJU(2,5)*PJU(3,5))
32391 T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
32392 T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
32393 TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
32394 T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
32395 T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
32397 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
32399 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
32401 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
32405 C...Put junction at rest if motion could give inconsistencies.
32406 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
32416 C...Start preparing for fragmentation of two strings from junction.
32419 NS=IJU(IU+1)-IJU(IU)
32421 C...Junction strings: find longitudinal string directions.
32426 DP(1,J)=0.5D0*P(IS1,J)
32427 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
32428 DP(2,J)=0.5D0*P(IS2,J)
32429 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
32431 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
32433 IF(IS.EQ.NS) DP(2,5)=0D0
32437 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32438 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32439 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32444 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32445 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32446 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32448 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32450 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32451 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32455 C...Junction strings: initialize flavour, momentum and starting pos.
32459 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32463 ELSEIF(NTRY.GT.100) THEN
32464 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32465 IF(MSTU(21).GE.1) RETURN
32470 IE(1)=K(N+1+(JT/2)*(NP-1),3)
32475 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
32481 KFL(1)=K(IJU(IU),2)
32489 C...Junction strings: find initial transverse directions.
32492 DP(2,J)=P(IN(4)+1,J)
32496 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32497 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32498 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32499 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32500 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32501 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32502 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32503 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32504 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32506 DHCX1=DFOUR(3,1)/DHC12
32507 DHCX2=DFOUR(3,2)/DHC12
32508 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32509 DHCY1=DFOUR(4,1)/DHC12
32510 DHCY2=DFOUR(4,2)/DHC12
32511 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32512 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32514 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32516 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32520 C...Junction strings: produce new particle, origin.
32522 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
32523 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32524 IF(MSTU(21).GE.1) RETURN
32532 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
32533 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
32534 IF(K(I,2).EQ.0) GOTO 320
32535 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
32536 & IABS(KFL(3)).GT.10) THEN
32537 IF(PYR(0).GT.PARJ(19)) GOTO 390
32539 P(I,5)=PYMASS(K(I,2))
32540 CALL PYPTDI(KFL(1),PX(3),PY(3))
32541 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
32542 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
32543 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
32544 & MSTU(90).LT.8) THEN
32545 MSTU(90)=MSTU(90)+1
32546 MSTU(90+MSTU(90))=I
32547 PARU(90+MSTU(90))=Z
32549 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
32554 C...Junction strings: stepping within or from 'low' string region easy.
32555 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
32556 & P(IN(1),5)**2.GE.PR(1)) THEN
32557 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
32558 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
32560 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
32563 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
32564 P(IN(2)+2,4)=P(IN(2)+2,3)
32567 IF(IN(2).GT.N+NR+4*NS) GOTO 320
32568 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32569 P(IN(1)+2,4)=P(IN(1)+2,3)
32575 C...Junction strings: find new transverse directions.
32576 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
32577 & IN(1).GT.IN(2)) GOTO 320
32578 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
32585 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32586 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32588 IF(DHC12.LE.1D-2) THEN
32589 P(IN(1)+2,4)=P(IN(1)+2,3)
32595 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32596 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32597 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32598 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32599 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32600 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32601 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32602 DHCX1=DFOUR(3,1)/DHC12
32603 DHCX2=DFOUR(3,2)/DHC12
32604 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32605 DHCY1=DFOUR(4,1)/DHC12
32606 DHCY2=DFOUR(4,2)/DHC12
32607 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32608 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32610 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32612 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32615 C...Express pT with respect to new axes, if sensible.
32616 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
32617 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
32618 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
32624 C...Junction strings: sum up known four-momentum, coefficients for m2.
32627 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
32628 & PY(3)*P(IN(3)+1,J)
32629 DO 450 IN1=IN(4),IN(1)-4,4
32630 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
32632 DO 460 IN2=IN(5),IN(2)-4,4
32633 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
32637 DHM(2)=2D0*FOUR(I,IN(1))
32638 DHM(3)=2D0*FOUR(I,IN(2))
32639 DHM(4)=2D0*FOUR(IN(1),IN(2))
32641 C...Junction strings: find coefficients for Gamma expression.
32642 DO 490 IN2=IN(1)+1,IN(2),4
32643 DO 480 IN1=IN(1),IN2-1,4
32644 DHC=2D0*FOUR(IN1,IN2)
32645 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
32646 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
32647 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
32648 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
32652 C...Junction strings: solve (m2, Gamma) equation system for energies.
32653 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
32654 IF(ABS(DHS1).LT.1D-4) GOTO 320
32655 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
32656 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
32657 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
32658 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
32659 & ABS(DHS1)-DHS2/DHS1)
32660 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
32661 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
32662 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
32664 C...Junction strings: step to new region if necessary.
32665 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
32666 P(IN(2)+2,4)=P(IN(2)+2,3)
32669 IF(IN(2).GT.N+NR+4*NS) GOTO 320
32670 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32671 P(IN(1)+2,4)=P(IN(1)+2,3)
32676 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
32677 P(IN(1)+2,4)=P(IN(1)+2,3)
32683 C...Junction strings: particle four-momentum, remainder, loop back.
32685 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
32686 & P(IN(2)+2,4)*P(IN(2),J)
32687 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
32689 IF(P(I,4).LT.P(I,5)) GOTO 320
32690 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
32691 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
32692 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
32697 IF(IN(3).NE.IN(6)) THEN
32699 P(IN(6),J)=P(IN(3),J)
32700 P(IN(6)+1,J)=P(IN(3)+1,J)
32705 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
32706 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
32711 C...Junction strings: save quantities left after each string.
32712 IF(IABS(KFL(1)).GT.10) GOTO 320
32716 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
32720 C...Junction strings: put together to new effective string endpoint.
32722 KFJS(JT)=K(K(MJU(JT+2),3),2)
32723 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
32724 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
32725 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
32726 & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
32729 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
32730 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
32732 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
32736 C...Open versus closed strings. Choose breakup region for latter.
32737 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
32740 ELSEIF(MJU(1).NE.0) THEN
32743 ELSEIF(MJU(2).NE.0) THEN
32746 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
32753 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
32754 W2SUM=W2SUM+P(N+NR+IS,1)
32759 W2SUM=W2SUM-P(N+NR+NB,1)
32760 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
32763 C...Find longitudinal string directions (i.e. lightlike four-vectors).
32765 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
32766 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
32769 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
32770 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
32772 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
32773 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
32778 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32781 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
32782 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
32785 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32786 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32787 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32789 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32791 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32792 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32796 C...Begin initialization: sum up energy, set starting position.
32800 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32804 ELSEIF(NTRY.GT.100) THEN
32805 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32806 IF(MSTU(21).GE.1) RETURN
32813 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
32818 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
32819 IF(NS.GT.NR) IRANK(JT)=1
32820 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
32821 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
32822 IN(3*JT+2)=IN(3*JT+1)+1
32823 IN(3*JT+3)=N+NR+4*NS+2*JT-1
32824 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
32830 C.. MOPS variables and switches
32836 C...Initialize flavour and pT variables for open string.
32840 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
32844 KFL(JT)=K(IE(JT),2)
32845 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
32847 PMQ(JT)=PYMASS(KFL(JT))
32851 C...Closed string: random initial breakup flavour, pT and vertex.
32853 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
32855 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
32856 C.. Closed string: first vertex diq attempt => enforced second
32858 IF(IABS(KFL(1)).GT.10)THEN
32863 IF(IBMO.EQ.1) MSTU(121)=-1
32865 CALL PYPTDI(KFL(1),PX(1),PY(1))
32868 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
32869 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
32870 ZR=PR3/(Z*P(N+NR+1,5)**2)
32871 IF(ZR.GE.1D0) GOTO 710
32874 PMQ(JT)=PYMASS(KFL(JT))
32875 GAM(JT)=PR3*(1D0-Z)/Z
32876 IN1=N+NR+3+4*(JT/2)*(NS-1)
32879 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
32882 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
32888 PM2QMO(JT)=PMQ(JT)**2
32889 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
32892 C...Find initial transverse directions (i.e. spacelike four-vectors).
32894 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
32903 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32904 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32905 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32906 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32907 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32908 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32909 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32910 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32911 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32913 DHCX1=DFOUR(3,1)/DHC12
32914 DHCX2=DFOUR(3,2)/DHC12
32915 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32916 DHCY1=DFOUR(4,1)/DHC12
32917 DHCY2=DFOUR(4,2)/DHC12
32918 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32919 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32921 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32923 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32928 P(IN3+2,J)=P(IN3,J)
32929 P(IN3+3,J)=P(IN3+1,J)
32934 C...Remove energy used up in junction string fragmentation.
32935 IF(MJU(1)+MJU(2).GT.0) THEN
32937 IF(NJS(JT).EQ.0) GOTO 790
32939 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
32944 C...Produce new particle: side, origin.
32946 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
32947 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32948 IF(MSTU(21).GE.1) RETURN
32950 C.. New side priority for popcorn systems
32951 IF(MSTU(121).LE.0)THEN
32953 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
32954 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
32958 IRANK(JT)=IRANK(JT)+1
32964 C...Generate flavour, hadron and pT.
32966 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
32967 IF(K(I,2).EQ.0) GOTO 640
32969 IF(MSTU(121).EQ.-1) GOTO 840
32970 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
32971 &IABS(KFL(3)).GT.10) THEN
32972 IF(PYR(0).GT.PARJ(19)) GOTO 810
32974 P(I,5)=PYMASS(K(I,2))
32975 CALL PYPTDI(KFL(JT),PX(3),PY(3))
32976 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
32978 C...Final hadrons for small invariant mass.
32980 PMQ(3)=PYMASS(KFL(3))
32982 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
32983 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
32984 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
32985 &WMIN-0.5D0*PARJ(36)*PMQ(3)
32986 WREM2=FOUR(N+NRS,N+NRS)
32987 IF(WREM2.LT.0.10D0) GOTO 640
32988 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
32989 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
32991 C...Choose z, which gives Gamma. Shift z for heavy flavours.
32992 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
32993 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
32994 &MSTU(90).LT.8) THEN
32995 MSTU(90)=MSTU(90)+1
32996 MSTU(90+MSTU(90))=I
32997 PARU(90+MSTU(90))=Z
33001 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33002 &MOD(KFL2A/1000,10)).GE.4) THEN
33003 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33004 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
33005 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
33006 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33007 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
33009 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
33011 C.. MOPS baryon model modification
33012 XTMO3=(1D0-Z)*XTMO(JT)
33013 IF(IABS(KFL(3)).LE.10) NRVMO=0
33014 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
33018 IF(IABS(KFL(JT)).LE.10)THEN
33019 XBMO=MIN(XTMO3,1D0-(2D-10))
33022 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
33023 GTSTMO=1D0-PARF(192)**PGMO
33025 IF(IRANK(JT).EQ.1) THEN
33030 IF(XBMO.LT.1D0-(1D-10))THEN
33031 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
33032 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
33035 IF(MSTJ(12).GE.5)THEN
33036 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
33037 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
33038 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
33043 C.. MOPS Accepting popcorn system hadron.
33044 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
33045 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
33047 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
33049 & '(PYSTRF:) no more memory left in PYJETS')
33050 IF(MSTU(21).GE.1) RETURN
33062 DO 820 LINE=1,I-N-NR
33063 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
33064 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
33071 C..Reject popcorn system, flag=-1 if enforcing new one
33073 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
33078 C..Lift restoring string outside MOPS block
33079 840 IF(MSTU(121).LT.0) THEN
33080 IF(MSTU(121).EQ.-2) MSTU(121)=0
33083 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
33094 DO 850 LINE=1,I-N-NR
33095 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
33096 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
33104 C.. MOPS end of modification
33110 C...Stepping within or from 'low' string region easy.
33111 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
33112 &P(IN(1),5)**2.GE.PR(JT)) THEN
33113 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
33114 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
33116 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
33119 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
33120 P(IN(JR)+2,4)=P(IN(JR)+2,3)
33123 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33124 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33125 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33131 C...Find new transverse directions (i.e. spacelike string vectors).
33132 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
33133 &IN(1).GT.IN(2)) GOTO 640
33134 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
33141 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
33142 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
33144 IF(DHC12.LE.1D-2) THEN
33145 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33151 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
33152 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
33153 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
33154 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
33155 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
33156 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
33157 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
33158 DHCX1=DFOUR(3,1)/DHC12
33159 DHCX2=DFOUR(3,2)/DHC12
33160 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
33161 DHCY1=DFOUR(4,1)/DHC12
33162 DHCY2=DFOUR(4,2)/DHC12
33163 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
33164 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
33166 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
33168 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
33171 C...Express pT with respect to new axes, if sensible.
33172 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
33173 & FOUR(IN(3*JT+3)+1,IN(3)))
33174 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
33175 & FOUR(IN(3*JT+3)+1,IN(3)+1))
33176 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
33182 C...Sum up known four-momentum. Gives coefficients for m2 expression.
33185 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
33186 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
33187 DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
33188 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
33190 DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
33191 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
33195 DHM(2)=2D0*FOUR(I,IN(1))
33196 DHM(3)=2D0*FOUR(I,IN(2))
33197 DHM(4)=2D0*FOUR(IN(1),IN(2))
33199 C...Find coefficients for Gamma expression.
33200 DO 960 IN2=IN(1)+1,IN(2),4
33201 DO 950 IN1=IN(1),IN2-1,4
33202 DHC=2D0*FOUR(IN1,IN2)
33203 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
33204 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
33205 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
33206 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
33210 C...Solve (m2, Gamma) equation system for energies taken.
33211 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
33212 IF(ABS(DHS1).LT.1D-4) GOTO 640
33213 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
33214 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
33215 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
33216 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
33217 &ABS(DHS1)-DHS2/DHS1)
33218 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
33219 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
33220 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
33222 C...Step to new region if necessary.
33223 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
33224 P(IN(JR)+2,4)=P(IN(JR)+2,3)
33227 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33228 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33229 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33234 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
33235 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33241 C...Four-momentum of particle. Remaining quantities. Loop back.
33243 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
33244 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
33246 IF(P(I,4).LT.P(I,5)) GOTO 640
33252 IF(IN(3).NE.IN(3*JT+3)) THEN
33254 P(IN(3*JT+3),J)=P(IN(3),J)
33255 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
33260 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
33261 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
33265 C...Final hadron: side, flavour, hadron, mass.
33271 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
33272 IF(K(I,2).EQ.0) GOTO 640
33273 P(I,5)=PYMASS(K(I,2))
33274 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33276 C...Final two hadrons: find common setup of four-vectors.
33278 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
33279 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
33280 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
33281 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
33282 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
33283 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
33284 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
33285 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
33286 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
33287 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
33290 C...Solve kinematics for final two hadrons, if possible.
33291 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
33292 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
33293 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
33294 IF(FD.GE.1D0) GOTO 640
33295 FA=WREM2+PR(JT)-PR(JR)
33296 IF(MSTJ(11).NE.2) PREV=0.5D0*EXP(MAX(-50D0,LOG(FD)*PARJ(38)*
33297 &(PR(1)+PR(2))**2))
33298 IF(MSTJ(11).EQ.2) PREV=0.5D0*FD**PARJ(39)
33299 FB=SIGN(SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))),JS*(PYR(0)-PREV))
33302 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33303 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
33304 &4D0*WREM2*PR(JT))),DBLE(JS))
33306 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
33307 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
33308 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
33309 P(I,J)=P(N+NRS,J)-P(I-1,J)
33311 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
33313 C...Mark jets as fragmented and give daughter pointers.
33315 DO 1030 I=NSAV+1,NSAV+NP
33318 IF(MSTU(16).NE.2) THEN
33327 C...Document string system. Move up particles.
33338 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
33342 K(I,J)=K(I+NRS-1,J)
33343 P(I,J)=P(I+NRS-1,J)
33348 DO 1070 IZ=MSTU90+1,MSTU91
33349 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
33350 PARU9T(IZ)=PARU(90+IZ)
33354 C...Order particles in rank along the chain. Update mother pointer.
33357 K(I-NSAV+N,J)=K(I,J)
33358 P(I-NSAV+N,J)=P(I,J)
33362 DO 1120 I=N+1,2*N-NSAV
33363 IF(K(I,3).NE.IE(1)) GOTO 1120
33369 IF(MSTU(16).NE.2) K(I1,3)=NSAV
33370 DO 1110 IZ=MSTU90+1,MSTU91
33371 IF(MSTU9T(IZ).EQ.I) THEN
33372 MSTU(90)=MSTU(90)+1
33373 MSTU(90+MSTU(90))=I1
33374 PARU(90+MSTU(90))=PARU9T(IZ)
33378 DO 1150 I=2*N-NSAV,N+1,-1
33379 IF(K(I,3).EQ.IE(1)) GOTO 1150
33385 IF(MSTU(16).NE.2) K(I1,3)=NSAV
33386 DO 1140 IZ=MSTU90+1,MSTU91
33387 IF(MSTU9T(IZ).EQ.I) THEN
33388 MSTU(90)=MSTU(90)+1
33389 MSTU(90+MSTU(90))=I1
33390 PARU(90+MSTU(90))=PARU9T(IZ)
33395 C...Boost back particle system. Set production vertices.
33398 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
33402 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
33403 IF(P(I,3).GT.0D0) THEN
33404 HHPEZ=(P(I,4)+P(I,3))*HHBZ
33405 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
33406 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33408 HHPEZ=(P(I,4)-P(I,3))/HHBZ
33409 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
33410 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33423 C*********************************************************************
33426 C...Handles the fragmentation of a jet system (or a single
33427 C...jet) according to independent fragmentation models.
33429 SUBROUTINE PYINDF(IP)
33431 C...Double precision and integer declarations.
33432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33433 INTEGER PYK,PYCHGE,PYCOMP
33435 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33436 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33437 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33438 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
33440 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
33441 &KFLO(2),PXO(2),PYO(2),WO(2)
33443 C.. MOPS error message
33444 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
33445 &' are not treated as expected in independent fragmentation')
33447 C...Reset counters. Identify parton system and take copy. Check flavour.
33457 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
33458 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
33459 IF(MSTU(21).GE.1) RETURN
33461 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
33463 IF(KC.EQ.0) GOTO 110
33464 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
33465 IF(KQ.EQ.0) GOTO 110
33467 IF(KQ.NE.2) KQSUM=KQSUM+KQ
33469 K(NSAV+NJET,J)=K(I,J)
33470 P(NSAV+NJET,J)=P(I,J)
33471 DPS(J)=DPS(J)+P(I,J)
33474 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
33475 &K(I+1,1).EQ.2)) GOTO 110
33476 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
33477 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
33478 IF(MSTU(21).GE.1) RETURN
33481 C...Boost copied system to CM frame. Find CM energy and sum flavours.
33484 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
33485 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
33491 DO 140 I=NSAV+1,NSAV+NJET
33495 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
33496 ELSEIF(KFA.GT.1000) THEN
33497 KFLA=MOD(KFA/1000,10)
33498 KFLB=MOD(KFA/100,10)
33499 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
33500 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
33504 C...Loop over attempts made. Reset counters.
33507 IF(NTRY.GT.200) THEN
33508 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
33509 IF(MSTU(21).GE.1) RETURN
33519 C...Loop over jets to be fragmented.
33520 DO 230 IP1=NSAV+1,NSAV+NJET
33525 C...Initial flavour and momentum values. Jet along +z axis.
33526 KFLH=IABS(K(IP1,2))
33527 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
33529 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
33531 C...Initial values for quark or diquark jet.
33532 170 IF(IABS(K(IP1,2)).NE.21) THEN
33535 CALL PYPTDI(0,PXO(1),PYO(1))
33538 C...Initial values for gluon treated like random quark jet.
33539 ELSEIF(MSTJ(2).LE.2) THEN
33541 IF(MSTJ(2).EQ.2) MSTJ(91)=1
33542 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33543 CALL PYPTDI(0,PXO(1),PYO(1))
33546 C...Initial values for gluon treated like quark-antiquark jet pair,
33547 C...sharing energy according to Altarelli-Parisi splitting function.
33550 IF(MSTJ(2).EQ.4) MSTJ(91)=1
33551 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33553 CALL PYPTDI(0,PXO(1),PYO(1))
33556 WO(1)=WF*PYR(0)**(1D0/3D0)
33560 C...Initial values for rank, flavour, pT and W+.
33570 C...New hadron. Generate flavour and hadron species.
33572 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
33573 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
33574 IF(MSTU(21).GE.1) RETURN
33581 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
33582 IF(K(I,2).EQ.0) GOTO 180
33583 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
33584 IF(PYR(0).GT.PARJ(19)) GOTO 200
33587 C...Find hadron mass. Generate four-momentum.
33588 P(I,5)=PYMASS(K(I,2))
33589 CALL PYPTDI(KFL1,PX2,PY2)
33592 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
33593 CALL PYZDIS(KFL1,KFL2,PR,Z)
33595 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
33597 MSTU(90)=MSTU(90)+1
33598 MSTU(90+MSTU(90))=I
33599 PARU(90+MSTU(90))=Z
33601 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
33602 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
33603 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
33604 & P(I,3).LE.0.001D0) THEN
33605 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
33611 C...Remaining flavour and momentum.
33620 C...Check if pL acceptable. Go back for new hadron if enough energy.
33621 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
33623 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
33625 IF(W.GT.PARJ(31)) GOTO 190
33628 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
33629 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
33631 C...Rotate jet to new direction.
33632 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
33633 PHI=PYANGL(P(IP1,1),P(IP1,2))
33635 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
33636 K(K(IP1,3),4)=NSAV1+1
33639 C...End of jet generation loop. Skip conservation in some cases.
33641 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
33642 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
33644 C...Subtract off produced hadron flavours, finished if zero.
33645 DO 240 I=NSAV+NJET+1,N
33647 KFLA=MOD(KFA/1000,10)
33648 KFLB=MOD(KFA/100,10)
33649 KFLC=MOD(KFA/10,10)
33651 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
33652 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
33654 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
33655 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
33656 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
33659 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33660 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33661 IF(NREQ.EQ.0) GOTO 320
33663 C...Take away flavour of low-momentum particles until enough freedom.
33667 DO 260 I=NSAV+NJET+1,N
33668 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
33669 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
33670 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
33672 IF(IREM.EQ.0) GOTO 150
33674 KFA=IABS(K(IREM,2))
33675 KFLA=MOD(KFA/1000,10)
33676 KFLB=MOD(KFA/100,10)
33677 KFLC=MOD(KFA/10,10)
33678 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
33679 IF(K(IREM,1).EQ.8) GOTO 250
33681 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
33682 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
33683 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
33685 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
33686 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
33687 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
33690 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33691 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33692 IF(NREQ.GT.NREM) GOTO 250
33693 DO 270 I=NSAV+NJET+1,N
33694 IF(K(I,1).EQ.8) K(I,1)=1
33697 C...Find combination of existing and new flavours for hadron.
33699 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
33700 IF(NREQ.LT.NREM) NFET=1
33701 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
33703 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
33704 KFLF(J)=ISIGN(1,NFL(1))
33705 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
33706 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
33708 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
33710 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
33711 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
33712 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
33713 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
33714 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
33715 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
33716 IF(NFET.LE.2) KFLF(3)=0
33717 IF(KFLF(3).NE.0) THEN
33718 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
33719 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
33720 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
33721 & KFLFC=KFLFC+ISIGN(2,KFLFC)
33725 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
33726 IF(KF.EQ.0) GOTO 280
33727 DO 300 J=1,MAX(2,NFET)
33728 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
33731 C...Store hadron at random among free positions.
33732 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
33733 DO 310 I=NSAV+NJET+1,N
33734 IF(K(I,1).EQ.7) NPOS=NPOS-1
33735 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
33738 P(I,5)=PYMASS(K(I,2))
33739 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33742 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33743 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33744 IF(NREM.GT.0) GOTO 280
33746 C...Compensate for missing momentum in global scheme (3 options).
33747 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
33750 DO 330 I=NSAV+NJET+1,N
33751 PSI(J)=PSI(J)+P(I,J)
33754 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
33756 DO 350 I=NSAV+NJET+1,N
33757 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
33758 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33759 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33760 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
33762 DO 370 I=NSAV+NJET+1,N
33763 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
33764 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33765 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33766 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
33768 P(I,J)=P(I,J)-PSI(J)*PW/PWS
33770 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33773 C...Compensate for missing momentum withing each jet separately.
33774 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
33775 DO 390 I=N+1,N+NJET
33781 DO 410 I=NSAV+NJET+1,N
33784 K(IR2,1)=K(IR2,1)+1
33785 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33786 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33788 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
33790 P(IR2,4)=P(IR2,4)+P(I,4)
33791 P(IR2,5)=P(IR2,5)+PLS
33794 DO 420 I=N+1,N+NJET
33795 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
33797 DO 440 I=NSAV+NJET+1,N
33800 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33801 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33803 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
33806 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33810 C...Scale momenta for energy conservation.
33811 IF(MOD(MSTJ(3),5).NE.0) THEN
33815 DO 450 I=NSAV+NJET+1,N
33818 PQS=PQS+P(I,5)**2/P(I,4)
33820 IF(PMS.GE.PECM) GOTO 150
33823 PFAC=(PECM-PQS)/(PES-PQS)
33826 DO 480 I=NSAV+NJET+1,N
33830 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33832 PQS=PQS+P(I,5)**2/P(I,4)
33834 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
33837 C...Origin of produced particles and parton daughter pointers.
33838 490 DO 500 I=NSAV+NJET+1,N
33839 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
33840 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
33842 DO 510 I=NSAV+1,NSAV+NJET
33845 IF(MSTU(16).NE.2) THEN
33849 K(I1,4)=K(I1,4)-NJET+1
33850 K(I1,5)=K(I1,5)-NJET+1
33851 IF(K(I1,5).LT.K(I1,4)) THEN
33858 C...Document independent fragmentation system. Remove copy of jets.
33869 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
33871 DO 540 I=NSAV+NJET,N
33873 K(I-NJET+1,J)=K(I,J)
33874 P(I-NJET+1,J)=P(I,J)
33875 V(I-NJET+1,J)=V(I,J)
33879 DO 550 IZ=MSTU90+1,MSTU(90)
33880 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
33883 C...Boost back particle system. Set production vertices.
33884 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
33885 &DPS(2)/DPS(4),DPS(3)/DPS(4))
33895 C*********************************************************************
33898 C...Handles the decay of unstable particles.
33900 SUBROUTINE PYDECY(IP)
33902 C...Double precision and integer declarations.
33903 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33904 INTEGER PYK,PYCHGE,PYCOMP
33906 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33907 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33908 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33909 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
33910 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
33912 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
33913 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
33915 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
33917 C...Functions: momentum in two-particle decays and four-product.
33918 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
33919 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)
33921 C...Initial values.
33925 KFS=ISIGN(1,K(IP,2))
33929 C...Choose lifetime and determine decay vertex.
33930 IF(K(IP,1).EQ.5) THEN
33932 ELSEIF(K(IP,1).NE.4) THEN
33933 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
33936 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
33939 C...Determine whether decay allowed or not.
33941 IF(MSTJ(22).EQ.2) THEN
33942 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
33943 ELSEIF(MSTJ(22).EQ.3) THEN
33944 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
33945 ELSEIF(MSTJ(22).EQ.4) THEN
33946 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
33947 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
33949 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
33954 C...Interface to external tau decay library (for tau polarization).
33955 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
33957 C...Starting values for pointers and momenta.
33961 PCMTAU(J)=P(ITAU,J)
33964 C...Iterate to find position and code of mother of tau.
33966 120 IMTAU=K(IMTAU,3)
33968 IF(IMTAU.EQ.0) THEN
33969 C...If no known origin then impossible to do anything further.
33973 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
33974 C...If tau -> tau + gamma then add gamma energy and loop.
33975 IF(K(K(IMTAU,4),2).EQ.22) THEN
33977 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
33979 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
33981 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
33986 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
33987 C...If coming from weak decay of hadron then W is not stored in record,
33988 C...but can be reconstructed by adding neutrino momentum.
33989 KFORIG=-ISIGN(24,K(ITAU,2))
33991 DO 160 II=K(IMTAU,4),K(IMTAU,5)
33992 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
33994 PCMTAU(J)=PCMTAU(J)+P(II,J)
34000 C...If coming from resonance decay then find latest copy of this
34001 C...resonance (may not completely agree).
34004 DO 170 II=IMTAU+1,IP-1
34005 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
34006 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
34009 PCMTAU(J)=P(IORIG,J)
34013 C...Boost tau to rest frame of production process (where known)
34014 C...and rotate it to sit along +z axis.
34016 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
34018 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
34019 & -DBETAU(2),-DBETAU(3))
34020 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
34021 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
34022 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
34023 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
34025 C...Call tau decay routine (if meaningful) and fill extra info.
34026 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34027 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
34028 DO 200 II=NSAV+1,NSAV+NDECAY
34037 C...Boost back decay tau and decay products.
34041 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34042 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
34043 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
34044 & DBETAU(2),DBETAU(3))
34046 C...Skip past ordinary tau decay treatment.
34054 C...B-Bbar mixing: flip sign of meson appropriately.
34056 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
34058 IF(KFA.EQ.531) XBBMIX=PARJ(77)
34059 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
34060 IF(MMIX.EQ.1) KFS=-KFS
34063 C...Check existence of decay channels. Particle/antiparticle rules.
34065 IF(MDCY(KC,2).GT.0) THEN
34066 MDMDCY=MDME(MDCY(KC,2),2)
34067 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
34069 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
34070 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
34073 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
34074 IF(KCHG(KC,3).EQ.0) THEN
34077 IF(PYR(0).GT.0.5D0) KFS=-KFS
34078 ELSEIF(KFS.GT.0) THEN
34086 C...Sum branching ratios of allowed decay channels.
34089 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
34090 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34091 & KFSN*MDME(IDL,1).NE.3) GOTO 230
34092 IF(MDME(IDL,2).GT.100) GOTO 230
34094 BRSU=BRSU+BRAT(IDL)
34097 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
34101 C...Select decay channel among allowed ones.
34102 240 RBR=BRSU*PYR(0)
34105 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34106 &KFSN*MDME(IDL,1).NE.3) THEN
34107 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34108 ELSEIF(MDME(IDL,2).GT.100) THEN
34109 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34113 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
34116 C...Start readout of decay channel: matrix element, reset counters.
34119 IF(MOD(NTRY,200).EQ.0) THEN
34120 WRITE(CIDC,'(I4)') IDC
34121 CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
34125 IF(NTRY.GT.1000) THEN
34126 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34127 IF(MSTU(21).GE.1) RETURN
34133 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
34136 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
34138 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
34144 IF(KFA.GT.80) MHADDY=1
34145 C.. Random flavour and popcorn system memory.
34151 C...Read out decay products. Convert to standard flavour code.
34153 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
34155 IF(JT.LE.5) KP=KFDP(IDC,JT)
34156 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
34157 IF(KP.EQ.0) GOTO 280
34160 IF(KPA.GT.80) MHADDY=1
34161 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
34163 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
34165 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
34166 KFP=-KFS*MOD(KFA/10,10)
34167 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
34168 KFP=KFS*(100*MOD(KFA/10,100)+3)
34169 ELSEIF(KPA.EQ.81) THEN
34170 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
34171 ELSEIF(KP.EQ.82) THEN
34172 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
34173 IF(KFP.EQ.0) GOTO 260
34177 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
34178 ELSEIF(KP.EQ.-82) THEN
34181 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
34183 C...Add decay product to event record or to quark flavour list.
34186 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
34189 C...set rndmflav popcorn system pointer
34190 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
34192 PSQ=PSQ+PYMASS(KFLO(NQ))
34193 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
34194 & MOD(NQ,2).EQ.1) THEN
34199 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
34200 IF(K(I,2).EQ.0) GOTO 260
34202 P(I,5)=PYMASS(K(I,2))
34207 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
34208 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
34210 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
34211 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
34221 C...Check masses for resonance decays.
34222 IF(MHADDY.EQ.0) THEN
34223 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
34226 C...Choose decay multiplicity in phase space model.
34227 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
34229 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
34230 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
34232 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
34233 IF(IRNDMO.EQ.0) THEN
34236 ELSEIF(IRNDMO.EQ.1) THEN
34241 IF(NTRY.GT.1000) THEN
34242 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34243 IF(MSTU(21).GE.1) RETURN
34245 IF(MMAT.LE.20) THEN
34246 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
34247 & SIN(PARU(2)*PYR(0))
34248 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
34249 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
34250 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
34251 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
34252 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
34256 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
34258 IF(MSTU(121).GT.MSTU(125)) GOTO 300
34260 C...Form hadrons from flavour content.
34264 IF(ND.EQ.NP+NQ/2) GOTO 330
34265 DO 320 I=N+NP+1,N+ND-NQ/2
34266 C.. Stick to started popcorn system, else pick side at random
34268 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
34269 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
34270 IF(K(I,2).EQ.0) GOTO 300
34271 MSTU(125)=MSTU(125)-1
34273 IF(MSTU(121).GT.0) JTMO=JT
34279 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
34280 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
34281 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
34284 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
34285 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
34286 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
34287 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
34289 C...Check that sum of decay product masses not too large.
34291 DO 340 I=N+NP+1,N+ND
34296 P(I,5)=PYMASS(K(I,2))
34299 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
34301 C...Rescale energy to subtract off spectator quark mass.
34302 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
34303 & .AND.NP.GE.3) THEN
34305 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
34307 P(N+NP,J)=PQT*PV(1,J)
34308 PV(1,J)=(1D0-PQT)*PV(1,J)
34310 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34314 C...Fully specified final state: check mass broadening effects.
34316 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
34320 C...Determine position of grandmother, number of sisters.
34326 IF(IM.LT.0.OR.IM.GE.IP) IM=0
34327 IF(IM.NE.0) KFAM=IABS(K(IM,2))
34329 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
34330 IF(K(IL,3).EQ.IM) NM=NM+1
34331 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
34333 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
34334 & MOD(KFAM/1000,10).NE.0) NM=0
34336 KFAS=IABS(K(ISIS,2))
34337 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
34338 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
34343 C...Kinematics of one-particle decays.
34351 C...Calculate maximum weight ND-particle decay.
34354 WTMAX=1D0/WTCOR(ND-2)
34355 PMAX=PV(1,5)-PS+P(N+ND,5)
34357 DO 380 IL=ND-1,1,-1
34358 PMAX=PMAX+P(N+IL,5)
34359 PMIN=PMIN+P(N+IL+1,5)
34360 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
34364 C...Find virtual gamma mass in Dalitz decay.
34365 390 IF(ND.EQ.2) THEN
34366 ELSEIF(MMAT.EQ.2) THEN
34367 PMES=4D0*PMAS(11,1)**2
34368 PMRHO2=PMAS(131,1)**2
34369 PGRHO2=PMAS(131,2)**2
34370 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
34371 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
34372 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
34373 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
34374 IF(WT.LT.PYR(0)) GOTO 400
34375 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
34377 C...M-generator gives weight. If rejected, try again.
34382 DO 420 IL2=IL1-1,1,-1
34383 IF(RSAV.LE.RORD(IL2)) GOTO 430
34384 RORD(IL2+1)=RORD(IL2)
34386 430 RORD(IL2+1)=RSAV
34390 DO 450 IL=ND-1,1,-1
34391 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
34393 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34395 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
34398 C...Perform two-particle decays in respective CM frame.
34399 460 DO 480 IL=1,ND-1
34400 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34401 UE(3)=2D0*PYR(0)-1D0
34403 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
34404 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
34407 PV(IL+1,J)=-PA*UE(J)
34409 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
34410 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
34413 C...Lorentz transform decay products to lab frame.
34417 DO 530 IL=ND-1,1,-1
34419 BE(J)=PV(IL,J)/PV(IL,4)
34421 GA=PV(IL,4)/PV(IL,5)
34423 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34425 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34427 P(I,4)=GA*(P(I,4)+BEP)
34431 C...Check that no infinite loop in matrix element weight.
34433 IF(NTRY.GT.800) GOTO 560
34435 C...Matrix elements for omega and phi decays.
34437 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
34438 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
34439 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
34440 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
34442 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
34443 ELSEIF(MMAT.EQ.2) THEN
34444 FOUR12=FOUR(N+1,N+2)
34445 FOUR13=FOUR(N+1,N+3)
34446 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
34447 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
34448 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
34450 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
34451 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
34452 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
34453 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
34455 FOUR12=FOUR(IP,N+1)
34456 FOUR02=FOUR(IM,N+1)
34460 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
34461 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
34462 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
34463 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
34464 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
34465 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
34467 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
34468 ELSEIF(MMAT.EQ.4) THEN
34469 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34470 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
34471 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
34472 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
34473 & ((1D0-HX3)/(HX1*HX2))**2
34474 IF(WT.LT.2D0*PYR(0)) GOTO 390
34475 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
34478 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
34479 ELSEIF(MMAT.EQ.41) THEN
34480 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34481 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
34482 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
34484 C...Matrix elements for weak decays (only semileptonic for c and b)
34485 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34486 & .AND.ND.EQ.3) THEN
34487 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
34488 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
34489 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34490 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
34494 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
34497 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
34498 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
34499 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34502 C...Scale back energy and reattach spectator.
34503 560 IF(MREM.EQ.1) THEN
34505 PV(1,J)=PV(1,J)/(1D0-PQT)
34511 C...Low invariant mass for system with spectator quark gives particle,
34512 C...not two jets. Readjust momenta accordingly.
34513 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
34515 PM2=PYMASS(K(N+2,2))
34517 PM3=PYMASS(K(N+3,2))
34518 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
34519 & (PARJ(32)+PM2+PM3)**2) GOTO 630
34522 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
34523 IF(K(N+2,2).EQ.0) GOTO 260
34524 P(N+2,5)=PYMASS(K(N+2,2))
34525 PS=P(N+1,5)+P(N+2,5)
34530 ELSEIF(MMAT.EQ.44) THEN
34532 PM3=PYMASS(K(N+3,2))
34534 PM4=PYMASS(K(N+4,2))
34535 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
34536 & (PARJ(32)+PM3+PM4)**2) GOTO 600
34539 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
34540 IF(K(N+3,2).EQ.0) GOTO 260
34541 P(N+3,5)=PYMASS(K(N+3,2))
34543 P(N+3,J)=P(N+3,J)+P(N+4,J)
34545 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)
34546 HA=P(N+1,4)**2-P(N+2,4)**2
34547 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
34548 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
34549 & (P(N+1,3)-P(N+2,3))**2
34550 HD=(PV(1,4)-P(N+3,4))**2
34551 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
34554 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
34556 PCOR=HH*(P(N+1,J)-P(N+2,J))
34557 P(N+1,J)=P(N+1,J)+PCOR
34558 P(N+2,J)=P(N+2,J)-PCOR
34560 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)
34561 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)
34565 C...Check invariant mass of W jets. May give one particle or start over.
34566 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34567 &.AND.IABS(K(N+1,2)).LT.10) THEN
34568 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
34570 PM1=PYMASS(K(N+1,2))
34572 PM2=PYMASS(K(N+2,2))
34573 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
34574 KFLDUM=INT(1.5D0+PYR(0))
34575 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
34576 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
34577 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
34578 PSM=PYMASS(KF1)+PYMASS(KF2)
34579 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
34580 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
34581 IF(MMAT.EQ.48) GOTO 390
34582 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
34585 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
34586 IF(K(N+1,2).EQ.0) GOTO 260
34587 P(N+1,5)=PYMASS(K(N+1,2))
34590 PS=P(N+1,5)+P(N+2,5)
34591 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34598 C...Phase space decay of partons from W decay.
34599 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
34605 PV(1,J)=P(N+1,J)+P(N+2,J)
34614 PSQ=PYMASS(KFLO(1))
34616 PSQ=PSQ+PYMASS(KFLO(2))
34621 C...Boost back for rapidly moving particle.
34625 BE(J)=P(IP,J)/P(IP,4)
34629 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34631 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34633 P(I,4)=GA*(P(I,4)+BEP)
34637 C...Fill in position of decay vertex.
34645 C...Set up for parton shower evolution from jets.
34646 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
34650 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34651 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34652 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34653 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34654 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34655 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34657 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
34660 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34661 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
34662 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
34663 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34665 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34666 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
34669 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34670 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
34671 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
34672 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34674 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34675 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
34677 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
34682 KCP=PYCOMP(K(NSAV+1,2))
34683 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
34685 IF(KQP.LT.0) JCON=5
34686 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
34687 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
34688 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
34689 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
34691 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
34694 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
34695 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34696 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34697 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
34701 C...Mark decayed particle; special option for B-Bbar mixing.
34702 IF(K(IP,1).EQ.5) K(IP,1)=15
34703 IF(K(IP,1).LE.10) K(IP,1)=11
34704 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
34711 C*********************************************************************
34714 C...Handles flavour production in the decay of unstable particles
34715 C...and small string clusters.
34717 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
34719 C...Double precision and integer declarations.
34720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34721 INTEGER PYK,PYCHGE,PYCOMP
34723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34725 SAVE /PYDAT1/,/PYDAT2/
34728 C.. Call PYKFDI directly if no popcorn option is on
34729 IF(MSTJ(12).LT.2) THEN
34730 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34737 IF(KFL1.EQ.0) RETURN
34742 NMAX=MIN(MSTU(125),10)
34744 C.. Identify rank 0 cluster qq
34746 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
34749 C.. Join jets: Fails if store not empty
34750 IF(MSTU(121).GT.0) THEN
34754 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34755 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
34756 C.. Pick popcorn meson from store, return same qq, decrease store
34757 KF=MSTU(NSTO+MSTU(121))
34759 MSTU(121)=MSTU(121)-1
34761 C.. Generate new flavour. Then done if no diquark is generated
34762 100 CALL PYKFDI(KFL1,0,KFL3,KF)
34763 IF(MSTU(121).EQ.-1) GOTO 100
34765 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
34767 C.. Simple case if no dynamical popcorn suppressions are considered
34768 IF(MSTJ(12).LT.4) THEN
34769 IF(MSTU(121).EQ.0) RETURN
34772 CALL PYKFDI(KFPREV,0,KFL3,KFM)
34773 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
34774 IF(IABS(KFL3).LE.10)THEN
34781 C test output qq against fake Gamma, then return if no popcorn.
34784 CALL PYZDIS(1,2103,5D0,Z)
34786 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
34791 IF(MSTU(121).EQ.0) RETURN
34793 C..Set store size memory. Pick fake dynamical variables of qq.
34795 CALL PYPTDI(1,PX3,PY3)
34801 C.. Pick next popcorn meson, test with fake dynamical variables
34805 CALL PYKFDI(KFPREV,0,KFL3,KFM)
34806 IF(MSTU(121).EQ.-1) GOTO 100
34807 CALL PYPTDI(KFL3,PX3,PY3)
34808 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
34809 CALL PYZDIS(KFPREV,KFL3,PM,Z)
34816 IF(MSTJ(12).GT.4)THEN
34817 POPMN=SQRT((1D0-X)*(G/X-GB))
34818 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
34819 PTST=EXP((POPM-POPMN)*PARF(193))
34824 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
34827 IF(RTST.GT.PTST*GTST)THEN
34829 IF(RTST.GT.PTST) MSTU(121)=-1
34834 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
34835 IF(MSTU(121).GT.0) GOTO 110
34837 C.. Test accepted system size. If OK set global popcorn size variable.
34838 IF(NMES.GT.NMAX)THEN
34849 C********************************************************************
34852 C...Generates a new flavour pair and combines off a hadron
34854 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
34856 C...Double precision and integer declarations.
34857 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34858 INTEGER PYK,PYCHGE,PYCOMP
34860 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34861 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34862 SAVE /PYDAT1/,/PYDAT2/
34866 IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
34868 C...Default flavour values. Input consistency checks.
34873 IF(KF1A.EQ.0) RETURN
34875 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
34876 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
34877 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
34880 C...Check if tabulated flavour probabilities are to be used.
34881 IF(MSTJ(15).EQ.1) THEN
34882 IF(MSTJ(12).GE.5) CALL PYERRM(29,
34883 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
34884 & ' together with MSTJ(12)>=5 modification')
34886 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
34887 KFL1A=MOD(KF1A/1000,10)
34888 KFL1B=MOD(KF1A/100,10)
34890 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
34891 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
34892 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
34893 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
34897 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
34898 KFL2A=MOD(KF2A/1000,10)
34899 KFL2B=MOD(KF2A/100,10)
34901 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
34902 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
34903 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
34905 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
34908 C.. Recognize rank 0 diquark case
34910 KFDIQ=MAX(KF1A,KF2A)
34911 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
34913 C.. Join two flavours to meson or baryon. Test for popcorn.
34916 IF(KFDIQ.GT.10) THEN
34917 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
34918 & CALL PYNMES(KFDIQ)
34919 IF(MSTU(121).NE.0) RETURN
34927 C.. Separate incoming flavours, curtain flavour consistency check
34933 KFL1A=MOD(KF1A/1000,10)
34934 KFL1B=MOD(KF1A/100,10)
34937 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
34938 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
34939 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
34941 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) RETURN
34942 KFQOLD=KFL1A+KFL1B-KFQPOP
34945 C...Meson/baryon choice. Set number of mesons if starting a popcorn
34948 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
34949 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
34953 ELSEIF(KF1A.GT.10)THEN
34955 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
34956 IF(MSTU(121).GT.0) MBARY=-1
34959 C..x->H+q: Choose single vertex quark. Jump to form hadron.
34960 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
34961 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
34962 KFL3=ISIGN(KFQVER,-KFIN)
34966 C..x->H+qq: (IDW=proper PARF position for diquark weights)
34968 C.. q->B+qq: Get curtain quark, different weights for q->B+B and
34971 IF(MSTU(121).EQ.0) IDW=150
34973 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
34974 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
34975 C.. Shift to s-curtain parameters if needed
34976 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
34977 PARF(194)=PARF(138)*PARF(139)
34978 PARF(193)=PARJ(8)+PARJ(9)
34982 C.. x->H+qq: Get vertex quark
34983 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
34985 MSTU(121)=MSTU(121)-1
34986 IF(IDW.EQ.170) THEN
34987 IF(MSTU(121).EQ.0)THEN
34988 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
34990 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
34993 IF(MSTU(121).EQ.0)THEN
34994 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
34996 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
35002 RMES=PYR(0)*PARF(194)
35004 RMES=RMES-PARF(IPOS+IMES)
35005 IF(IMES.EQ.30) THEN
35010 IF(RMES.GT.0D0) GOTO 120
35013 IF(KMUL.EQ.2) KFJ=10003
35014 IF(KMUL.EQ.3) KFJ=10001
35015 IF(KMUL.EQ.4) KFJ=20003
35016 IF(KMUL.EQ.5) KFJ=5
35018 KFQVER=MOD(IMES,5)+1
35019 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
35020 IF(KFQVER.GT.3)THEN
35025 IF(MBARY.EQ.-1) IDW=170
35027 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
35028 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
35029 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
35030 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
35032 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
35036 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
35038 IF(KFQPOP.NE.KFQVER)THEN
35040 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
35041 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
35042 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
35044 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
35046 KFL3=ISIGN(KFDIQ,KFIN)
35048 C..x->M+y: flavour for meson.
35049 130 IF(MBARY.LE.0)THEN
35050 KFLA=MAX(KFQOLD,KFQVER)
35051 KFLB=MIN(KFQOLD,KFQVER)
35053 IF(KFLA.NE.KFQOLD) KFS=-KFS
35054 C... Form meson, with spin and flavour mixing for diagonal states.
35055 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
35056 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
35057 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
35060 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
35061 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
35062 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
35063 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
35064 IF(PYR(0).LT.PARJ(14)) KMUL=2
35065 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
35067 IF(RMUL.LT.PARJ(15)) KMUL=3
35068 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
35069 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
35072 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
35073 IF(KMUL.EQ.5) KFLS=5
35074 IF(KFLA.NE.KFLB)THEN
35075 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
35078 IMIX=2*KFLA+10*KMUL
35079 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
35080 & INT(RMIX+PARF(IMIX)))+KFLS
35081 IF(KFLA.GE.4) KF=110*KFLA+KFLS
35083 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
35084 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
35086 C..Optional extra suppression of eta and eta'.
35087 C..Allow shift to qq->B+q in old version (set IRANK to 0)
35088 IF(KF.EQ.221.OR.KF.EQ.331)THEN
35089 IF(PYR(0).GT.PARJ(25+KF/300))THEN
35090 IF(KF2A.GT.0) GOTO 130
35091 IF(MSTJ(12).LT.4) IRANK=0
35097 C.. x->B+y: Flavour for baryon
35100 IF(KF1A.LE.10) KFLA=KFQOLD
35101 KFLB=MOD(KFDIQ/1000,10)
35102 KFLC=MOD(KFDIQ/100,10)
35103 KFLDS=MOD(KFDIQ,10)
35104 KFLD=MAX(KFLA,KFLB,KFLC)
35105 KFLF=MIN(KFLA,KFLB,KFLC)
35106 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35108 C... SU(6) factors for formation of baryon.
35112 IF(KFLB.NE.KFLC)THEN
35115 IF(KFLB.GT.2) KDMAX=KDMAX+2
35117 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
35122 SU6MAX=PARF(140+KDMAX)
35125 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
35130 SU6OCT=PARF(60+KBARY)
35131 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
35132 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
35133 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
35135 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
35137 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
35139 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
35140 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
35142 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
35146 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
35149 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
35150 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
35152 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
35154 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
35155 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
35159 C...Use tabulated probabilities to select new flavour and hadron.
35160 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
35163 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
35166 ELSEIF(KTAB2.EQ.0) THEN
35175 DO 150 KT3=KT3L,KT3U
35176 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
35182 DO 170 KT3=KT3L,KT3U
35184 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
35185 IF(RFL.LE.0D0) GOTO 190
35190 C...Reconstruct flavour of produced quark/diquark.
35191 IF(KTAB3.LE.6) THEN
35194 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
35197 IF(KTAB3.GE.8) KFL3A=2
35198 IF(KTAB3.GE.11) KFL3A=3
35199 IF(KTAB3.GE.16) KFL3A=4
35200 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
35201 KFL3=1000*KFL3A+100*KFL3B+1
35202 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
35204 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
35207 C...Reconstruct meson code.
35208 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
35210 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35211 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
35213 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
35214 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35215 & 25*KTABS)) KF=330+2*KTABS+1
35216 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
35217 KFLA=MAX(KTAB1,KTAB3)
35218 KFLB=MIN(KTAB1,KTAB3)
35220 IF(KFLA.NE.KF1A) KFS=-KFS
35221 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35222 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
35224 IF(KFL1A.EQ.KFL3A) THEN
35225 KFLA=MAX(KFL1B,KFL3B)
35226 KFLB=MIN(KFL1B,KFL3B)
35227 IF(KFLA.NE.KFL1B) KFS=-KFS
35228 ELSEIF(KFL1A.EQ.KFL3B) THEN
35232 ELSEIF(KFL1B.EQ.KFL3A) THEN
35235 ELSEIF(KFL1B.EQ.KFL3B) THEN
35236 KFLA=MAX(KFL1A,KFL3A)
35237 KFLB=MIN(KFL1A,KFL3A)
35238 IF(KFLA.NE.KFL1A) KFS=-KFS
35240 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
35243 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35245 C...Reconstruct baryon code.
35247 IF(KTAB1.GE.7) THEN
35256 KFLD=MAX(KFLA,KFLB,KFLC)
35257 KFLF=MIN(KFLA,KFLB,KFLC)
35258 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35259 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
35260 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
35263 C...Check that constructed flavour code is an allowed one.
35264 IF(KFL2.NE.0) KFL3=0
35267 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
35275 C*********************************************************************
35278 C...Generates number of popcorn mesons and stores some relevant
35281 SUBROUTINE PYNMES(KFDIQ)
35283 C...Double precision and integer declarations.
35284 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35285 INTEGER PYK,PYCHGE,PYCOMP
35287 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35288 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35289 SAVE /PYDAT1/,/PYDAT2/
35292 IF(MSTJ(12).LT.2) RETURN
35294 C..Old version: Get 1 or 0 popcorn mesons
35295 IF(MSTJ(12).LT.5)THEN
35297 IF(KFDIQ.NE.0) THEN
35299 KFA=MOD(KFDIQA/1000,10)
35300 KFB=MOD(KFDIQA/100,10)
35303 IF(KFA.EQ.3) POPWT=PARF(133)
35304 IF(KFB.EQ.3) POPWT=PARF(134)
35305 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
35307 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
35311 C..New version: Store popcorn- or rank 0 diquark parameters
35314 PARF(194)=PARF(139)
35315 IF(KFDIQ.NE.0) THEN
35318 PARF(194)=PARF(140)
35320 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
35321 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
35322 & '(PYNMES:) Neglecting too large popcorn possibility')
35326 C..New version: Get number of popcorn mesons
35329 110 MSTU(121)=MSTU(121)+1
35330 RTST=RTST/PARF(194)
35331 IF(RTST.LT.1D0) GOTO 110
35332 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)).GT.
35333 & (2D0+PARF(135)*PARF(138)**MSTU(121))) GOTO 100
35337 C*********************************************************************
35340 C...Precalculates a set of diquark and popcorn weights.
35341 C.. (Results stored in order SU0,US0,SS1,UU1,SU1,US1,UD1)
35345 C...Double precision and integer declarations.
35346 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35347 INTEGER PYK,PYCHGE,PYCOMP
35349 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35350 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35351 SAVE /PYDAT1/,/PYDAT2/
35353 DIMENSION SU6(12),SU6M(7)
35356 C..Curtain tunneling factor T(D,q)/T(ud0,u).
35357 IF(MSTJ(12).GE.5) THEN
35359 PMUD1=PYMASS(2103)-PMUD0
35360 PMUS0=PYMASS(3201)-PMUD0
35361 PMUS1=PYMASS(3203)-PMUS0-PMUD0
35362 PMSS1=PYMASS(3303)-PMUS0-PMUD0
35363 PARF(151)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
35364 PARF(152)=EXP(-PARJ(8)*PMUS0)
35365 PARF(153)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*PARF(151)
35366 PARF(154)=EXP(-PARJ(8)*PMUD1)
35367 PARF(155)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*PARF(151)
35368 PARF(156)=EXP(-PARJ(8)*PMUS1)*PARF(152)
35369 PARF(157)=PARF(154)
35371 PAR2M=SQRT(PARJ(2))
35372 PAR3M=SQRT(PARJ(3))
35373 PAR4M=SQRT(PARJ(4))
35374 PARF(151)=PAR2M*PAR3M
35376 PARF(153)=PAR2M*PARJ(3)*PAR4M
35378 PARF(155)=PAR4M*PARF(151)
35379 PARF(156)=PAR4M*PARF(152)
35383 C.. Total tunneling factor tau(D,q)=T*vertex*spin.
35384 PARF(161)=PARF(151)
35385 PARF(162)=PARJ(2)*PARF(152)
35386 PARF(163)=PARJ(2)*6D0*PARF(153)
35387 PARF(164)=6D0*PARF(154)
35388 PARF(165)=3D0*PARF(155)
35389 PARF(166)=PARJ(2)*3D0*PARF(156)
35390 PARF(167)=3D0*PARF(157)
35393 PARF(150+I)=PARF(150+I)*PARF(160+I)
35396 C..Modified SU(6) factors.
35398 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
35399 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
35400 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
35403 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
35405 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
35406 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
35408 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
35409 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
35412 C..Total diquark quark*SU(6).
35413 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
35414 PARF(171)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
35415 PARF(172)=PARF(171)
35416 PARF(173)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
35417 PARF(174)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
35418 PARF(175)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
35419 PARF(176)=PARF(175)
35420 PARF(177)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
35422 C..SU(6)max q q' s,c,b
35423 SU6MUD =MAX(SU6(1) , SU6(8) )
35424 SU6M(7)=MAX(SU6(5) , SU6(12))
35425 SU6M(1)=MAX(SU6(7) ,SU6(2),SU6MUD )
35426 SU6M(4)=MAX(SU6(3) ,SU6(4),SU6(10))
35427 SU6M(5)=MAX(SU6(11),SU6(6),SU6M(7))
35432 IF(MSTJ(12).GE.5)THEN
35433 C..New version: tau for rank 0 diquark.
35434 PARF(181)=EXP(-PARJ(10)*PMUS0)
35435 PARF(182)=PARJ(2)*PARF(181)
35436 PARF(183)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*PARF(181)
35437 PARF(184)=3D0*EXP(-PARJ(10)*PMUD1)
35438 PARF(185)=3D0*EXP(-PARJ(10)*PMUS1)*PARF(181)
35439 PARF(186)=PARJ(2)*PARF(185)
35440 PARF(187)=2D0*PARF(184)
35442 C..New version: s/u curtain ratios.
35443 WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35444 PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35445 WU=1D0+PARF(187)+PARF(182)+PARF(186)+PARF(184)
35446 PARF(136)=(2D0*(PARF(181)+PARF(185))+PARF(183))/WU
35447 PARF(137)=(PARF(181)+PARF(185))*
35448 & (2D0+PARF(183)/(2D0*PARF(185)))/WU
35450 C..Old version: Shuffle PARJ(7) into tau
35451 PARF(162)=PARF(162)*PARJ(7)
35452 PARF(163)=PARF(163)*PARJ(7)
35453 PARF(166)=PARF(166)*PARJ(7)
35455 C..Old version: s/u curtain ratios.
35456 WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35457 PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35458 PARF(136)=PARF(135)*PARJ(6)*PARF(161)/PARF(162)
35459 PARF(137)=(1D0+PARF(167))*(2D0+PARF(162))/WU
35462 C..Combine SU(6), SU(6)max, tau and T into proper products
35464 PARF(180+I)=PARF(180+I)*PARF(170+I)
35465 PARF(170+I)=PARF(170+I)*PARF(160+I)
35466 PARF(160+I)=PARF(160+I)*SU6M(I)/SU6MUD
35467 PARF(150+I)=PARF(150+I)*SU6M(I)/SU6MUD
35470 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
35477 IF(MSTJ(12).LT.5)THEN
35478 C.. Old version: Resulting popcorn weights.
35480 WS=PARF(135)*PARF(138)
35482 PARF(132)=WQ*PARF(167)/PARF(157)
35483 PARF(133)=WQ*(PARF(166)/PARF(156)+WS*PARF(165)/PARF(155))/2D0
35484 PARF(134)=WQ*WS*PARF(163)/PARF(153)
35485 PARF(131)=WQ*((1D0+PARF(167))*(1D0+PARF(162)+WS*PARF(161))+
35486 & PARF(164)+WS*PARF(163)/2D0)/
35487 & ((1D0+PARF(157))*(1D0+2D0*PARF(152))+PARF(154)+PARF(153)/2D0)
35489 C..New version: Store weights for popcorn mesons,
35490 C..get prel. popcorn weights.
35491 DO 150 IPOS=201,1400
35499 DO 240 MR=170,180,10
35500 IF(MR.EQ.180) PARF(193)=PARJ(10)
35501 SQWT=2D0*(PARF(MR+2)+PARF(MR+6))/(1D0+PARF(MR+7)+PARF(MR+4))
35502 QQWT=PARF(MR+4)/(1D0+PARF(MR+7)+PARF(MR+4))
35504 IF(NMES.EQ.1) SQWT=PARJ(2)
35506 IF(MR.EQ.170.AND.KFQPOP.GT.3) GOTO 220
35507 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
35508 SQWT=PARF(MR+3)/(PARF(MR+1)+PARF(MR+5))
35510 IF(MR.EQ.170) PARF(193)=PARJ(8)+PARJ(9)
35511 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/PARF(185)+1D0)/2D0
35514 IF(MR.EQ.170.AND.KFQOLD.GT.3) GOTO 210
35515 IF(MR*NMES.EQ.170.AND.KFQPOP.EQ.1) GOTO 210
35516 IF(MR*NMES.EQ.180.AND.KFQPOP.NE.1) GOTO 210
35521 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
35522 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
35523 IF(PJWT.LE.0D0) GOTO 190
35524 IF(PJWT.GT.1D0) PJWT=1D0
35526 IMIX=2*KFQOLD+10*KMUL
35528 IF(KMUL.EQ.2) KFJ=10003
35529 IF(KMUL.EQ.3) KFJ=10001
35530 IF(KMUL.EQ.4) KFJ=20003
35531 IF(KMUL.EQ.5) KFJ=5
35533 KFLA=MAX(KFQOLD,KFQVER)
35534 KFLB=MIN(KFQOLD,KFQVER)
35535 SWT=PARJ(11+KFLA/3+KFLA/4)
35536 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
35538 QWT=SQWT/(2D0+SQWT)
35539 IF(KFQVER.LT.3)THEN
35540 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
35541 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
35543 IF(KFQVER.NE.KFQOLD)THEN
35545 KFM=100*KFLA+10*KFLB+KFJ
35546 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35547 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
35548 WTTOT=WTTOT+PARF(IPOS+IMES)
35551 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
35552 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
35553 IF(ID.EQ.5) DWT=PARF(IMIX)
35555 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35556 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
35557 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
35558 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
35559 PARF(IPOS+5*KMUL+ID)=
35560 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
35562 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
35568 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
35570 IF(MR.EQ.180) PARF(140)=
35571 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
35572 IF(MR.EQ.170) PARF(139-KFQPOP/3)=
35573 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
35579 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
35582 PARF(186)=PARF(186)/PARF(182)
35583 PARF(185)=PARF(185)/PARF(181)
35586 C..Recombine diquark weights to flavour and spin ratios
35587 DO 250 I=150,170,10
35588 WSWQ=(2D0*(PARF(I+1)+PARF(I+5))+PARF(I+3))/
35589 & (1D0+PARF(I+7)+PARF(I+4)+PARF(I+2)+PARF(I+6))
35590 WSSWSQ=PARF(I+3)/(PARF(I+1)+PARF(I+5))
35591 WQSWQQ=2D0*(PARF(I+2)+PARF(I+6))/(1D0+PARF(I+7)+PARF(I+4))
35592 WUUWQQ=PARF(I+4)/(1D0+PARF(I+7)+PARF(I+4))
35593 PARF(I+5)=PARF(I+5)/PARF(I+1)
35594 PARF(I+6)=PARF(I+6)/PARF(I+2)
35603 C*********************************************************************
35606 C...Generates transverse momentum according to a Gaussian.
35608 SUBROUTINE PYPTDI(KFL,PX,PY)
35610 C...Double precision and integer declarations.
35611 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35612 INTEGER PYK,PYCHGE,PYCOMP
35614 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35617 C...Generate p_T and azimuthal angle, gives p_x and p_y.
35619 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
35620 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
35621 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
35622 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
35630 C*********************************************************************
35633 C...Generates the longitudinal splitting variable z.
35635 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
35637 C...Double precision and integer declarations.
35638 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35639 INTEGER PYK,PYCHGE,PYCOMP
35641 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35642 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35643 SAVE /PYDAT1/,/PYDAT2/
35645 C...Check if heavy flavour fragmentation.
35649 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
35651 C...Lund symmetric scaling function: determine parameters of shape.
35652 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
35653 &MSTJ(11).GE.4) THEN
35655 IF(MSTJ(91).EQ.1) FA=PARJ(43)
35656 IF(KFLB.GE.10) FA=FA+PARJ(45)
35658 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
35661 IF(KFLA.GE.10) FC=FC-PARJ(45)
35662 IF(KFLB.GE.10) FC=FC+PARJ(45)
35663 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
35665 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
35666 FC=FC+FRED*FBB*PARF(100+KFLH)**2
35667 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
35669 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
35670 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
35673 IF(ABS(FC-1D0).GT.0.01D0) MC=2
35675 C...Determine position of maximum. Special cases for a = 0 or a = c.
35676 IF(FA.LT.0.02D0) THEN
35679 IF(FC.GT.FB) ZMAX=FB/FC
35680 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
35685 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
35686 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
35689 C...Subdivide z range if distribution very peaked near endpoint.
35691 IF(ZMAX.LT.0.1D0) THEN
35697 ZDIVC=ZDIV**(1D0-FC)
35698 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
35700 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
35702 FSCB=SQRT(4D0+(FC/FB)**2)
35703 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
35704 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
35705 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
35706 FINT=1D0+FB*(1D0-ZDIV)
35709 C...Choice of z, preweighted for peaks at low or high z.
35713 IF(FINT*PYR(0).LE.1D0) THEN
35715 ELSEIF(MC.EQ.1) THEN
35719 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
35722 ELSEIF(MMAX.EQ.3) THEN
35723 IF(FINT*PYR(0).LE.1D0) THEN
35725 FPRE=EXP(FB*(Z-ZDIV))
35727 Z=ZDIV+Z*(1D0-ZDIV)
35731 C...Weighting according to correct formula.
35732 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
35733 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
35734 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
35735 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
35736 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
35738 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
35740 FC=PARJ(50+MAX(1,KFLH))
35741 IF(MSTJ(91).EQ.1) FC=PARJ(59)
35743 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
35744 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
35745 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
35746 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
35749 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
35750 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
35757 C*********************************************************************
35760 C...Generates timelike parton showers from given partons.
35762 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
35764 C...Double precision and integer declarations.
35765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35766 INTEGER PYK,PYCHGE,PYCOMP
35768 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
35769 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35770 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35771 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
35773 DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
35774 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
35775 &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
35778 C...Initialization of cutoff masses etc.
35779 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
35780 &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN
35785 PMTH(1,21)=PYMASS(21)
35786 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
35787 PMTH(3,21)=2D0*PMTH(2,21)
35788 PMTH(4,21)=PMTH(3,21)
35789 PMTH(5,21)=PMTH(3,21)
35790 PMTH(1,22)=PYMASS(22)
35791 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
35792 PMTH(3,22)=2D0*PMTH(2,22)
35793 PMTH(4,22)=PMTH(3,22)
35794 PMTH(5,22)=PMTH(3,22)
35796 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
35798 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
35801 PMTH(1,IFL)=PYMASS(IFL)
35802 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
35803 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
35804 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
35805 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
35808 IF(MSTJ(41).GE.2) KSH(IFL)=1
35809 PMTH(1,IFL)=PYMASS(IFL)
35810 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)
35811 PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22)
35812 PMTH(4,IFL)=PMTH(3,IFL)
35813 PMTH(5,IFL)=PMTH(3,IFL)
35815 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
35817 ALFM=LOG(PT2MIN/ALAMS)
35819 C...Store positions of shower initiating partons.
35820 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
35823 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
35828 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
35829 & .AND.IP2.GE.-3) THEN
35836 & '(PYSHOW:) failed to reconstruct showering system')
35837 IF(MSTU(21).GE.1) RETURN
35840 C...Check on phase space available for emission.
35847 KFLA(I)=IABS(K(IPA(I),2))
35849 C...Special cutoff masses for t, l, h with variable masses.
35851 IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
35852 IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
35853 PMTH(1,IFLA)=PMA(I)
35854 PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PMQTH1**2)
35855 PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
35856 PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(82)**2)+
35858 PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(83)**2)+
35861 IF(KFLA(I).LE.40) THEN
35862 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
35865 IF(KFLA(I).GT.40) THEN
35868 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
35871 PS(J)=PS(J)+P(IPA(I),J)
35874 IF(IREJ.EQ.NPA) RETURN
35875 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
35876 IF(NPA.EQ.1) PS(5)=PS(4)
35877 IF(PS(5).LE.PM+PMQTH1) RETURN
35879 C...Check if 3-jet matrix elements to be used.
35881 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
35882 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
35883 & KFLA(2).LE.8) M3JC=1
35884 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
35885 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
35886 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
35887 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
35888 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
35889 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
35890 IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
35892 IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
35894 QME=(2D0*PMTH(1,KFLA(1))/PS(5))**2
35898 C...Find if interference with initial state partons.
35900 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
35904 KCA=PYCOMP(KFLA(I))
35905 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
35907 IF(KCII(I).NE.0) THEN
35909 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
35910 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
35911 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
35913 IIIS(I,NIIS(I))=ICSI
35918 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
35921 C...Boost interfering initial partons to rest frame
35922 C...and reconstruct their polar and azimuthal angles.
35926 K(N+I,J)=K(IPA(I),J)
35927 P(N+I,J)=P(IPA(I),J)
35931 DO 220 I=3,2+NIIS(1)
35933 K(N+I,J)=K(IIIS(1,I-2),J)
35934 P(N+I,J)=P(IIIS(1,I-2),J)
35938 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
35940 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
35941 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
35945 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
35946 & -PS(2)/PS(4),-PS(3)/PS(4))
35947 PHI=PYANGL(P(N+1,1),P(N+1,2))
35948 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
35949 THE=PYANGL(P(N+1,3),P(N+1,1))
35950 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
35951 DO 250 I=3,2+NIIS(1)
35952 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
35953 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
35955 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
35956 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
35957 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
35958 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
35962 C...Define imagined single initiator of shower for parton system.
35964 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
35965 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
35966 IF(MSTU(21).GE.1) RETURN
35983 C...Loop over partons that may branch.
35986 IF(NPA.EQ.1) IM=NS-1
35989 IF(IM.GT.N) GOTO 510
35991 IF(KFLM.GT.40) GOTO 270
35992 IF(KSH(KFLM).EQ.0) GOTO 270
35994 IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
35995 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
36000 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
36001 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36002 IF(MSTU(21).GE.1) RETURN
36005 C...Position of aunt (sister to branching parton).
36006 C...Origin and flavour of daughters.
36009 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
36010 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
36022 K(N+I,2)=K(IPA(I),2)
36024 ELSEIF(KFLM.NE.21) THEN
36027 ELSEIF(K(IM,5).EQ.21) THEN
36035 C...Reset flags on daughers and tries made.
36040 KFLD(IP)=IABS(K(N+IP,2))
36041 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
36045 IF(KFLD(IP).LE.40) THEN
36046 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
36051 C...Maximum virtuality of daughters.
36054 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
36055 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
36056 P(N+I,5)=MIN(QMAX,PS(5))
36057 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
36058 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
36061 IF(MSTJ(43).LE.2) PEM=V(IM,2)
36062 IF(MSTJ(43).GE.3) PEM=P(IM,4)
36063 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
36064 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
36065 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
36069 IF(ISI(I).EQ.1) THEN
36071 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36072 & ISIGN(2,K(N+I,2))
36073 IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
36075 V(N+I,5)=P(N+I,5)**2
36078 C...Choose one of the daughters for evolution.
36080 IF(NEP.EQ.1) INUM=1
36082 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
36085 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
36087 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36088 & ISIGN(2,K(N+I,2))
36089 IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
36095 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
36096 RPM=P(N+I,5)/PMSD(I)
36098 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36099 & ISIGN(2,K(N+I,2))
36100 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
36108 C...Store information on choice of evolving daughter.
36113 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
36116 KFL(I)=IABS(K(IEP(I),2))
36118 ITRY(INUM)=ITRY(INUM)+1
36119 IF(ITRY(INUM).GT.200) THEN
36120 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
36121 IF(MSTU(21).GE.1) RETURN
36124 IF(KFL(1).GT.40) GOTO 430
36125 IF(KSH(KFL(1)).EQ.0) GOTO 430
36127 IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
36128 &ISIGN(2,K(IEP(1),2))
36129 IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
36131 C...Select side for interference with initial state partons.
36132 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
36135 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
36137 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
36138 IF(PYR(0).GT.0.5D0) ISII(III)=1
36139 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
36141 IF(PYR(0).GT.0.5D0) ISII(III)=2
36145 C...Calculate allowed z range.
36148 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36151 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
36152 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
36154 IF(MOD(MSTJ(43),2).EQ.1) THEN
36156 ZCE=PMTH(2,22)/PMED
36158 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
36159 IF(ZC.LT.1D-4) ZC=(PMTH(2,21)/PMED)**2
36160 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,22)/PMED)**2)))
36161 IF(ZCE.LT.1D-4) ZCE=(PMTH(2,22)/PMED)**2
36164 ZCE=MIN(ZCE,0.491D0)
36165 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
36166 &MIN(ZC,ZCE).GT.0.49D0)) THEN
36167 P(IEP(1),5)=PMTH(1,IFL)
36168 V(IEP(1),5)=P(IEP(1),5)**2
36172 C...Integral of Altarelli-Parisi z kernel for QCD.
36173 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
36174 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*(0.5D0-ZC)
36175 ELSEIF(MSTJ(49).EQ.0) THEN
36176 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
36178 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
36179 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
36180 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
36181 ELSEIF(MSTJ(49).EQ.1) THEN
36182 FBR=(1D0-2D0*ZC)/3D0
36183 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4D0*FBR
36185 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
36186 ELSEIF(KFL(1).EQ.21) THEN
36187 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
36189 FBR=2D0*LOG((1D0-ZC)/ZC)
36192 C...Reset QCD probability for lepton.
36193 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0D0
36195 C...Integral of Altarelli-Parisi kernel for photon emission.
36196 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36197 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
36198 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
36201 C...Inner veto algorithm starts. Find maximum mass for evolution.
36202 390 PMS=V(IEP(1),5)
36207 IF(KFL(I).LE.40) THEN
36209 IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
36210 & ISIGN(2,K(IEP(I),2))
36211 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
36215 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
36218 C...Select mass for daughter in QCD evolution.
36220 DO 410 IFF=4,MSTJ(45)
36221 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
36223 IF(FBR.LT.1D-3) THEN
36225 ELSEIF(MSTJ(44).LE.0) THEN
36226 PMSQCD=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
36227 ELSEIF(MSTJ(44).EQ.1) THEN
36228 PMSQCD=4D0*ALAMS*(0.25D0*PMS/ALAMS)**(PYR(0)**(B0/FBR))
36230 PMSQCD=PMS*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
36232 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
36236 C...Select mass for daughter in QED evolution.
36237 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36238 PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
36239 IF(ZCE.GT.0.49D0.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
36241 IF(PMSQED.GT.PMSQCD) THEN
36247 C...Check whether daughter mass below cutoff.
36248 P(IEP(1),5)=SQRT(V(IEP(1),5))
36249 IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
36250 P(IEP(1),5)=PMTH(1,IFL)
36251 V(IEP(1),5)=P(IEP(1),5)**2
36255 C...Select z value of branching: q -> qgamma.
36257 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
36258 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36261 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
36262 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
36263 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36264 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36266 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5D0-ZC).LT.PYR(0)*FBR) THEN
36267 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36268 IF(PYR(0).GT.0.5D0) Z=1D0-Z
36269 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390
36271 ELSEIF(MSTJ(49).NE.1) THEN
36272 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36273 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390
36274 KFLB=1+INT(MSTJ(45)*PYR(0))
36275 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36276 IF(PMQ.GE.1D0) GOTO 390
36277 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
36278 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.
36279 & PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390
36282 C...Ditto for scalar gluon model.
36283 ELSEIF(KFL(1).NE.21) THEN
36284 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
36286 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
36287 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36290 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36291 KFLB=1+INT(MSTJ(45)*PYR(0))
36292 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36293 IF(PMQ.GE.1D0) GOTO 390
36296 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
36297 IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
36298 IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390
36301 C...Check if z consistent with chosen m.
36302 IF(KFL(1).EQ.21) THEN
36303 KFLGD1=IABS(K(IEP(1),5))
36307 KFLGD2=IABS(K(IEP(1),5))
36311 ELSEIF(NEP.GE.3) THEN
36313 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36314 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
36316 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
36317 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
36319 IF(MOD(MSTJ(43),2).EQ.1) THEN
36321 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
36322 PMQTH3=0.5D0*PARJ(82)
36323 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36324 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
36325 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
36326 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36330 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
36335 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
36336 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
36338 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36340 C...Width suppression for q -> q + g.
36341 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
36343 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
36347 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
36348 IF(MSTJ(40).EQ.1) THEN
36349 IF(CHI.LT.PYR(0)) GOTO 390
36350 ELSEIF(MSTJ(40).EQ.2) THEN
36351 IF(1D0-CHI.LT.PYR(0)) GOTO 390
36355 C...Three-jet matrix element correction.
36356 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
36357 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
36358 X2=1D0-V(IEP(1),5)/V(NS+1,5)
36359 X3=(1D0-X1)+(1D0-X2)
36362 KI2=K(IPA(3-INUM),2)
36363 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0
36364 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0
36365 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
36366 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
36367 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
36368 ELSEIF(MSTJ(49).NE.1) THEN
36369 WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
36370 & (1D0-X2)/X3*(X2/(2D0-X1))**2
36372 IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5D0*QME**2-
36373 & (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-7,1D0-X1)+
36374 & (1D0-X1)/MAX(1D-7,1D0-X2))
36376 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
36378 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
36381 IF(WME.LT.PYR(0)*WSHOW) GOTO 390
36383 C...Impose angular ordering by rejection of nonordered emission.
36384 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
36387 IF(IEP(1).EQ.N+2) ZM=1D0-V(IM,1)
36388 THE2ID=Z*(1D0-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
36390 420 IF(K(IAOM,5).EQ.22) THEN
36392 IF(K(IAOM,3).LE.NS) MAOM=0
36393 IF(MAOM.EQ.1) GOTO 420
36396 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
36397 IF(THE2ID.LT.THE2IM) GOTO 390
36401 C...Impose user-defined maximum angle at first branching.
36402 IF(MSTJ(48).EQ.1) THEN
36403 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
36404 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
36405 IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36406 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
36407 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36408 IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36409 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
36410 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36411 IF(THE2ID.LT.1D0/PARJ(86)**2) GOTO 390
36415 C...Impose angular constraint in first branching from interference
36416 C...with initial state partons.
36417 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
36418 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
36419 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
36420 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
36421 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
36422 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
36426 C...End of inner veto algorithm. Check if only one leg evolved so far.
36430 IF(NEP.EQ.1) GOTO 460
36431 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
36433 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
36434 IF(KSH(KFLD(I)).EQ.1) THEN
36436 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36437 & ISIGN(2,K(N+I,2))
36438 IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
36443 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
36445 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
36446 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
36447 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
36448 PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S-
36449 & PA1S**2-PA2S**2-PA3S**2)/PA1S
36450 IF(PTS.LE.0D0) GOTO 330
36451 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
36453 KFLDA=IABS(K(I1,2))
36454 IF(KFLDA.GT.40) GOTO 450
36455 IF(KSH(KFLDA).EQ.0) GOTO 450
36457 IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
36459 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
36460 IF(KFLDA.EQ.21) THEN
36461 KFLGD1=IABS(K(I1,5))
36465 KFLGD2=IABS(K(I1,5))
36468 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36469 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
36471 IF(I1.EQ.N+1) ZM=V(IM,1)
36472 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
36473 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
36474 & 4D0*V(N+1,5)*V(N+2,5))
36475 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
36477 IF(MOD(MSTJ(43),2).EQ.1) THEN
36478 PMQTH3=0.5D0*PARJ(82)
36479 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36481 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
36482 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
36483 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
36484 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36488 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
36493 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
36494 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
36495 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
36497 IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36499 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
36502 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
36503 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
36504 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
36505 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
36506 IF(ISL(1).EQ.1) ISL(2)=0
36507 IF(ISL(1).EQ.0) ISLM=1
36508 IF(ISL(2).EQ.0) ISLM=2
36510 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
36513 IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
36516 IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
36518 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
36519 &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
36520 PMQ1=V(N+1,5)/V(IM,5)
36521 PMQ2=V(N+2,5)/V(IM,5)
36522 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
36527 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
36530 C...Accepted branch. Construct four-momentum for initial partons.
36536 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
36538 P(N+1,4)=P(IPA(1),4)
36540 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
36541 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
36544 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
36549 P(N+2,4)=P(IM,5)-PED1
36552 ELSEIF(NEP.EQ.3) THEN
36555 P(N+1,3)=SQRT(MAX(0D0,PA1S))
36558 P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3)
36561 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
36566 C...Construct transverse momentum for ordinary branching in shower.
36569 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
36570 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
36571 IF(PZM.LE.0D0) THEN
36573 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
36574 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
36575 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
36577 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
36579 PT=SQRT(MAX(0D0,PTS))
36581 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
36583 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
36584 & .AND.IAU.NE.0) THEN
36585 IF(K(IGM,3).NE.0) MAZIP=1
36587 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
36588 IF(MAZIP.EQ.0) ZAU=0D0
36589 IF(K(IGM,2).NE.21) THEN
36590 HAZIP=2D0*ZAU/(1D0+ZAU**2)
36592 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
36594 IF(K(N+1,2).NE.21) THEN
36595 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
36597 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
36601 C...Find coefficient of azimuthal asymmetry due to soft gluon
36604 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
36605 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
36606 IF(K(IGM,3).NE.0) MAZIC=N+1
36607 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
36608 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36609 & ZM.GT.0.5D0) MAZIC=N+2
36610 IF(K(IAU,2).EQ.22) MAZIC=0
36612 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
36614 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
36615 IF(MAZIC.EQ.0) ZGM=1D0
36616 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
36617 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
36618 HAZIC=MIN(0.95D0,HAZIC)
36622 C...Construct kinematics for ordinary branching in shower.
36623 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
36624 IF(MOD(MSTJ(43),2).EQ.1) THEN
36625 P(N+1,4)=PEM*V(IM,1)
36627 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
36628 & SQRT(PMLS)*ZM)/V(IM,5)
36631 P(N+1,1)=PT*COS(PHI)
36632 P(N+1,2)=PT*SIN(PHI)
36633 IF(PZM.GT.0D0) THEN
36634 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
36635 & 2D0*PEM*P(N+1,4))/PZM
36641 P(N+2,3)=PZM-P(N+1,3)
36642 P(N+2,4)=PEM-P(N+1,4)
36643 IF(MSTJ(43).LE.2) THEN
36644 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
36645 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
36649 C...Rotate and boost daughters.
36651 IF(MSTJ(43).LE.2) THEN
36652 BEX=P(IGM,1)/P(IGM,4)
36653 BEY=P(IGM,2)/P(IGM,4)
36654 BEZ=P(IGM,3)/P(IGM,4)
36655 GA=P(IGM,4)/P(IGM,5)
36656 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
36665 THE=PYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
36666 & (P(IM,2)+GABEP*BEY)**2))
36667 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
36669 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
36670 & SIN(THE)*COS(PHI)*P(I,3)
36671 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
36672 & SIN(THE)*SIN(PHI)*P(I,3)
36673 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
36675 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
36676 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
36677 P(I,1)=DP(1)+DGABP*BEX
36678 P(I,2)=DP(2)+DGABP*BEY
36679 P(I,3)=DP(3)+DGABP*BEZ
36680 P(I,4)=GA*(DP(4)+DBP)
36684 C...Weight with azimuthal distribution, if required.
36685 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
36691 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
36692 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
36693 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
36695 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
36696 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
36698 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
36699 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
36700 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
36701 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
36702 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
36703 IF(MAZIP.NE.0) THEN
36704 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
36707 IF(MAZIC.NE.0) THEN
36708 IF(MAZIC.EQ.N+2) CAD=-CAD
36709 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
36710 & .LT.PYR(0)) GOTO 470
36715 C...Azimuthal anisotropy due to interference with initial state partons.
36716 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
36717 &K(N+2,2).EQ.21)) THEN
36719 IF(ISII(III).GE.1) THEN
36721 IF(K(N+1,2).NE.21) IAZIID=N+2
36722 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36723 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
36724 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
36725 IF(III.EQ.2) THEIID=PARU(1)-THEIID
36726 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
36727 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
36728 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
36729 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
36730 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
36731 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
36732 & .LT.PYR(0)) GOTO 470
36736 C...Continue loop over partons that may branch, until none left.
36737 IF(IGM.GE.0) K(IM,1)=14
36740 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
36741 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36742 IF(MSTU(21).GE.1) N=NS
36743 IF(MSTU(21).GE.1) RETURN
36747 C...Set information on imagined shower initiator.
36748 510 IF(NPA.GE.2) THEN
36752 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
36760 C...Reconstruct string drawing information.
36761 DO 520 I=NS+1+IIM,N
36762 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
36764 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
36765 & IABS(K(I,2)).LE.18) THEN
36767 ELSEIF(K(I,1).LE.10) THEN
36768 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
36769 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
36770 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
36771 ID1=MOD(K(I,4),MSTU(5))
36772 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
36773 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
36774 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36775 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
36776 K(ID1,4)=K(ID1,4)+MSTU(5)*I
36777 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
36778 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
36779 K(ID2,5)=K(ID2,5)+MSTU(5)*I
36781 ID1=MOD(K(I,4),MSTU(5))
36783 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36784 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
36785 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
36786 K(ID1,4)=K(ID1,4)+MSTU(5)*I
36787 K(ID1,5)=K(ID1,5)+MSTU(5)*I
36797 C...Transformation from CM frame.
36803 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
36804 & /(1D0+GA)-P(IPA(1),4))
36811 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
36812 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
36813 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
36815 CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
36816 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
36817 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
36820 CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0)
36823 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
36825 C...Decay vertex of shower.
36832 C...Delete trivial shower, else connect initiators.
36833 IF(N.EQ.NS+NPA+IIM) THEN
36838 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
36839 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
36840 K(NS+IIM+IP,3)=IPA(IP)
36841 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
36842 IF(K(NS+IIM+IP,1).NE.1) THEN
36843 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
36844 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
36852 C*********************************************************************
36855 C...Modifies an event so as to approximately take into account
36856 C...Bose-Einstein effects according to a simple phenomenological
36857 C...parametrization.
36859 SUBROUTINE PYBOEI(NSAV)
36861 C...Double precision and integer declarations.
36862 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36863 INTEGER PYK,PYCHGE,PYCOMP
36865 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
36866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36867 SAVE /PYJETS/,/PYDAT1/
36868 C...Local arrays and data.
36869 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
36870 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
36872 C...Boost event to overall CM frame. Calculate CM energy.
36873 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
36879 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
36880 & .AND.K(I,3).GT.0) THEN
36881 KFMA=IABS(K(K(I,3),2))
36882 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
36884 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
36886 DPS(J)=DPS(J)+P(I,J)
36889 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
36893 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
36896 C...Reserve copy of particles by species at end of record.
36898 DO 160 IBE=1,MIN(9,MSTJ(52))
36899 NBE(IBE)=NBE(IBE-1)
36901 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
36902 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
36903 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
36904 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
36907 NBE(IBE)=NBE(IBE)+1
36914 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
36916 C...Tabulate integral for subsequent momentum shift.
36917 DO 220 IBE=1,MIN(9,MSTJ(52))
36918 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
36919 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
36921 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
36922 & NBE(7)-NBE(6)).LE.1) GOTO 180
36923 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
36924 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
36925 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
36926 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
36927 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
36928 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
36929 IF(MSTJ(51).EQ.1) THEN
36930 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
36931 BEEX=EXP(0.5D0*QDEL/PARJ(93))
36932 BERT=EXP(-QDEL/PARJ(93))
36934 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
36937 QBIN=QDEL*(IBIN-0.5D0)
36938 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
36939 IF(MSTJ(51).EQ.1) THEN
36941 BEI(IBIN)=BEI(IBIN)*BEEX
36943 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
36945 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
36948 C...Loop through particle pairs and find old relative momentum.
36949 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
36951 DO 200 I2M=I1M+1,NBE(IBE)
36953 Q2OLD=MAX(0D0,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
36954 & (P(I1,2)+ P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
36955 & (P(I1,5)+P(I2,5))**2)
36958 C...Calculate new relative momentum.
36959 IF(QOLD.LT.1D-3*QDEL) THEN
36961 ELSEIF(QOLD.LE.QDEL) THEN
36963 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
36966 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
36967 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
36968 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
36970 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
36972 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
36974 C...Calculate and save shift to be performed on three-momenta.
36975 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
36976 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
36977 HA=0.5D0*(1D0-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
36979 PD=HA*(P(I2,J)-P(I1,J))
36980 P(I1M,J)=P(I1M,J)+PD
36981 P(I2M,J)=P(I2M,J)-PD
36987 C...Shift momenta and recalculate energies.
36988 DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
36991 P(I,J)=P(I,J)+P(IM,J)
36993 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
36996 C...Rescale all momenta for energy conservation.
37000 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
37002 PQS=PQS+P(I,5)**2/P(I,4)
37004 FAC=(PECM-PQS)/(PES-PQS)
37006 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
37010 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
37013 C...Boost back to correct reference frame.
37014 280 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
37016 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
37022 C*********************************************************************
37025 C...Gives the mass of a particle/parton.
37027 FUNCTION PYMASS(KF)
37029 C...Double precision and integer declarations.
37030 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37031 INTEGER PYK,PYCHGE,PYCOMP
37033 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37034 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37035 SAVE /PYDAT1/,/PYDAT2/
37037 C...Reset variables. Compressed code. Special case for popcorn diquarks.
37046 C...Guarantee use of constituent masses for internal checks.
37047 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
37048 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
37049 PARF(106)=PMAS(6,1)
37050 PARF(107)=PMAS(7,1)
37051 PARF(108)=PMAS(8,1)
37053 PYMASS=PARF(100+KFA)
37054 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
37055 ELSEIF(MSTJ(93).EQ.1) THEN
37056 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
37058 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
37061 C...Other masses can be read directly off table.
37066 C...Optional mass broadening according to truncated Breit-Wigner
37067 C...(either in m or in m^2).
37068 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
37069 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
37070 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
37071 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
37074 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
37075 & (PM0*PMAS(KC,2)))
37076 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
37077 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
37078 & (PMUPP-PMLOW)*PYR(0))))
37086 C*********************************************************************
37089 C...Gives the particle/parton name as a character string.
37091 SUBROUTINE PYNAME(KF,CHAU)
37093 C...Double precision and integer declarations.
37094 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37095 INTEGER PYK,PYCHGE,PYCOMP
37097 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37098 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37099 COMMON/PYDAT4/CHAF(500,2)
37101 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
37102 C...Local character variable.
37105 C...Read out code with distinction particle/antiparticle.
37108 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
37114 C*********************************************************************
37117 C...Gives three times the charge for a particle/parton.
37119 FUNCTION PYCHGE(KF)
37121 C...Double precision and integer declarations.
37122 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37123 INTEGER PYK,PYCHGE,PYCOMP
37125 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37128 C...Read out charge and change sign for antiparticle.
37131 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
37136 C*********************************************************************
37139 C...Compress the standard KF codes for use in mass and decay arrays;
37140 C...also checks whether a given code actually is defined.
37142 FUNCTION PYCOMP(KF)
37144 C...Double precision and integer declarations.
37145 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37146 INTEGER PYK,PYCHGE,PYCOMP
37148 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37149 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37150 SAVE /PYDAT1/,/PYDAT2/
37151 C...Local arrays and saved data.
37152 DIMENSION KFORD(100:500),KCORD(101:500)
37153 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
37155 C...Whenever necessary reorder codes for faster search.
37156 IF(MSTU(20).EQ.0) THEN
37161 IF(KFA.LE.100) GOTO 120
37163 DO 100 I1=NFORD-1,0,-1
37164 IF(KFA.GE.KFORD(I1)) GOTO 110
37165 KFORD(I1+1)=KFORD(I1)
37166 KCORD(I1+1)=KCORD(I1)
37168 110 KFORD(I1+1)=KFA
37176 C...Fast action if same code as in latest call.
37177 IF(KF.EQ.KFLAST) THEN
37182 C...Starting values. Remove internal diquark flags.
37185 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
37186 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
37188 C...Simple cases: direct translation.
37189 IF(KFA.GT.KFORD(NFORD)) THEN
37190 ELSEIF(KFA.LE.100) THEN
37193 C...Else binary search.
37197 130 IAVG=(IMIN+IMAX)/2
37198 IF(KFORD(IAVG).GT.KFA) THEN
37200 IF(IMAX.GT.IMIN+1) GOTO 130
37201 ELSEIF(KFORD(IAVG).LT.KFA) THEN
37203 IF(IMAX.GT.IMIN+1) GOTO 130
37209 C...Check if antiparticle allowed.
37210 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
37211 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
37214 C...Save codes for possible future fast action.
37221 C*********************************************************************
37224 C...Informs user of errors in program execution.
37226 SUBROUTINE PYERRM(MERR,CHMESS)
37228 C...Double precision and integer declarations.
37229 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37230 INTEGER PYK,PYCHGE,PYCOMP
37232 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37233 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37234 SAVE /PYJETS/,/PYDAT1/
37235 C...Local character variable.
37236 CHARACTER CHMESS*(*)
37238 C...Write first few warnings, then be silent.
37239 IF(MERR.LE.10) THEN
37240 MSTU(27)=MSTU(27)+1
37242 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
37243 & MERR,MSTU(31),CHMESS
37245 C...Write first few errors, then be silent or stop program.
37246 ELSEIF(MERR.LE.20) THEN
37247 MSTU(23)=MSTU(23)+1
37249 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
37250 & MERR-10,MSTU(31),CHMESS
37251 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
37252 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
37253 WRITE(MSTU(11),5200)
37254 IF(MERR.NE.17) CALL PYLIST(2)
37258 C...Stop program in case of irreparable error.
37260 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
37264 C...Formats for output.
37265 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
37266 &' PYEXEC calls:'/5X,A)
37267 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
37268 &' PYEXEC calls:'/5X,A)
37269 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
37271 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
37272 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
37277 C*********************************************************************
37280 C...Calculates the running alpha_electromagnetic.
37282 FUNCTION PYALEM(Q2)
37284 C...Double precision and integer declarations.
37285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37286 INTEGER PYK,PYCHGE,PYCOMP
37288 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37291 C...Calculate real part of photon vacuum polarization.
37292 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
37293 C...For hadrons use parametrization of H. Burkhardt et al.
37294 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
37295 AEMPI=PARU(101)/(3D0*PARU(1))
37296 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
37298 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
37300 ELSEIF(MSTU(101).EQ.2) THEN
37301 RPIGG=1D0-PARU(101)/PARU(103)
37302 ELSEIF(Q2.LT.0.09D0) THEN
37303 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
37304 ELSEIF(Q2.LT.9D0) THEN
37305 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
37306 & 0.00238D0*LOG(1D0+3.927D0*Q2)
37307 ELSEIF(Q2.LT.1D4) THEN
37308 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
37309 & 0.00299D0*LOG(1D0+Q2)
37311 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
37312 & 0.00293D0*LOG(1D0+Q2)
37315 C...Calculate running alpha_em.
37316 PYALEM=PARU(101)/(1D0-RPIGG)
37322 C*********************************************************************
37325 C...Gives the value of alpha_strong.
37327 FUNCTION PYALPS(Q2)
37329 C...Double precision and integer declarations.
37330 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37331 INTEGER PYK,PYCHGE,PYCOMP
37333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37335 SAVE /PYDAT1/,/PYDAT2/
37337 C...Constant alpha_strong trivial. Pick artificial Lambda.
37338 IF(MSTU(111).LE.0) THEN
37340 MSTU(118)=MSTU(112)
37342 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
37343 & ((33D0-2D0*MSTU(112))*PARU(111)))
37344 PARU(118)=PARU(111)
37348 C...Find effective Q2, number of flavours and Lambda.
37350 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
37353 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
37354 Q2THR=PARU(113)*PMAS(NF,1)**2
37355 IF(Q2EFF.LT.Q2THR) THEN
37357 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
37361 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
37362 Q2THR=PARU(113)*PMAS(NF+1,1)**2
37363 IF(Q2EFF.GT.Q2THR) THEN
37365 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
37369 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
37370 PARU(117)=SQRT(ALAM2)
37372 C...Evaluate first or second order alpha_strong.
37373 B0=(33D0-2D0*NF)/6D0
37374 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
37375 IF(MSTU(111).EQ.1) THEN
37376 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
37378 B1=(153D0-19D0*NF)/6D0
37379 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
37388 C*********************************************************************
37391 C...Reconstructs an angle from given x and y coordinates.
37393 FUNCTION PYANGL(X,Y)
37395 C...Double precision and integer declarations.
37396 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37397 INTEGER PYK,PYCHGE,PYCOMP
37399 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37404 IF(R.LT.1D-20) RETURN
37405 IF(ABS(X)/R.LT.0.8D0) THEN
37406 PYANGL=SIGN(ACOS(X/R),Y)
37409 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
37410 PYANGL=PARU(1)-PYANGL
37411 ELSEIF(X.LT.0D0) THEN
37412 PYANGL=-PARU(1)-PYANGL
37419 C*********************************************************************
37422 C...Generates random numbers uniformly distributed between
37423 C...0 and 1, excluding the endpoints.
37425 **sr renamed for use of internal dpmjet3 random number generator
37426 FUNCTION XPYR(IDUMMY)
37429 C...Double precision and integer declarations.
37430 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37431 INTEGER PYK,PYCHGE,PYCOMP
37433 COMMON/PYDATR/MRPY(6),RRPY(100)
37435 C...Equivalence between commonblock and local variables.
37436 EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
37437 &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
37438 &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
37440 C...Initialize generation from given seed.
37441 IF(MRPY2.EQ.0) THEN
37442 IJ=MOD(MRPY1/30082,31329)
37443 KL=MOD(MRPY1,30082)
37444 I=MOD(IJ/177,177)+2
37446 K=MOD(KL/169,178)+1
37452 M=MOD(MOD(I*J,179)*K,179)
37457 IF(MOD(L*M,64).GE.32) S=S+T
37464 TWOM24=0.5D0*TWOM24
37466 RRPY98=362436D0*TWOM24
37467 RRPY99=7654321D0*TWOM24
37468 RRPY00=16777213D0*TWOM24
37475 C...Generate next random number.
37476 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
37477 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37480 IF(MRPY4.EQ.0) MRPY4=97
37482 IF(MRPY5.EQ.0) MRPY5=97
37483 RRPY98=RRPY98-RRPY99
37484 IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
37486 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37487 IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
37489 C...Update counters. Random number to output.
37491 IF(MRPY3.EQ.1000000000) THEN
37500 C*********************************************************************
37503 C...Dumps the state of the random number generator on a file
37504 C...for subsequent startup from this state onwards.
37506 SUBROUTINE PYRGET(LFN,MOVE)
37508 C...Double precision and integer declarations.
37509 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37510 INTEGER PYK,PYCHGE,PYCOMP
37512 COMMON/PYDATR/MRPY(6),RRPY(100)
37514 C...Local character variable.
37517 C...Backspace required number of records (or as many as there are).
37519 NBCK=MIN(MRPY(6),-MOVE)
37521 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
37523 MRPY(6)=MRPY(6)-NBCK
37526 C...Unformatted write on unit LFN.
37527 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37528 &(RRPY(I2),I2=1,100)
37533 110 WRITE(CHERR,'(I8)') IERR
37534 CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
37540 C*********************************************************************
37543 C...Reads a state of the random number generator from a file
37544 C...for subsequent generation from this state onwards.
37546 SUBROUTINE PYRSET(LFN,MOVE)
37548 C...Double precision and integer declarations.
37549 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37550 INTEGER PYK,PYCHGE,PYCOMP
37552 COMMON/PYDATR/MRPY(6),RRPY(100)
37554 C...Local character variable.
37557 C...Backspace required number of records (or as many as there are).
37559 NBCK=MIN(MRPY(6),-MOVE)
37561 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
37563 MRPY(6)=MRPY(6)-NBCK
37566 C...Unformatted read from unit LFN.
37569 READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37570 & (RRPY(I2),I2=1,100)
37572 MRPY(6)=MRPY(6)+NFOR
37576 120 WRITE(CHERR,'(I8)') IERR
37577 CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
37583 C*********************************************************************
37586 C...Performs rotations and boosts.
37588 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
37590 C...Double precision and integer declarations.
37591 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37592 INTEGER PYK,PYCHGE,PYCOMP
37594 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37596 SAVE /PYJETS/,/PYDAT1/
37598 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
37600 C...Find and check range of rotation/boost.
37602 IF(IMIN.LE.0) IMIN=1
37603 IF(MSTU(1).GT.0) IMIN=MSTU(1)
37605 IF(IMAX.LE.0) IMAX=N
37606 IF(MSTU(2).GT.0) IMAX=MSTU(2)
37607 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
37608 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
37612 C...Optional resetting of V (when not set before.)
37613 IF(MSTU(33).NE.0) THEN
37614 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
37622 C...Rotate, typically from z axis to direction (theta,phi).
37623 IF(THE**2+PHI**2.GT.1D-20) THEN
37624 ROT(1,1)=COS(THE)*COS(PHI)
37626 ROT(1,3)=SIN(THE)*COS(PHI)
37627 ROT(2,1)=COS(THE)*SIN(PHI)
37629 ROT(2,3)=SIN(THE)*SIN(PHI)
37634 IF(K(I,1).LE.0) GOTO 140
37640 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
37641 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
37646 C...Boost, typically from rest to momentum/energy=beta.
37647 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
37651 DB=SQRT(DBX**2+DBY**2+DBZ**2)
37653 IF(DB.GT.EPS1) THEN
37654 C...Rescale boost vector if too close to unity.
37655 CALL PYERRM(3,'(PYROBO:) boost vector too large')
37661 DGA=1D0/SQRT(1D0-DB**2)
37663 IF(K(I,1).LE.0) GOTO 160
37668 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
37669 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
37670 P(I,1)=DP(1)+DGABP*DBX
37671 P(I,2)=DP(2)+DGABP*DBY
37672 P(I,3)=DP(3)+DGABP*DBZ
37673 P(I,4)=DGA*(DP(4)+DBP)
37674 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
37675 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
37676 V(I,1)=DV(1)+DGABV*DBX
37677 V(I,2)=DV(2)+DGABV*DBY
37678 V(I,3)=DV(3)+DGABV*DBZ
37679 V(I,4)=DGA*(DV(4)+DBV)
37686 C*********************************************************************
37689 C...Performs global manipulations on the event record, in particular
37690 C...to exclude unstable or undetectable partons/particles.
37692 SUBROUTINE PYEDIT(MEDIT)
37694 C...Double precision and integer declarations.
37695 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37696 INTEGER PYK,PYCHGE,PYCOMP
37698 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37699 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37700 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37701 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37703 DIMENSION NS(2),PTS(2),PLS(2)
37705 C...Remove unwanted partons/particles.
37706 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
37708 IF(MSTU(2).GT.0) IMAX=MSTU(2)
37709 I1=MAX(1,MSTU(1))-1
37710 DO 110 I=MAX(1,MSTU(1)),IMAX
37711 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
37712 IF(MEDIT.EQ.1) THEN
37713 IF(K(I,1).GT.10) GOTO 110
37714 ELSEIF(MEDIT.EQ.2) THEN
37715 IF(K(I,1).GT.10) GOTO 110
37717 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
37719 ELSEIF(MEDIT.EQ.3) THEN
37720 IF(K(I,1).GT.10) GOTO 110
37722 IF(KC.EQ.0) GOTO 110
37723 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
37724 ELSEIF(MEDIT.EQ.5) THEN
37725 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
37727 IF(KC.EQ.0) GOTO 110
37728 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
37731 C...Pack remaining partons/particles. Origin no longer known.
37740 IF(I1.LT.N) MSTU(3)=0
37741 IF(I1.LT.N) MSTU(70)=0
37744 C...Selective removal of class of entries. New position of retained.
37745 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
37748 K(I,3)=MOD(K(I,3),MSTU(5))
37749 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
37750 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
37751 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
37752 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
37753 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
37754 & K(I,2).EQ.94)) GOTO 120
37755 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
37757 K(I,3)=K(I,3)+MSTU(5)*I1
37760 C...Find new event history information and replace old.
37762 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
37765 130 IM=MOD(K(ID,3),MSTU(5))
37766 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
37767 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
37768 & K(IM,2).NE.94) THEN
37772 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
37773 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
37778 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
37779 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
37780 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
37781 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
37782 & K(K(I,4),3)/MSTU(5)
37783 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
37784 & K(K(I,5),3)/MSTU(5)
37786 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
37787 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
37788 KCD=MOD(K(I,4),MSTU(5))
37789 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
37790 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
37791 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
37792 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
37793 KCD=MOD(K(I,5),MSTU(5))
37794 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
37795 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
37799 C...Pack remaining entries.
37804 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
37811 K(I1,3)=MOD(K(I1,3),MSTU(5))
37813 IF(I.EQ.MSTU(90+IZ)) THEN
37814 MSTU(90)=MSTU(90)+1
37815 MSTU(90+MSTU(90))=I1
37816 PARU(90+MSTU(90))=PARU(90+IZ)
37820 IF(I1.LT.N) MSTU(3)=0
37821 IF(I1.LT.N) MSTU(70)=0
37824 C...Fill in some missing daughter pointers (lost in colour flow).
37825 ELSEIF(MEDIT.EQ.16) THEN
37827 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
37828 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
37829 C...Find daughters who point to mother.
37831 IF(K(I1,3).NE.I) THEN
37832 ELSEIF(K(I,4).EQ.0) THEN
37838 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
37839 IF(K(I,4).NE.0) GOTO 220
37840 C...Find daughters who point to documentation version of mother.
37842 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
37843 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
37844 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
37846 IF(K(I1,3).NE.IM) THEN
37847 ELSEIF(K(I,4).EQ.0) THEN
37853 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
37854 IF(K(I,4).NE.0) GOTO 220
37855 C...Find daughters who point to documentation daughters who,
37856 C...in their turn, point to documentation mother.
37860 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
37862 IF(ID1.EQ.IM) ID1=I1
37866 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
37867 ELSEIF(K(I,4).EQ.0) THEN
37873 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
37876 C...Save top entries at bottom of PYJETS commonblock.
37877 ELSEIF(MEDIT.EQ.21) THEN
37878 IF(2*N.GE.MSTU(4)) THEN
37879 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
37884 K(MSTU(4)-I,J)=K(I,J)
37885 P(MSTU(4)-I,J)=P(I,J)
37886 V(MSTU(4)-I,J)=V(I,J)
37891 C...Restore bottom entries of commonblock PYJETS to top.
37892 ELSEIF(MEDIT.EQ.22) THEN
37893 DO 260 I=1,MSTU(32)
37895 K(I,J)=K(MSTU(4)-I,J)
37896 P(I,J)=P(MSTU(4)-I,J)
37897 V(I,J)=V(MSTU(4)-I,J)
37902 C...Mark primary entries at top of commonblock PYJETS as untreated.
37903 ELSEIF(MEDIT.EQ.23) THEN
37908 IF(K(KH,1).GT.20) KH=0
37910 IF(KH.NE.0) GOTO 280
37912 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
37916 C...Place largest axis along z axis and second largest in xy plane.
37917 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
37918 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
37919 & P(MSTU(61),2)),0D0,0D0,0D0)
37920 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
37921 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
37922 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
37923 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
37924 IF(MEDIT.EQ.31) RETURN
37926 C...Rotate to put slim jet along +z axis.
37933 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
37934 IF(MSTU(41).GE.2) THEN
37936 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
37937 & KC.EQ.18) GOTO 300
37938 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
37941 IS=2D0-SIGN(0.5D0,P(I,3))
37943 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
37945 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
37946 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
37948 C...Rotate to put second largest jet into -z,+x quadrant.
37950 IF(P(I,3).GE.0D0) GOTO 310
37951 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
37952 IF(MSTU(41).GE.2) THEN
37954 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
37955 & KC.EQ.18) GOTO 310
37956 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
37959 IS=2D0-SIGN(0.5D0,P(I,1))
37960 PLS(IS)=PLS(IS)-P(I,3)
37962 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
37969 C*********************************************************************
37972 C...Gives program heading, or lists an event, or particle
37973 C...data, or current parameter values.
37975 SUBROUTINE PYLIST(MLIST)
37977 C...Double precision and integer declarations.
37978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37979 INTEGER PYK,PYCHGE,PYCOMP
37980 C...Parameter statement to help give large particle numbers.
37981 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
37983 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37984 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37985 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37986 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
37987 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
37988 C...Local arrays, character variables and data.
37989 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
37991 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
37993 C...Initialization printout: version number and date of last change.
37994 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
37997 IF(MLIST.EQ.0) RETURN
38000 C...List event data, including additional lines after N.
38001 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
38002 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
38003 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
38004 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
38006 IF(MLIST.GE.2) LMX=16
38009 IF(MSTU(2).GT.0) IMAX=MSTU(2)
38010 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
38011 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
38013 C...Get particle name, pad it and check it is not too long.
38014 CALL PYNAME(K(I,2),CHAP)
38017 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
38021 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
38023 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
38026 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
38028 CHAC=CHDL(MDL)(1:2*LDL)//' '
38030 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
38031 & CHDL(MDL)(LDL+1:2*LDL)//' '
38032 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
38036 C...Add information on string connection.
38037 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
38041 IF(KC.NE.0) KCC=KCHG(KC,2)
38042 IF(IABS(K(I,2)).EQ.39) THEN
38043 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
38044 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
38046 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
38047 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
38048 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
38049 ELSEIF(KCC.NE.0) THEN
38051 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
38055 C...Write data for particle/jet.
38056 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
38057 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
38059 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
38060 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
38062 ELSEIF(MLIST.EQ.1) THEN
38063 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
38065 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
38066 & K(I,1).EQ.14)) THEN
38067 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
38068 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
38069 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
38072 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
38075 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
38077 C...Insert extra separator lines specified by user.
38078 IF(MSTU(70).GE.1) THEN
38080 DO 110 J=1,MIN(10,MSTU(70))
38081 IF(I.EQ.MSTU(70+J)) ISEP=1
38083 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
38084 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
38088 C...Sum of charges and momenta.
38092 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
38093 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
38094 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
38095 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
38096 ELSEIF(MLIST.EQ.1) THEN
38097 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
38099 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
38102 C...Give simple list of KF codes defined in program.
38103 ELSEIF(MLIST.EQ.11) THEN
38104 WRITE(MSTU(11),6600)
38106 CALL PYNAME(KF,CHAP)
38107 CALL PYNAME(-KF,CHAN)
38108 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38109 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38113 DO 150 KFLB=1,KFLA-(3-KFLS)/2
38114 KF=1000*KFLA+100*KFLB+KFLS
38115 CALL PYNAME(KF,CHAP)
38116 CALL PYNAME(-KF,CHAN)
38117 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38122 CALL PYNAME(KF,CHAP)
38123 WRITE(MSTU(11),6700) KF,CHAP
38125 CALL PYNAME(KF,CHAP)
38126 WRITE(MSTU(11),6700) KF,CHAP
38129 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
38130 IF(KMUL.EQ.5) KFLS=5
38132 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
38133 IF(KMUL.EQ.4) KFLR=2
38135 DO 180 KFLC=1,KFLB-1
38136 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
38137 CALL PYNAME(KF,CHAP)
38138 CALL PYNAME(-KF,CHAN)
38139 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38141 KF=10000*KFLR+110*KFLB+KFLS
38142 CALL PYNAME(KF,CHAP)
38143 WRITE(MSTU(11),6700) KF,CHAP
38147 CALL PYNAME(KF,CHAP)
38148 WRITE(MSTU(11),6700) KF,CHAP
38150 CALL PYNAME(KF,CHAP)
38151 WRITE(MSTU(11),6700) KF,CHAP
38157 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
38159 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
38160 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
38161 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
38162 CALL PYNAME(KF,CHAP)
38163 CALL PYNAME(-KF,CHAN)
38164 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38169 DO 250 KF=KSUSY1+1,KSUSY1+40
38170 CALL PYNAME(KF,CHAP)
38171 CALL PYNAME(-KF,CHAN)
38172 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38173 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38175 DO 260 KF=KSUSY2+1,KSUSY2+40
38176 CALL PYNAME(KF,CHAP)
38177 CALL PYNAME(-KF,CHAN)
38178 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38179 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38181 DO 270 KF=KEXCIT+1,KEXCIT+40
38182 CALL PYNAME(KF,CHAP)
38183 CALL PYNAME(-KF,CHAN)
38184 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38185 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38188 C...List parton/particle data table. Check whether to be listed.
38189 ELSEIF(MLIST.EQ.12) THEN
38190 WRITE(MSTU(11),6800)
38191 DO 300 KC=1,MSTU(6)
38193 IF(KF.EQ.0) GOTO 300
38194 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
38197 C...Find particle name and mass. Print information.
38198 CALL PYNAME(KF,CHAP)
38199 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
38200 CALL PYNAME(-KF,CHAN)
38201 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
38202 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
38204 C...Particle decay: channel number, branching ratios, matrix element,
38205 C...decay products.
38206 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38208 CALL PYNAME(KFDP(IDC,J),CHAD(J))
38210 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38215 C...List parameter value table.
38216 ELSEIF(MLIST.EQ.13) THEN
38217 WRITE(MSTU(11),7100)
38219 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
38223 C...Format statements for output on unit MSTU(11) (by default 6).
38224 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
38225 &5X,'KF orig p_x p_y p_z E m'/)
38226 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
38227 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
38228 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
38229 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
38230 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
38231 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
38232 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
38233 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
38234 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
38235 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
38236 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
38237 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
38238 5900 FORMAT(66X,5(1X,F12.3))
38239 6000 FORMAT(1X,78('='))
38240 6100 FORMAT(1X,130('='))
38241 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
38242 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
38243 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
38244 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
38246 6600 FORMAT(///20X,'List of KF codes in program'/)
38247 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
38248 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
38249 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
38250 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
38251 &1X,'ME',3X,'Br.rat.',4X,'decay products')
38252 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
38253 &1X,1P,E13.5,3X,I2)
38254 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
38255 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
38256 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
38257 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
38262 C*********************************************************************
38265 C...Writes a logo for the program.
38269 C...Double precision and integer declarations.
38270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38271 INTEGER PYK,PYCHGE,PYCOMP
38272 C...Parameter for length of information block.
38273 PARAMETER (IREFER=17)
38275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38276 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38277 SAVE /PYDAT1/,/PYPARS/
38278 C...Local arrays and character variables.
38280 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
38281 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
38283 C...Data on months, logo, titles, and references.
38284 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
38285 &'Oct','Nov','Dec'/
38286 DATA (LOGO(J),J=1,19)/
38288 &' *:::!!:::::::::::* ',
38289 &' *::::::!!::::::::::::::* ',
38290 &' *::::::::!!::::::::::::::::* ',
38291 &' *:::::::::!!:::::::::::::::::* ',
38292 &' *:::::::::!!:::::::::::::::::* ',
38293 &' *::::::::!!::::::::::::::::*! ',
38294 &' *::::::!!::::::::::::::* !! ',
38295 &' !! *:::!!:::::::::::* !! ',
38296 &' !! !* -><- * !! ',
38306 DATA (LOGO(J),J=20,38)/
38307 &'Welcome to the Lund Monte Carlo!',
38309 &'PPP Y Y TTTTT H H III A ',
38310 &'P P Y Y T H H I A A ',
38311 &'PPP Y T HHHHH I AAAAA',
38312 &'P Y T H H I A A',
38313 &'P Y T H H III A A',
38315 &'This is PYTHIA version x.xxx ',
38316 &'Last date of change: xx xxx 199x',
38318 &'Now is xx xxx 199x at xx:xx:xx ',
38320 &'Disclaimer: this program comes ',
38321 &'without any guarantees. Beware ',
38322 &'of errors and use common sense ',
38323 &'when interpreting results. ',
38325 &'Copyright T. Sjostrand (1997) '/
38326 DATA (REFER(J),J=1,18)/
38327 &'An archive of program versions and d',
38328 &'ocumentation is found on the web: ',
38329 &'http://www.thep.lu.se/tf2/staff/torb',
38330 &'jorn/Pythia.html ',
38333 &'When you cite this program, currentl',
38334 &'y the official reference is ',
38335 &'T. Sjostrand, Computer Physics Commu',
38336 &'n. 82 (1994) 74. ',
38337 &'The supersymmetry extensions are des',
38339 &'S. Mrenna, Computer Physics Commun. ',
38340 &'101 (1997) 232 ',
38341 &'Also remember that the program, to a',
38342 &' large extent, represents original ',
38343 &'physics research. Other publications',
38344 &' of special relevance to your '/
38345 DATA (REFER(J),J=19,2*IREFER)/
38346 &'studies may therefore deserve separa',
38350 &'Main author: Torbjorn Sjostrand; Dep',
38351 &'artment of Theoretical Physics 2, ',
38352 &' Lund University, Solvegatan 14A, S',
38353 &'-223 62 Lund, Sweden; ',
38354 &' phone: + 46 - 46 - 222 48 16; e-ma',
38355 &'il: torbjorn@thep.lu.se ',
38356 &'SUSY author: Stephen Mrenna, Argonne',
38357 &' National Laboratory, ',
38358 &' 9700 South Cass Avenue, Argonne, I',
38360 &' phone: + 1 - 630 - 252 - 7615; e-m',
38361 &'ail: mrenna@hep.anl.gov '/
38363 C...Check that PYDATA linked.
38364 IF(MSTP(183)/10.NE.199) THEN
38365 WRITE(MSTU(11),'(1X,A)')
38366 & 'Error: PYDATA has not been linked.'
38367 WRITE(MSTU(11),'(1X,A)') 'Execution stopped!'
38370 C...Write current version number and current date+time.
38372 WRITE(VERS,'(I1)') MSTP(181)
38373 LOGO(28)(24:24)=VERS
38374 WRITE(SUBV,'(I3)') MSTP(182)
38375 LOGO(28)(26:28)=SUBV
38376 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
38377 WRITE(DATE,'(I2)') MSTP(185)
38378 LOGO(29)(22:23)=DATE
38379 LOGO(29)(25:27)=MONTH(MSTP(184))
38380 WRITE(YEAR,'(I4)') MSTP(183)
38381 LOGO(29)(29:32)=YEAR
38383 IF(IDATI(1).LE.0) THEN
38386 WRITE(DATE,'(I2)') IDATI(3)
38388 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
38389 WRITE(YEAR,'(I4)') IDATI(1)
38390 LOGO(31)(15:18)=YEAR
38391 WRITE(HOUR,'(I2)') IDATI(4)
38392 LOGO(31)(23:24)=HOUR
38393 WRITE(MINU,'(I2)') IDATI(5)
38394 LOGO(31)(26:27)=MINU
38395 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
38396 WRITE(SECO,'(I2)') IDATI(6)
38397 LOGO(31)(29:30)=SECO
38398 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
38402 C...Loop over lines in header. Define page feed and side borders.
38403 DO 100 ILIN=1,29+IREFER
38412 C...Separator lines and logos.
38413 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
38414 LINE(4:77)='***********************************************'//
38415 & '***************************'
38416 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
38417 LINE(6:37)=LOGO(ILIN-5)
38418 LINE(44:75)=LOGO(ILIN+14)
38419 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
38420 LINE(5:40)=REFER(2*ILIN-51)
38421 LINE(41:76)=REFER(2*ILIN-50)
38424 C...Write lines to appropriate unit.
38425 WRITE(MSTU(11),'(A79)') LINE
38431 C*********************************************************************
38434 C...Facilitates the updating of particle and decay data
38435 C...by allowing it to be done in an external file.
38437 SUBROUTINE PYUPDA(MUPDA,LFN)
38439 C...Double precision and integer declarations.
38440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38441 INTEGER PYK,PYCHGE,PYCOMP
38443 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38444 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38445 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38446 COMMON/PYDAT4/CHAF(500,2)
38448 COMMON/PYINT4/MWID(500),WIDS(500,5)
38449 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
38450 C...Local arrays, character variables and data.
38451 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
38452 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
38453 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
38454 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
38455 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
38456 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
38457 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
38459 C...Write header if not yet done.
38460 IF(MSTU(12).GE.1) CALL PYLIST(0)
38462 C...Write information on file for editing.
38463 IF(MUPDA.EQ.1) THEN
38465 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38466 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38467 & MWID(KC),MDCY(KC,1)
38468 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38469 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38470 & (KFDP(IDC,J),J=1,5)
38474 C...Read complete set of information from edited file or
38475 C...read partial set of new or updated information from edited file.
38476 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
38478 C...Reset counters.
38482 IF(MUPDA.EQ.2) THEN
38487 DO 130 KC=1,MSTU(6)
38488 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
38489 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
38493 C...Begin of loop: read new line; unknown whether particle or
38495 140 READ(LFN,5200,END=190) CHINL
38497 C...Identify particle code and whether already defined (for MUPDA=3).
38498 IF(CHINL(2:10).NE.' ') THEN
38501 IF(MUPDA.EQ.2) THEN
38514 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
38517 C...Remove duplicate old decay data.
38518 IF(KCREP.NE.0) THEN
38519 IDCREP=MDCY(KCREP,2)
38520 NDCREP=MDCY(KCREP,3)
38522 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
38524 DO 180 I=IDCREP,NDC-NDCREP
38525 MDME(I,1)=MDME(I+NDCREP,1)
38526 MDME(I,2)=MDME(I+NDCREP,2)
38527 BRAT(I)=BRAT(I+NDCREP)
38529 KFDP(I,J)=KFDP(I+NDCREP,J)
38540 C...Study line with particle data.
38541 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
38542 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
38543 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38544 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38545 & MWID(KC),MDCY(KC,1)
38549 C...Study line with decay data.
38552 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
38553 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
38554 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
38555 MDCY(KC,3)=MDCY(KC,3)+1
38556 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
38557 & (KFDP(NDC,J),J=1,5)
38560 C...End of loop; ensure that PYCOMP tables are updated.
38565 C...Perform possible tests that new information is consistent.
38568 DO 220 KC=1,MSTU(6)
38570 IF(KF.EQ.0) GOTO 220
38571 WRITE(CHKF,5300) KF
38572 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
38573 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
38574 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
38576 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38577 IF(MDME(IDC,2).GT.80) GOTO 210
38579 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
38583 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
38585 ELSEIF(PYCOMP(KP).EQ.0) THEN
38591 PMS=PMS-PMAS(KPC,1)
38592 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
38596 IF(KQ.NE.0) MERR=MAX(2,MERR)
38597 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
38599 IF(MERR.EQ.3) CALL PYERRM(17,
38600 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
38601 IF(MERR.EQ.2) CALL PYERRM(17,
38602 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
38603 IF(MERR.EQ.1) CALL PYERRM(7,
38604 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
38605 BRSUM=BRSUM+BRAT(IDC)
38607 WRITE(CHTMP,5500) BRSUM
38608 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
38609 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
38610 & CHTMP(9:16)//' for KF ='//CHKF)
38614 C...Write DATA statements for inclusion in program.
38615 ELSEIF(MUPDA.EQ.4) THEN
38617 C...Find out how many codes and decay channels are actually used.
38621 IF(KCHG(I,4).NE.0) THEN
38623 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
38627 C...Initialize writing of DATA statements for inclusion in program.
38630 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
38633 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
38637 C...Loop through variables for conversion to characters.
38639 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
38640 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
38641 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
38642 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
38643 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
38644 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
38645 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
38646 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
38647 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
38648 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
38649 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
38650 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
38651 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
38652 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
38653 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
38654 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
38655 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
38656 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
38657 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
38658 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
38659 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
38660 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
38662 C...Replace variables beyond what is properly defined.
38664 IF(IDIM.GT.KCC) CHTMP=' 0'
38665 ELSEIF(IVAR.LE.8) THEN
38666 IF(IDIM.GT.KCC) CHTMP=' 0.0'
38667 ELSEIF(IVAR.LE.11) THEN
38668 IF(IDIM.GT.KCC) CHTMP=' 0'
38669 ELSEIF(IVAR.LE.13) THEN
38670 IF(IDIM.GT.NDC) CHTMP=' 0'
38671 ELSEIF(IVAR.LE.14) THEN
38672 IF(IDIM.GT.NDC) CHTMP=' 0.0'
38673 ELSEIF(IVAR.LE.19) THEN
38674 IF(IDIM.GT.NDC) CHTMP=' 0'
38675 ELSEIF(IVAR.LE.21) THEN
38676 IF(IDIM.GT.KCC) CHTMP=' '
38678 IF(IDIM.GT.KCC) CHTMP=' 0'
38681 C...Length of variable, trailing decimal zeros, quotation marks.
38685 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
38686 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
38688 CHNEW=CHTMP(LLOW:LHIG)//' '
38690 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
38693 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
38694 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
38699 CHNEW(LNEW+1:LNEW+2)='D0'
38702 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
38703 DO 260 LL=LNEW,1,-1
38704 IF(CHNEW(LL:LL).EQ.'''') THEN
38706 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
38712 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
38716 C...Form composite character string, often including repetition counter.
38717 IF(CHNEW.NE.CHOLD) THEN
38724 IF(NRPT.GE.2) LRPT=LNEW+3
38725 IF(NRPT.GE.10) LRPT=LNEW+4
38726 IF(NRPT.GE.100) LRPT=LNEW+5
38727 IF(NRPT.GE.1000) LRPT=LNEW+6
38730 WRITE(CHTMP,5400) NRPT
38732 IF(NRPT.GE.10) LRPT=2
38733 IF(NRPT.GE.100) LRPT=3
38734 IF(NRPT.GE.1000) LRPT=4
38735 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
38739 C...Add characters to end of line, to new line (after storing old line),
38740 C...or to new block of lines (after writing old block).
38741 IF(LLIN+LCOM.LE.70) THEN
38742 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
38744 ELSEIF(NLIN.LE.19) THEN
38745 CHLIN(LLIN+1:72)=' '
38748 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
38751 CHLIN(LLIN:72)='/'//' '
38753 WRITE(CHTMP,5400) IDIM-NRPT
38754 CHBLK(1)(30:33)=CHTMP(13:16)
38756 WRITE(LFN,5700) CHBLK(ILIN)
38760 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
38761 & ',I= , )/'//CHCOM(1:LCOM)//','
38762 WRITE(CHTMP,5400) IDIM-NRPT+1
38763 CHLIN(25:28)=CHTMP(13:16)
38768 C...Write final block of lines.
38769 CHLIN(LLIN:72)='/'//' '
38771 WRITE(CHTMP,5400) NDIM
38772 CHBLK(1)(30:33)=CHTMP(13:16)
38774 WRITE(LFN,5700) CHBLK(ILIN)
38779 C...Formats for reading and writing particle data.
38780 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
38781 5100 FORMAT(10X,2I5,F12.6,5I10)
38792 C*********************************************************************
38795 C...Provides various integer-valued event related data.
38799 C...Double precision and integer declarations.
38800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38801 INTEGER PYK,PYCHGE,PYCOMP
38803 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38806 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
38808 C...Default value. For I=0 number of entries, number of stable entries
38809 C...or 3 times total charge.
38811 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
38812 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
38814 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
38816 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
38817 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
38820 ELSEIF(I.EQ.0) THEN
38822 C...For I > 0 direct readout of K matrix or charge.
38823 ELSEIF(J.LE.5) THEN
38825 ELSEIF(J.EQ.6) THEN
38828 C...Status (existing/fragmented/decayed), parton/hadron separation.
38829 ELSEIF(J.LE.8) THEN
38830 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
38831 IF(J.EQ.8) PYK=PYK*K(I,2)
38832 ELSEIF(J.LE.12) THEN
38836 IF(KC.NE.0) KQ=KCHG(KC,2)
38837 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
38838 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
38840 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
38842 C...Heaviest flavour in hadron/diquark.
38843 ELSEIF(J.EQ.13) THEN
38845 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
38846 IF(KFA.LT.10) PYK=KFA
38847 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
38848 PYK=PYK*ISIGN(1,K(I,2))
38850 C...Particle history: generation, ancestor, rank.
38851 ELSEIF(J.LE.15) THEN
38857 IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
38859 ELSEIF(J.EQ.16) THEN
38861 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
38862 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
38869 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
38870 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
38872 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
38873 IF(ILP.EQ.1) GOTO 120
38875 IF(K(I1,1).EQ.12) THEN
38877 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
38878 & .AND.K(I3,2).NE.93) PYK=PYK+1
38884 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
38888 C...Particle coming from collapsing jet system or not.
38889 ELSEIF(J.EQ.17) THEN
38896 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
38897 IF(PYK.EQ.1) PYK=-1
38901 IF(KCHG(KC,2).EQ.0) GOTO 150
38902 IF(K(I1,1).NE.12) PYK=0
38903 IF(K(I1,1).NE.12) RETURN
38906 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
38908 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
38910 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
38912 C...Number of decay products. Colour flow.
38913 ELSEIF(J.EQ.18) THEN
38914 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
38915 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
38916 ELSEIF(J.LE.22) THEN
38917 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
38918 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
38919 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
38920 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
38921 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
38928 C*********************************************************************
38931 C...Provides various real-valued event related data.
38935 C...Double precision and integer declarations.
38936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38937 INTEGER PYK,PYCHGE,PYCOMP
38939 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38940 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38941 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38942 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
38946 C...Set default value. For I = 0 sum of momenta or charges,
38947 C...or invariant mass of system.
38949 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
38950 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
38952 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
38954 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
38958 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
38962 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
38963 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
38965 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
38967 ELSEIF(I.EQ.0) THEN
38969 C...Direct readout of P matrix.
38970 ELSEIF(J.LE.5) THEN
38973 C...Charge, total momentum, transverse momentum, transverse mass.
38974 ELSEIF(J.LE.12) THEN
38975 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
38976 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
38977 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
38978 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
38979 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
38981 C...Theta and phi angle in radians or degrees.
38982 ELSEIF(J.LE.16) THEN
38983 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
38984 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
38985 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
38987 C...True rapidity, rapidity with pion mass, pseudorapidity.
38988 ELSEIF(J.LE.19) THEN
38990 IF(J.EQ.17) PMR=P(I,5)
38991 IF(J.EQ.18) PMR=PYMASS(211)
38992 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
38993 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
38996 C...Energy and momentum fractions (only to be used in CM frame).
38997 ELSEIF(J.LE.25) THEN
38998 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
38999 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
39000 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
39001 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
39002 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
39003 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
39009 C*********************************************************************
39012 C...Performs sphericity tensor analysis to give sphericity,
39013 C...aplanarity and the related event axes.
39015 SUBROUTINE PYSPHE(SPH,APL)
39017 C...Double precision and integer declarations.
39018 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39019 INTEGER PYK,PYCHGE,PYCOMP
39021 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39024 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39026 DIMENSION SM(3,3),SV(3,3)
39028 C...Calculate matrix to be diagonalized.
39037 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39038 IF(MSTU(41).GE.2) THEN
39040 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39041 & KC.EQ.18) GOTO 140
39042 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39046 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39048 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
39049 & MAX(1D-10,PA)**(PARU(41)-2D0)
39052 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
39058 C...Very low multiplicities (0 or 1) not considered.
39060 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
39067 SM(J1,J2)=SM(J1,J2)/PS
39071 C...Find eigenvalues to matrix (third degree equation).
39072 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
39073 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
39074 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
39075 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
39076 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
39077 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
39078 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
39079 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
39080 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
39081 IF(P(N+2,4).LT.1D-5) THEN
39082 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
39088 C...Find first and last eigenvector by solving equation system.
39091 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
39093 SV(J1,J2)=SM(J1,J2)
39094 SV(J2,J1)=SM(J1,J2)
39100 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
39103 SMAX=ABS(SV(J1,J2))
39107 DO 220 J3=JA+1,JA+2
39109 RL=SV(J1,JB)/SV(JA,JB)
39111 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
39112 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
39114 SMAX=ABS(SV(J1,J2))
39118 JB2=JB+2-3*((JB+1)/3)
39119 P(N+I,JB1)=-SV(JC,JB2)
39120 P(N+I,JB2)=SV(JC,JB1)
39121 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
39123 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
39124 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39126 P(N+I,J)=SGN*P(N+I,J)/PA
39130 C...Middle axis orthogonal to other two. Fill other codes.
39131 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39132 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
39133 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
39134 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
39147 C...Calculate sphericity and aplanarity. Select storing option.
39148 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
39152 IF(MSTU(43).LE.1) MSTU(3)=3
39153 IF(MSTU(43).GE.2) N=N+3
39158 C*********************************************************************
39161 C...Performs thrust analysis to give thrust, oblateness
39162 C...and the related event axes.
39164 SUBROUTINE PYTHRU(THR,OBL)
39166 C...Double precision and integer declarations.
39167 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39168 INTEGER PYK,PYCHGE,PYCOMP
39170 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39172 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39173 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39175 DIMENSION TDI(3),TPR(3)
39177 C...Take copy of particles that are to be considered in thrust analysis.
39181 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
39182 IF(MSTU(41).GE.2) THEN
39184 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39185 & KC.EQ.18) GOTO 100
39186 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39189 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
39190 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
39200 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39202 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
39203 & P(N+NP,4)**(PARU(42)-1D0)
39204 PS=PS+P(N+NP,4)*P(N+NP,5)
39207 C...Very low multiplicities (0 or 1) not considered.
39209 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
39215 C...Loop over thrust and major. T axis along z direction in latter case.
39219 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
39221 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
39222 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
39223 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
39226 C...Find and order particles with highest p (pT for major).
39227 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
39231 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
39232 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
39233 IF(P(I,4).LE.P(ILF,4)) GOTO 140
39235 P(ILF+1,J)=P(ILF,J)
39244 C...Find and order initial axes with highest thrust (major).
39245 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
39248 NC=2**(MIN(MSTU(44),NP)-1)
39253 DO 200 ILF=1,MIN(MSTU(44),NP)
39254 SGN=P(N+NP+ILF+3,5)
39255 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
39257 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
39260 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
39261 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
39262 IF(TDS.LE.P(ILG,4)) GOTO 230
39264 P(ILG+1,J)=P(ILG,J)
39267 ILG=N+NP+MSTU(44)+4
39274 C...Iterate direction of axis until stable maximum.
39281 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
39282 IF(THP.GT.1D-10) TDI(J)=TPR(J)
39286 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
39288 TPR(J)=TPR(J)+SGN*P(I,J)
39291 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
39292 IF(THP.GE.THPS+PARU(48)) GOTO 270
39294 C...Save good axis. Try new initial axis until a number of tries agree.
39295 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
39296 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
39298 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39300 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
39306 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
39309 C...Find minor axis and value by orthogonality.
39310 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39311 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
39312 P(N+NP+3,2)=SGN*P(N+NP+2,1)
39316 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
39321 C...Fill axis information. Rotate back to original coordinate system.
39329 P(N+ILD,J)=P(N+NP+ILD,J)
39333 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
39335 C...Calculate thrust and oblateness. Select storing option.
39337 OBL=P(N+2,4)-P(N+3,4)
39340 IF(MSTU(43).LE.1) MSTU(3)=3
39341 IF(MSTU(43).GE.2) N=N+3
39346 C*********************************************************************
39349 C...Subdivides the particle content of an event into jets/clusters.
39351 SUBROUTINE PYCLUS(NJET)
39353 C...Double precision and integer declarations.
39354 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39355 INTEGER PYK,PYCHGE,PYCOMP
39357 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39358 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39359 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39360 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39361 C...Local arrays and saved variables.
39363 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
39365 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
39366 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
39367 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
39368 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
39369 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39370 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
39371 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39373 C...If first time, reset. If reentering, skip preliminaries.
39374 IF(MSTU(48).LE.0) THEN
39380 PIMASS=PMAS(PYCOMP(211),1)
39383 IF(MSTU(43).GE.2) N=N-NJET
39384 DO 110 I=N+1,N+NJET
39385 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39387 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39390 R2ACC=PARU(45)*PS(5)**2
39396 C...Find which particles are to be considered in cluster search.
39398 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39399 IF(MSTU(41).GE.2) THEN
39401 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39402 & KC.EQ.18) GOTO 140
39403 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39406 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
39407 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
39412 C...Take copy of these particles, with space left for jets later on.
39418 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
39419 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
39420 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
39421 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39423 PS(J)=PS(J)+P(N+NP,J)
39433 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
39435 C...Very low multiplicities not considered.
39436 IF(NP.LT.MSTU(47)) THEN
39437 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
39442 C...Find precluster configuration. If too few jets, make harder cuts.
39444 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39447 R2ACC=PARU(45)*PS(5)**2
39449 RINIT=1.25D0*PARU(43)
39450 IF(NP.LE.MSTU(47)+2) RINIT=0D0
39451 170 RINIT=0.8D0*RINIT
39454 DO 180 I=N+NP+1,N+2*NP
39458 C...Sum up small momentum region. Jet if enough absolute momentum.
39459 IF(MSTU(46).LE.2) THEN
39463 DO 210 I=N+NP+1,N+2*NP
39464 IF(P(I,5).GT.2D0*RINIT) GOTO 210
39468 P(N+1,J)=P(N+1,J)+P(I,J)
39471 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
39472 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
39473 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39474 IF(NREM.EQ.0) GOTO 170
39477 C...Find fastest remaining particle.
39480 DO 230 I=N+NP+1,N+2*NP
39481 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
39486 P(N+NPRE,J)=P(IMAX,J)
39491 C...Sum up precluster around it according to pT separation.
39492 IF(MSTU(46).LE.2) THEN
39493 DO 260 I=N+NP+1,N+2*NP
39494 IF(K(I,4).NE.0) GOTO 260
39496 IF(R2.GT.RINIT**2) GOTO 260
39500 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
39503 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39505 C...Sum up precluster around it according to mass or
39506 C...Durham pT separation.
39510 DO 280 I=N+NP+1,N+2*NP
39511 IF(K(I,4).NE.0) GOTO 280
39512 IF(MSTU(46).LE.4) THEN
39517 IF(R2.GE.R2MIN) GOTO 280
39523 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
39525 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39532 C...Check if more preclusters to be found. Start over if too few.
39533 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39534 IF(NREM.GT.0) GOTO 220
39537 C...Reassign all particles to nearest jet. Sum up new jet momenta.
39540 310 IF(MSTU(46).LE.1) THEN
39541 DO 330 I=N+1,N+NJET
39546 DO 360 I=N+NP+1,N+2*NP
39548 DO 340 IJET=N+1,N+NJET
39549 IF(P(IJET,5).LT.RINIT) GOTO 340
39551 IF(R2.GE.R2MIN) GOTO 340
39557 V(IMIN,J)=V(IMIN,J)+P(I,J)
39561 DO 380 I=N+1,N+NJET
39565 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39570 C...Find two closest jets.
39571 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
39572 DO 400 ITRY1=N+1,N+NJET-1
39573 DO 390 ITRY2=ITRY1+1,N+NJET
39574 IF(MSTU(46).LE.2) THEN
39575 R2=R2T(ITRY1,ITRY2)
39576 ELSEIF(MSTU(46).LE.4) THEN
39577 R2=R2M(ITRY1,ITRY2)
39579 R2=R2D(ITRY1,ITRY2)
39581 IF(R2.GE.R2MIN) GOTO 390
39588 C...If allowed, join two closest jets and start over.
39589 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
39590 IREC=MIN(IMIN1,IMIN2)
39591 IDEL=MAX(IMIN1,IMIN2)
39593 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
39595 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
39596 DO 430 I=IDEL+1,N+NJET
39601 IF(MSTU(46).GE.2) THEN
39602 DO 440 I=N+NP+1,N+2*NP
39604 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
39605 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
39611 C...Divide up broad jet if empty cluster in list of final ones.
39612 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
39613 DO 450 I=N+1,N+NJET
39616 DO 460 I=N+NP+1,N+2*NP
39617 K(N+K(I,4),5)=K(N+K(I,4),5)+1
39620 DO 470 I=N+1,N+NJET
39621 IF(K(I,5).EQ.0) IEMP=I
39627 DO 480 I=N+NP+1,N+2*NP
39628 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
39631 IF(R2.LE.R2MAX) GOTO 480
39638 P(IEMP,J)=P(ISPL,J)
39639 P(IJET,J)=P(IJET,J)-P(ISPL,J)
39641 P(IEMP,5)=P(ISPL,5)
39642 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
39643 IF(NLOOP.LE.2) GOTO 300
39648 C...If generalized thrust has not yet converged, continue iteration.
39649 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
39655 C...Reorder jets according to energy.
39656 DO 510 I=N+1,N+NJET
39661 DO 540 INEW=N+1,N+NJET
39663 DO 520 ITRY=N+1,N+NJET
39664 IF(V(ITRY,4).LE.PEMAX) GOTO 520
39673 P(INEW,J)=V(IMAX,J)
39679 C...Clean up particle-jet assignments and jet information.
39680 DO 550 I=N+NP+1,N+2*NP
39683 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
39684 K(IORI,4)=K(IORI,4)+1
39688 DO 570 I=N+1,N+NJET
39691 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
39695 IF(K(I,4).EQ.0) IEMP=I
39698 C...Select storing option. Output variables. Check for failure.
39704 PARU(63)=SQRT(R2MIN)
39705 IF(NJET.LE.1) PARU(63)=0D0
39707 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
39710 IF(MSTU(43).LE.1) MSTU(3)=NJET
39711 IF(MSTU(43).GE.2) N=N+NJET
39717 C*********************************************************************
39720 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
39721 C...as used for calorimeters at hadron colliders.
39723 SUBROUTINE PYCELL(NJET)
39725 C...Double precision and integer declarations.
39726 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39727 INTEGER PYK,PYCHGE,PYCOMP
39729 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39730 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39731 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39732 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39734 C...Loop over all particles. Find cell that was hit by given particle.
39735 PTLRAT=1D0/SINH(PARU(51))**2
39739 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
39740 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
39741 IF(MSTU(41).GE.2) THEN
39743 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39744 & KC.EQ.18) GOTO 110
39745 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39749 PT=SQRT(P(I,1)**2+P(I,2)**2)
39750 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
39751 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
39752 & (ETA/PARU(51)+1D0))))
39753 PHI=PYANGL(P(I,1),P(I,2))
39754 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
39755 & (PHI/PARU(1)+1D0))))
39756 IETPH=MSTU(52)*IETA+IPHI
39758 C...Add to cell already hit, or book new cell.
39760 IF(IETPH.EQ.K(IC,3)) THEN
39766 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
39767 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
39775 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
39776 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
39780 C...Smear true bin content by calorimeter resolution.
39781 IF(MSTU(53).GE.1) THEN
39784 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
39785 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
39786 & COS(PARU(2)*PYR(0))
39787 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
39789 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
39793 C...Remove cells below threshold.
39794 IF(PARU(58).GT.0D0) THEN
39798 IF(P(IC,5).GT.PARU(58)) THEN
39810 C...Find initiator cell: the one with highest pT of not yet used ones.
39814 IF(K(IC,5).NE.2) GOTO 160
39815 IF(P(IC,5).LE.ETMAX) GOTO 160
39821 IF(ETMAX.LT.PARU(52)) GOTO 220
39822 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
39823 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
39837 C...Sum up unused cells within required distance of initiator.
39839 IF(K(IC,5).EQ.0) GOTO 170
39840 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
39841 DPHIA=ABS(P(IC,2)-PHI)
39842 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
39844 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
39845 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
39847 K(NJ,4)=K(NJ,4)+K(IC,4)
39848 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
39849 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
39850 P(NJ,5)=P(NJ,5)+P(IC,5)
39853 C...Reject cluster below minimum ET, else accept.
39854 IF(P(NJ,5).LT.PARU(53)) THEN
39857 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
39859 ELSEIF(MSTU(54).LE.2) THEN
39860 P(NJ,3)=P(NJ,3)/P(NJ,5)
39861 P(NJ,4)=P(NJ,4)/P(NJ,5)
39862 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
39865 IF(K(IC,5).LT.0) K(IC,5)=0
39872 IF(K(IC,5).GE.0) GOTO 210
39873 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
39874 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
39875 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
39876 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
39882 C...Arrange clusters in falling ET sequence.
39883 220 DO 250 I=1,NJ-NC
39886 IF(K(IJ,5).EQ.0) GOTO 230
39887 IF(P(IJ,5).LT.ETMAX) GOTO 230
39895 K(N+I,4)=K(IJMAX,4)
39898 P(N+I,J)=P(IJMAX,J)
39904 C...Convert to massless or massive four-vectors.
39905 IF(MSTU(54).EQ.2) THEN
39906 DO 260 I=N+1,N+NJET
39908 P(I,1)=P(I,5)*COS(P(I,4))
39909 P(I,2)=P(I,5)*SIN(P(I,4))
39910 P(I,3)=P(I,5)*SINH(ETA)
39911 P(I,4)=P(I,5)*COSH(ETA)
39914 ELSEIF(MSTU(54).GE.3) THEN
39915 DO 270 I=N+1,N+NJET
39916 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
39920 C...Information about storage.
39924 IF(MSTU(43).LE.1) MSTU(3)=NJET
39925 IF(MSTU(43).GE.2) N=N+NJET
39930 C*********************************************************************
39933 C...Determines, approximately, the two jet masses that minimize
39934 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
39936 SUBROUTINE PYJMAS(PMH,PML)
39938 C...Double precision and integer declarations.
39939 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39940 INTEGER PYK,PYCHGE,PYCOMP
39942 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39943 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39944 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39945 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39947 DIMENSION SM(3,3),SAX(3),PS(3,5)
39960 PIMASS=PMAS(PYCOMP(211),1)
39962 C...Take copy of particles that are to be considered in mass analysis.
39964 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
39965 IF(MSTU(41).GE.2) THEN
39967 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39968 & KC.EQ.18) GOTO 170
39969 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39972 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
39973 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
39982 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
39983 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
39984 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
39986 C...Fill information in sphericity tensor and total momentum vector.
39989 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
39992 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39994 PS(3,J)=PS(3,J)+P(N+NP,J)
39998 C...Very low multiplicities (0 or 1) not considered.
40000 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
40005 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
40008 C...Find largest eigenvalue to matrix (third degree equation).
40011 SM(J1,J2)=SM(J1,J2)/PSS
40014 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
40015 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
40016 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
40017 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
40018 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
40019 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
40020 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
40022 C...Find largest eigenvector by solving equation system.
40024 SM(J1,J1)=SM(J1,J1)-SMA
40026 SM(J2,J1)=SM(J1,J2)
40032 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
40035 SMAX=ABS(SM(J1,J2))
40039 DO 250 J3=JA+1,JA+2
40041 RL=SM(J1,JB)/SM(JA,JB)
40043 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
40044 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
40046 SMAX=ABS(SM(J1,J2))
40050 JB2=JB+2-3*((JB+1)/3)
40051 SAX(JB1)=-SM(JC,JB2)
40052 SAX(JB2)=SM(JC,JB1)
40053 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
40055 C...Divide particles into two initial clusters by hemisphere.
40057 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
40059 IF(PSAX.LT.0D0) IS=2
40062 PS(IS,J)=PS(IS,J)+P(I,J)
40065 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
40066 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
40068 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
40072 PS(3,J)=PS(1,J)-PS(2,J)
40075 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)
40076 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
40077 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
40078 IF(PMDI.LT.PMD) THEN
40084 C...Loop back if significant reduction in sum of m^2.
40085 IF(PMD.LT.-PARU(48)*PMS) THEN
40089 PS(IS,J)=PS(IS,J)-P(IM,J)
40090 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
40096 C...Final masses and output.
40099 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
40100 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
40101 PMH=MAX(PS(1,5),PS(2,5))
40102 PML=MIN(PS(1,5),PS(2,5))
40107 C*********************************************************************
40110 C...Calculates the first few Fox-Wolfram moments.
40112 SUBROUTINE PYFOWO(H10,H20,H30,H40)
40114 C...Double precision and integer declarations.
40115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40116 INTEGER PYK,PYCHGE,PYCOMP
40118 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40119 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40120 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40121 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40123 C...Copy momenta for particles and calculate H0.
40128 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
40129 IF(MSTU(41).GE.2) THEN
40131 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40132 & KC.EQ.18) GOTO 110
40133 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40136 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
40137 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
40148 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
40154 C...Very low multiplicities (0 or 1) not considered.
40156 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
40164 C...Calculate H1 - H4.
40170 DO 120 I2=I1+1,N+NP
40171 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40172 & (P(I1,4)*P(I2,4))
40173 H10=H10+P(I1,4)*P(I2,4)*CTHE
40174 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
40175 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
40176 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
40181 C...Calculate H1/H0 - H4/H0. Output.
40184 H10=(HD+2D0*H10)/H0
40185 H20=(HD+2D0*H20)/H0
40186 H30=(HD+2D0*H30)/H0
40187 H40=(HD+2D0*H40)/H0
40192 C*********************************************************************
40195 C...Evaluates various properties of an event, with statistics
40196 C...accumulated during the course of the run and
40197 C...printed at the end.
40199 SUBROUTINE PYTABU(MTABU)
40201 C...Double precision and integer declarations.
40202 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40203 INTEGER PYK,PYCHGE,PYCOMP
40205 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40206 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40207 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40208 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
40209 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
40210 C...Local arrays, character variables, saved variables and data.
40211 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
40212 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
40213 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
40214 &KFDM(8),KFDC(200,0:8),NPDC(200)
40215 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
40216 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
40217 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
40218 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
40219 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
40220 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
40221 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
40222 &NEVDC/0/,NKFDC/0/,NREDC/0/
40224 C...Reset statistics on initial parton state.
40225 IF(MTABU.EQ.10) THEN
40229 C...Identify and order flavour content of initial state.
40230 ELSEIF(MTABU.EQ.11) THEN
40232 KFM1=2*IABS(MSTU(161))
40233 IF(MSTU(161).GT.0) KFM1=KFM1-1
40234 KFM2=2*IABS(MSTU(162))
40235 IF(MSTU(162).GT.0) KFM2=KFM2-1
40236 KFMN=MIN(KFM1,KFM2)
40237 KFMX=MAX(KFM1,KFM2)
40239 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
40242 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
40243 & KFMX.LT.KFIS(I,2))) THEN
40249 110 IF(IKFIS.LT.0) THEN
40252 IF(NKFIS.GE.100) RETURN
40253 DO 130 I=NKFIS,IKFIS,-1
40254 KFIS(I+1,1)=KFIS(I,1)
40255 KFIS(I+1,2)=KFIS(I,2)
40257 NPIS(I+1,J)=NPIS(I,J)
40267 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
40269 C...Count number of partons in initial state.
40272 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
40273 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
40274 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
40279 IF(IM.LE.0.OR.IM.GT.N) THEN
40281 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40283 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
40284 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
40294 IF(NP.GE.11) NPCO=8
40295 IF(NP.GE.16) NPCO=9
40296 IF(NP.GE.26) NPCO=10
40297 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
40300 C...Write statistics on initial parton state.
40301 ELSEIF(MTABU.EQ.12) THEN
40302 FAC=1D0/MAX(1,NEVIS)
40303 WRITE(MSTU(11),5000) NEVIS
40306 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40308 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40309 CALL PYNAME(KFM1,CHAU)
40311 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
40313 IF(KFIS(I,1).EQ.0) KFMX=0
40315 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40316 CALL PYNAME(KFM2,CHAU)
40318 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
40319 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
40320 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
40323 C...Copy statistics on initial parton state into /PYJETS/.
40324 ELSEIF(MTABU.EQ.13) THEN
40325 FAC=1D0/MAX(1,NEVIS)
40328 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40330 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40332 IF(KFIS(I,1).EQ.0) KFMX=0
40334 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40341 P(I,J)=FAC*NPIS(I,J)
40342 V(I,J)=FAC*NPIS(I,J+5)
40356 C...Reset statistics on number of particles/partons.
40357 ELSEIF(MTABU.EQ.20) THEN
40364 C...Identify whether particle/parton is primary or not.
40365 ELSEIF(MTABU.EQ.21) THEN
40369 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
40370 MSTU(62)=MSTU(62)+1
40373 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
40375 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
40377 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
40379 ELSEIF(KC.EQ.0) THEN
40380 ELSEIF(K(K(I,3),1).EQ.13) THEN
40382 IF(IM.LE.0.OR.IM.GT.N) THEN
40384 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40387 ELSEIF(KCHG(KC,2).EQ.0) THEN
40388 KCM=PYCOMP(K(K(I,3),2))
40390 IF(KCHG(KCM,2).NE.0) MPRI=1
40393 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
40394 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
40396 IF(K(I,1).LE.10) THEN
40398 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
40401 C...Fill statistics on number of particles/partons in event.
40403 KFS=3-ISIGN(1,K(I,2))-MPRI
40405 IF(KFA.EQ.KFFS(IP)) THEN
40408 ELSEIF(KFA.LT.KFFS(IP)) THEN
40414 220 IF(IKFFS.LT.0) THEN
40417 IF(NKFFS.GE.400) RETURN
40418 DO 240 IP=NKFFS,IKFFS,-1
40419 KFFS(IP+1)=KFFS(IP)
40421 NPFS(IP+1,J)=NPFS(IP,J)
40430 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
40433 C...Write statistics on particle/parton composition of events.
40434 ELSEIF(MTABU.EQ.22) THEN
40435 FAC=1D0/MAX(1,NEVFS)
40436 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
40438 CALL PYNAME(KFFS(I),CHAU)
40441 IF(KC.NE.0) MDCYF=MDCY(KC,1)
40442 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
40443 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
40446 C...Copy particle/parton composition information into /PYJETS/.
40447 ELSEIF(MTABU.EQ.23) THEN
40448 FAC=1D0/MAX(1,NEVFS)
40454 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
40456 P(I,J)=FAC*NPFS(I,J)
40476 C...Reset factorial moments statistics.
40477 ELSEIF(MTABU.EQ.30) THEN
40483 FM1FM(IM,IB,IP)=0D0
40484 FM2FM(IM,IB,IP)=0D0
40489 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
40490 ELSEIF(MTABU.EQ.31) THEN
40495 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
40496 IF(MSTU(41).GE.2) THEN
40498 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40499 & KC.EQ.18) GOTO 410
40500 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40501 & PYCHGE(K(I,2)).EQ.0) GOTO 410
40504 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40505 IF(MSTU(42).GE.2) PMR=P(I,5)
40506 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
40507 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
40509 IF(ABS(YETA).GT.PARU(57)) GOTO 410
40510 PHI=PYANGL(P(I,1),P(I,2))
40511 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
40512 IYETA=MAX(0,MIN(511,IYETA))
40513 IPHI=512D0*(PHI+PARU(1))/PARU(2)
40514 IPHI=MAX(0,MIN(511,IPHI))
40517 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
40520 C...Order particles in (pseudo)rapidity and/or azimuth.
40521 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40522 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40526 IF(NUPP.EQ.NLOW+1) THEN
40531 DO 350 I1=NUPP-1,NLOW+1,-1
40532 IF(IYETA.GE.K(I1,1)) GOTO 360
40535 360 K(I1+1,1)=IYETA
40536 DO 370 I1=NUPP-1,NLOW+1,-1
40537 IF(IPHI.GE.K(I1,2)) GOTO 380
40541 DO 390 I1=NUPP-1,NLOW+1,-1
40542 IF(IYEP.GE.K(I1,3)) GOTO 400
40552 C...Calculate sum of factorial moments in event.
40560 IF(IM.LE.2) IBIN=2**(10-IB)
40561 IF(IM.EQ.3) IBIN=4**(10-IB)
40562 IAGR=K(NLOW+1,IM)/IBIN
40564 DO 440 I=NLOW+2,NUPP+1
40566 IF(ICUT.EQ.IAGR) THEN
40570 ELSEIF(NAGR.EQ.2) THEN
40571 FEVFM(IB,1)=FEVFM(IB,1)+2D0
40572 ELSEIF(NAGR.EQ.3) THEN
40573 FEVFM(IB,1)=FEVFM(IB,1)+6D0
40574 FEVFM(IB,2)=FEVFM(IB,2)+6D0
40575 ELSEIF(NAGR.EQ.4) THEN
40576 FEVFM(IB,1)=FEVFM(IB,1)+12D0
40577 FEVFM(IB,2)=FEVFM(IB,2)+24D0
40578 FEVFM(IB,3)=FEVFM(IB,3)+24D0
40580 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
40581 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
40582 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40584 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40585 & (NAGR-3D0)*(NAGR-4D0)
40593 C...Add results to total statistics.
40596 IF(FEVFM(1,IP).LT.0.5D0) THEN
40598 ELSEIF(IM.LE.2) THEN
40599 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40601 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40603 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
40604 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
40608 NMUFM=NMUFM+(NUPP-NLOW)
40611 C...Write accumulated statistics on factorial moments.
40612 ELSEIF(MTABU.EQ.32) THEN
40613 FAC=1D0/MAX(1,NEVFM)
40614 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
40615 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
40616 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
40618 WRITE(MSTU(11),5500)
40621 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
40623 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
40624 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
40625 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
40627 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
40628 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40631 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
40636 C...Copy statistics on factorial moments into /PYJETS/.
40637 ELSEIF(MTABU.EQ.33) THEN
40638 FAC=1D0/MAX(1,NEVFM)
40645 IF(IM.NE.2) K(I,3)=2**(IB-1)
40647 IF(IM.NE.1) K(I,4)=2**(IB-1)
40649 P(I,1)=2D0*PARU(57)/K(I,3)
40650 V(I,1)=PARU(2)/K(I,4)
40652 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
40653 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40669 C...Reset statistics on Energy-Energy Correlation.
40670 ELSEIF(MTABU.EQ.40) THEN
40681 C...Find particles to include, with proper assumed mass.
40682 ELSEIF(MTABU.EQ.41) THEN
40688 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
40689 IF(MSTU(41).GE.2) THEN
40691 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40692 & KC.EQ.18) GOTO 570
40693 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40694 & PYCHGE(K(I,2)).EQ.0) GOTO 570
40697 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40698 IF(MSTU(42).GE.2) PMR=P(I,5)
40699 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40700 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40707 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
40708 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
40711 IF(NUPP.EQ.NLOW) RETURN
40713 C...Analyze Energy-Energy Correlation in event.
40714 FAC=(2D0/ECM**2)*50D0/PARU(1)
40718 DO 600 I1=NLOW+2,NUPP
40719 DO 590 I2=NLOW+1,I1-1
40720 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40721 & (P(I1,5)*P(I2,5))
40722 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
40723 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
40724 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
40728 FE1EC(J)=FE1EC(J)+FEVEE(J)
40729 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
40730 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
40731 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
40732 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
40733 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
40737 C...Write statistics on Energy-Energy Correlation.
40738 ELSEIF(MTABU.EQ.42) THEN
40739 FAC=1D0/MAX(1,NEVEE)
40740 WRITE(MSTU(11),5700) NEVEE
40743 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
40744 FEEC2=FAC*FE1EC(51-J)
40745 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
40747 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
40748 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
40749 & FEEC2,FEES2,FEECA,FEESA
40752 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
40753 ELSEIF(MTABU.EQ.43) THEN
40754 FAC=1D0/MAX(1,NEVEE)
40761 P(I,1)=FAC*FE1EC(I)
40762 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
40763 P(I,2)=FAC*FE1EC(51-I)
40764 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
40765 P(I,3)=FAC*FE1EA(I)
40766 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
40767 P(I,4)=PARU(1)*(I-1)/50D0
40768 P(I,5)=PARU(1)*I/50D0
40783 C...Reset statistics on decay channels.
40784 ELSEIF(MTABU.EQ.50) THEN
40789 C...Identify and order flavour content of final state.
40790 ELSEIF(MTABU.EQ.51) THEN
40794 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
40801 IF(K(I,2).LT.0) KFM=KFM-1
40802 DO 650 IDS=NDS-1,1,-1
40804 IF(KFM.LT.KFDM(IDS)) GOTO 660
40805 KFDM(IDS+1)=KFDM(IDS)
40811 C...Find whether old or new final state.
40813 IF(NDS.LT.KFDC(IDC,0)) THEN
40816 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
40818 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
40821 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
40830 700 IF(IKFDC.LT.0) THEN
40832 ELSEIF(NKFDC.GE.200) THEN
40836 DO 720 IDC=NKFDC,IKFDC,-1
40837 NPDC(IDC+1)=NPDC(IDC)
40839 KFDC(IDC+1,I)=KFDC(IDC,I)
40845 KFDC(IKFDC,I)=KFDM(I)
40849 NPDC(IKFDC)=NPDC(IKFDC)+1
40851 C...Write statistics on decay channels.
40852 ELSEIF(MTABU.EQ.52) THEN
40853 FAC=1D0/MAX(1,NEVDC)
40854 WRITE(MSTU(11),5900) NEVDC
40856 DO 740 I=1,KFDC(IDC,0)
40859 IF(2*KF.NE.KFM) KF=-KF
40860 CALL PYNAME(KF,CHAU)
40862 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
40864 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
40866 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
40868 C...Copy statistics on decay channels into /PYJETS/.
40869 ELSEIF(MTABU.EQ.53) THEN
40870 FAC=1D0/MAX(1,NEVDC)
40876 K(IDC,5)=KFDC(IDC,0)
40881 DO 770 I=1,KFDC(IDC,0)
40884 IF(2*KF.NE.KFM) KF=-KF
40885 IF(I.LE.5) P(IDC,I)=KF
40886 IF(I.GE.6) V(IDC,I-5)=KF
40888 V(IDC,5)=FAC*NPDC(IDC)
40903 C...Format statements for output on unit MSTU(11) (default 6).
40904 5000 FORMAT(///20X,'Event statistics - initial state'/
40905 &20X,'based on an analysis of ',I6,' events'//
40906 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
40907 &'according to fragmenting system multiplicity'/
40908 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
40909 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
40910 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
40911 5200 FORMAT(///20X,'Event statistics - final state'/
40912 &20X,'based on an analysis of ',I7,' events'//
40913 &5X,'Mean primary multiplicity =',F10.4/
40914 &5X,'Mean final multiplicity =',F10.4/
40915 &5X,'Mean charged multiplicity =',F10.4//
40916 &5X,'Number of particles produced per event (directly and via ',
40917 &'decays/branchings)'/
40918 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
40919 &8X,'Total'/35X,'prim seco prim seco'/)
40920 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
40921 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
40922 &20X,'based on an analysis of ',I6,' events'//
40923 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
40924 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
40926 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
40927 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
40928 &20X,'based on an analysis of ',I6,' events'//
40929 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
40930 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
40931 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
40932 5900 FORMAT(///20X,'Decay channel analysis - final state'/
40933 &20X,'based on an analysis of ',I6,' events'//
40934 &2X,'Probability',10X,'Complete final state'/)
40935 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
40936 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
40937 &'or table overflow)')
40942 C*********************************************************************
40945 C...Handles the generation of an e+e- annihilation jet event.
40947 SUBROUTINE PYEEVT(KFL,ECM)
40948 C...Double precision and integer declarations.
40949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40950 INTEGER PYK,PYCHGE,PYCOMP
40952 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40954 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40955 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40957 C...Check input parameters.
40958 IF(MSTU(12).GE.1) CALL PYLIST(0)
40959 IF(KFL.LT.0.OR.KFL.GT.8) THEN
40960 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
40961 IF(MSTU(21).GE.1) RETURN
40963 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
40964 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
40965 IF(ECM.LT.ECMMIN) THEN
40966 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
40967 IF(MSTU(21).GE.1) RETURN
40970 C...Check consistency of MSTJ options set.
40971 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
40973 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
40976 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
40978 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
40982 C...Initialize alpha_strong and total cross-section.
40983 MSTU(111)=MSTJ(108)
40984 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
40986 PARU(112)=PARJ(121)
40987 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
40988 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
40989 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
40991 IF(MSTJ(116).GE.3) MSTJ(116)=1
40994 C...Add initial e+e- to event record (documentation only).
40997 IF(NTRY.GT.100) THEN
40998 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
41003 IF(MSTJ(115).GE.2) THEN
41005 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
41007 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
41011 C...Radiative photon (in initial state).
41014 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
41016 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
41017 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
41019 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
41020 K(NC,3)=MIN(MSTJ(115)/2,1)
41023 C...Virtual exchange boson (gamma or Z0).
41024 IF(MSTJ(115).GE.3) THEN
41027 IF(MSTJ(102).EQ.2) KF=23
41031 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
41037 C...Choice of flavour and jet configuration.
41038 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
41039 IF(KFLC.EQ.0) GOTO 100
41040 CALL PYXJET(ECMC,NJET,CUT)
41042 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
41044 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
41045 IF(NJET.EQ.2) MSTJ(120)=1
41047 C...Fill jet configuration and origin.
41048 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
41049 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
41051 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
41052 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
41053 &-KFLC,ECMC,X1,X2,X4,X12,X14)
41054 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
41055 &-KFLC,ECMC,X1,X2,X4,X12,X14)
41056 IF(MSTU(24).NE.0) GOTO 100
41058 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
41061 C...Angular orientation according to matrix element.
41062 IF(MSTJ(106).EQ.1) THEN
41063 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
41064 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
41065 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
41068 C...Rotation and boost from radiative photon.
41070 DBEK=-PAK/(ECM-PAK)
41071 NMIN=NC+1-MSTJ(115)/3
41072 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
41073 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
41074 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
41077 C...Generate parton shower. Rearrange along strings and check.
41078 IF(MSTJ(101).EQ.5) THEN
41079 CALL PYSHOW(N-1,N,ECMC)
41081 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
41082 IF(MSTJ(105).GE.0) MSTU(28)=0
41085 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
41088 C...Fragmentation/decay generation. Information for PYTABU.
41089 IF(MSTJ(105).EQ.1) CALL PYEXEC
41096 C*********************************************************************
41099 C...Calculates total cross-section, including initial state
41100 C...radiation effects.
41102 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
41104 C...Double precision and integer declarations.
41105 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41106 INTEGER PYK,PYCHGE,PYCOMP
41108 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41109 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41110 SAVE /PYDAT1/,/PYDAT2/
41112 C...Status, (optimized) Q^2 scale, alpha_strong.
41114 MSTJ(119)=10*MSTJ(102)+KFL
41115 IF(MSTJ(111).EQ.0) THEN
41117 ELSEIF(MSTU(111).EQ.0) THEN
41118 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41119 & ((33D0-2D0*MSTU(112))*PARU(111)))))
41120 Q2R=PARJ(168)*ECM**2
41122 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41123 & (2D0*PARU(112)/ECM)**2))
41124 Q2R=PARJ(168)*ECM**2
41126 ALSPI=PYALPS(Q2R)/PARU(1)
41128 C...QCD corrections factor in R.
41129 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
41131 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
41133 ELSEIF(MSTJ(109).EQ.0) THEN
41134 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41135 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
41136 & LOG(PARJ(168))*ALSPI**2)
41137 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
41138 RQCD=1D0+(3D0/4D0)*ALSPI
41140 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
41143 C...Calculate Z0 width if default value not acceptable.
41144 IF(MSTJ(102).GE.3) THEN
41145 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
41146 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
41149 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
41150 & (2D0*PYMASS(KFLC)/ ECM)**2))
41151 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
41152 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
41153 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
41155 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
41159 C...Calculate propagator and related constants for QFD case.
41160 POLL=1D0-PARJ(131)*PARJ(132)
41161 IF(MSTJ(102).GE.2) THEN
41162 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41163 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41164 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
41165 VE=4D0*PARU(102)-1D0
41166 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
41167 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41172 C...Loop over different flavours: charge, velocity.
41177 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
41178 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
41181 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
41182 QF=KCHG(KFLC,1)/3D0
41184 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
41186 C...Calculate R and sum of charges for QED or QFD case.
41187 RQQ=RQQ+3D0*QF**2*POLL
41188 IF(MSTJ(102).LE.1) THEN
41189 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
41191 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41192 RQV=RQV-6D0*QF*VF*SF1I
41193 RVA=RVA+3D0*(VF**2+1D0)*SF1W
41194 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
41195 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
41199 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
41201 C...Calculate cross-section, including QCD corrections.
41204 PARJ(143)=RTOT*RQCD
41205 PARJ(144)=PARJ(143)
41206 PARJ(145)=PARJ(141)*86.8D0/ECM**2
41207 PARJ(146)=PARJ(142)*86.8D0/ECM**2
41208 PARJ(147)=PARJ(143)*86.8D0/ECM**2
41209 PARJ(148)=PARJ(147)
41210 PARJ(157)=RSUM*RQCD
41214 IF(MSTJ(107).LE.0) RETURN
41216 C...Virtual cross-section.
41218 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41219 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
41220 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
41221 &1.526D0*LOG(ECM**2/0.932D0)
41223 C...Soft and hard radiative cross-section in QED case.
41224 IF(MSTJ(102).LE.1) THEN
41225 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
41226 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
41227 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
41229 C...Soft and hard radiative cross-section in QFD case.
41231 SZM=1D0-(PARJ(123)/ECM)**2
41232 SZW=PARJ(123)*PARJ(124)/ECM**2
41233 PARJ(161)=-RQQ/RSUM
41234 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
41235 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
41236 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
41237 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
41238 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
41239 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
41240 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
41241 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
41242 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
41243 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
41244 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
41245 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
41246 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
41249 C...Total cross-section and fraction of hard photon events.
41250 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
41251 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
41252 PARJ(144)=PARJ(157)
41253 PARJ(148)=PARJ(144)*86.8D0/ECM**2
41259 C*********************************************************************
41262 C...Generates initial state photon radiation.
41264 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
41266 C...Double precision and integer declarations.
41267 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41268 INTEGER PYK,PYCHGE,PYCOMP
41270 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41273 C...Function: cumulative hard photon spectrum in QFD case.
41274 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
41275 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
41277 C...Determine whether radiative photon or not.
41280 IF(PARJ(160).LT.PYR(0)) RETURN
41283 C...Photon energy range. Find photon momentum in QED case.
41285 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41286 IF(MSTJ(102).LE.1) THEN
41287 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
41288 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
41290 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
41292 SZM=1D0-(PARJ(123)/ECM)**2
41293 SZW=PARJ(123)*PARJ(124)/ECM**2
41296 FXKD=1D-4*(FXKU-FXKL)
41297 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
41302 IF(FXKV.GT.FXKR) THEN
41309 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
41310 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
41314 C...Photon polar and azimuthal angle.
41315 PME=2D0*(PYMASS(11)/ECM)**2
41316 120 CTHM=PME*(2D0/PME)**PYR(0)
41317 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
41318 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
41320 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
41321 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
41322 THEK=PYANGL(CTHE,STHE)
41323 PHIK=PARU(2)*PYR(0)
41325 C...Rotation angle for hadronic system.
41327 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
41329 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
41330 &(2D0-XK*(1D0-SGN*CTHE)))
41335 C*********************************************************************
41338 C...Selects flavour for produced qqbar pair.
41340 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
41342 C...Double precision and integer declarations.
41343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41344 INTEGER PYK,PYCHGE,PYCOMP
41346 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41347 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41348 SAVE /PYDAT1/,/PYDAT2/
41350 C...Calculate maximum weight in QED or QFD case.
41351 IF(MSTJ(102).LE.1) THEN
41354 POLL=1D0-PARJ(131)*PARJ(132)
41355 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41356 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41357 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
41358 VE=4D0*PARU(102)-1D0
41359 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
41360 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41361 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
41362 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
41363 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
41367 C...Choose flavour. Gives charge and velocity.
41370 IF(NTRY.GT.100) THEN
41371 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
41376 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
41379 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
41380 QF=KCHG(KFLC,1)/3D0
41382 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
41384 C...Calculate weight in QED or QFD case.
41385 IF(MSTJ(102).LE.1) THEN
41387 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
41389 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41390 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
41391 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
41393 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
41396 C...Weighting or new event (radiative photon). Cross-section update.
41397 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
41398 PARJ(158)=PARJ(158)+1D0
41399 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
41400 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
41401 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
41402 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
41403 PARJ(148)=PARJ(144)*86.8D0/ECM**2
41408 C*********************************************************************
41411 C...Selects number of jets in matrix element approach.
41413 SUBROUTINE PYXJET(ECM,NJET,CUT)
41415 C...Double precision and integer declarations.
41416 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41417 INTEGER PYK,PYCHGE,PYCOMP
41419 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41421 C...Local array and data.
41423 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
41425 C...Trivial result for two-jets only, including parton shower.
41426 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41429 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
41430 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
41432 IF(MSTJ(109).EQ.2) CF=1D0
41433 IF(MSTJ(111).EQ.0) THEN
41436 ELSEIF(MSTU(111).EQ.0) THEN
41437 PARJ(169)=MIN(1D0,PARJ(129))
41438 Q2=PARJ(169)*ECM**2
41439 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41440 & ((33D0-2D0*MSTU(112))*PARU(111)))))
41441 Q2R=PARJ(168)*ECM**2
41443 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
41444 Q2=PARJ(169)*ECM**2
41445 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41446 & (2D0*PARU(112)/ECM)**2))
41447 Q2R=PARJ(168)*ECM**2
41450 C...alpha_strong for R and R itself.
41451 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
41452 IF(IABS(MSTJ(101)).EQ.1) THEN
41454 ELSEIF(MSTJ(109).EQ.0) THEN
41455 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41456 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
41457 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
41459 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
41462 C...alpha_strong for jet rate. Initial value for y cut.
41463 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41464 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
41465 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
41466 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
41467 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41469 C...Parametrization of first order three-jet cross-section.
41470 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
41473 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
41474 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
41475 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
41476 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
41477 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
41481 C...Parametrization of second order three-jet cross-section.
41482 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
41483 & CUT.GE.0.25D0) THEN
41485 ELSEIF(MSTJ(110).LE.1) THEN
41486 CT=LOG(1D0/CUT-2D0)
41487 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
41488 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
41490 C...Interpolation in second/first order ratio for Zhu parametrization.
41491 ELSEIF(MSTJ(110).EQ.2) THEN
41494 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41500 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
41502 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
41505 C...Shift in second order three-jet cross-section with optimized Q^2.
41506 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
41507 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
41508 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
41510 C...Parametrization of second order four-jet cross-section.
41511 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
41514 CT=LOG(1D0/CUT-5D0)
41515 IF(CUT.LE.0.018D0) THEN
41516 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
41517 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
41519 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
41520 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41522 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
41523 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
41524 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
41525 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
41526 & 0.002093D0*CT**3)
41527 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41529 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
41530 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
41533 C...If negative three-jet rate, change y' optimization parameter.
41534 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
41535 & PARJ(169).LT.0.99D0) THEN
41536 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41537 Q2=PARJ(169)*ECM**2
41538 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41542 C...If too high cross-section, use harder cuts, or fail.
41543 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
41544 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
41545 & PARJ(169).LT.0.99D0) THEN
41546 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41547 Q2=PARJ(169)*ECM**2
41548 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41550 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
41552 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
41554 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
41555 & PARJ(154))**(-1D0/3D0)
41556 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41560 C...Scalar gluon (first order only).
41562 ALSPI=PYALPS(ECM**2)/PARU(1)
41563 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
41565 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
41566 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
41571 C...Select number of jets.
41573 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41575 ELSEIF(MSTJ(101).LE.0) THEN
41576 NJET=MIN(4,2-MSTJ(101))
41580 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
41581 IF(PARJ(154).GT.RNJ) NJET=4
41587 C*********************************************************************
41590 C...Selects the kinematical variables of three-jet events.
41592 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
41594 C...Double precision and integer declarations.
41595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41596 INTEGER PYK,PYCHGE,PYCOMP
41598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41601 DIMENSION ZHUP(5,12)
41603 C...Coefficients of Zhu second order parametrization.
41604 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
41605 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
41606 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
41607 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
41608 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
41609 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
41610 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
41611 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
41612 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
41613 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
41614 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
41616 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
41617 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
41620 C...Event type. Mass effect factors and other common constants.
41624 QME=(2D0*PMQ/ECM)**2
41625 IF(MSTJ(109).NE.1) THEN
41627 CUTD=LOG(1D0/CUT-2D0)
41628 IF(MSTJ(109).EQ.0) THEN
41632 WTMX=MIN(20D0,37D0-6D0*CUTD)
41633 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
41641 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
41642 ALS2PI=PARU(118)/PARU(2)
41644 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
41645 & LOG(PARJ(169))*ALS2PI
41646 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
41648 C...Choose three-jet events in allowed region.
41650 110 Y13L=CUTL+CUTD*PYR(0)
41651 Y23L=CUTL+CUTD*PYR(0)
41655 IF(Y12.LE.CUT) GOTO 110
41656 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
41658 C...Second order corrections.
41659 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
41664 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
41665 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
41666 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
41667 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
41668 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
41669 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
41670 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
41671 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
41672 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
41673 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
41674 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
41675 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
41676 & TR*(2D0*CUTL/3D0-10D0/9D0)+
41677 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
41678 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
41679 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
41680 & Y13*Y23)/(Y12+Y13)**2)/WT1+
41681 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
41682 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
41683 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
41684 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
41685 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
41686 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
41687 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
41688 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41689 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41690 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
41692 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
41693 C...Second order corrections; Zhu parametrization of ERT.
41698 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41702 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41703 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41704 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41705 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41708 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41709 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41710 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41711 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41713 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41714 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41715 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41716 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41717 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
41719 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41720 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41721 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
41724 C...Impose mass cuts (gives two jets). For fixed jet number new try.
41728 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
41729 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
41730 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
41731 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
41732 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
41734 C...Scalar gluon model (first order only, no mass effects).
41737 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
41738 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
41739 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
41740 X1=1D0-0.5D0*(X3+YD)
41741 X2=1D0-0.5D0*(X3-YD)
41742 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
41743 IF(MSTJ(102).GE.2) THEN
41744 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
41745 & X3**2*PYR(0)) NJET=2
41747 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
41753 C*********************************************************************
41756 C...Selects the kinematical variables of four-jet events.
41758 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
41760 C...Double precision and integer declarations.
41761 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41762 INTEGER PYK,PYCHGE,PYCOMP
41764 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41767 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
41769 C...Common constants. Colour factors for QCD and Abelian gluon theory.
41771 QME=(2D0*PMQ/ECM)**2
41772 CT=LOG(1D0/CUT-5D0)
41773 IF(MSTJ(109).EQ.0) THEN
41783 C...Choice of process (qqbargg or qqbarqqbar).
41786 IF(PARJ(155).GT.PYR(0)) IT=2
41787 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
41788 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
41789 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
41790 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
41793 C...Sample the five kinematical variables (for qqgg preweighted in y34).
41794 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
41795 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
41796 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
41797 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
41798 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
41800 CP=COS(PARU(1)*PYR(0))
41803 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
41804 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
41805 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
41807 Y12=1D0-Y134-Y23-Y24
41808 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
41812 C...Calculate matrix elements for qqgg or qqqq process.
41817 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
41818 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
41819 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
41820 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
41821 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
41822 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
41823 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
41824 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
41825 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
41826 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
41827 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
41828 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
41829 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
41830 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
41831 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
41832 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
41833 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
41834 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
41835 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
41836 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
41837 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
41838 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
41839 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
41840 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
41841 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
41842 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
41843 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
41844 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
41845 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
41846 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
41847 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
41848 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
41849 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
41850 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
41851 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
41852 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
41853 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
41854 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
41855 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
41856 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
41857 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
41860 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
41861 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
41862 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
41863 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
41864 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
41865 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
41866 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
41867 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
41868 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
41869 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
41870 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
41871 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
41872 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
41873 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
41874 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
41875 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
41876 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
41877 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
41880 C...Permutations of momenta in matrix element. Weighting.
41881 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
41892 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
41903 IF(IC.LE.3) GOTO 120
41904 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
41907 C...qqgg events: string configuration and event type.
41909 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
41910 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
41911 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
41912 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
41913 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
41914 IF(ID.EQ.2) GOTO 130
41915 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
41916 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
41917 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
41918 IF(ID.EQ.2) GOTO 130
41921 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
41922 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
41925 C...Mass cuts. Kinematical variables out.
41926 IF(Y12.LE.CUT+QME) NJET=2
41927 IF(NJET.EQ.2) GOTO 150
41928 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
41929 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
41930 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
41932 X12=(1D0-Q12)*Y13+Q12*Y23
41934 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
41936 C...qqbarqqbar events: string configuration, choose new flavour.
41939 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
41940 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
41941 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
41942 IF(WTR.LT.WTD(4)) ID=4
41943 IF(ID.GE.2) GOTO 130
41946 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
41947 140 KFLN=1+INT(5D0*PYR(0))
41948 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
41949 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
41950 IF(KFLN.GT.MSTJ(104)) NJET=2
41952 QMEN=(2D0*PMQN/ECM)**2
41954 C...Mass cuts. Kinematical variables out.
41955 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
41956 IF(NJET.EQ.2) GOTO 150
41957 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
41958 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
41959 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
41960 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
41961 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
41962 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
41965 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
41967 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
41968 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
41969 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
41971 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
41976 C*********************************************************************
41979 C...Gives the angular orientation of events.
41981 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
41983 C...Double precision and integer declarations.
41984 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41985 INTEGER PYK,PYCHGE,PYCOMP
41987 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41988 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41989 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41990 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41992 C...Charge. Factors depending on polarization for QED case.
41994 POLL=1D0-PARJ(131)*PARJ(132)
41995 POLD=PARJ(132)-PARJ(131)
41996 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
42002 C...Factors depending on flavour, energy and polarization for QFD case.
42004 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
42005 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
42006 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
42008 VE=4D0*PARU(102)-1D0
42010 VF=AF-4D0*QF*PARU(102)
42011 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
42012 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
42013 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
42014 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
42015 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
42016 & SFW*SFF**2*(VE**2-AE**2))
42017 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
42021 C...Mass factor. Differential cross-sections for two-jet events.
42024 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
42025 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
42027 SIGU=4D0*SQRT(1D0-QME)
42028 SIGL=2D0*QME*SQRT(1D0-QME)
42034 C...Kinematical variables. Reduce four-jet event to three-jet one.
42037 X1=2D0*P(NC+1,4)/ECM
42038 X2=2D0*P(NC+3,4)/ECM
42040 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
42041 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
42042 X1=2D0*P(NC+1,4)/ECMR
42043 X2=2D0*P(NC+4,4)/ECMR
42046 C...Differential cross-sections for three-jet (or reduced four-jet).
42047 XQ=(1D0-X1)/(1D0-X2)
42048 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
42049 ST12=SQRT(1D0-CT12**2)
42050 IF(MSTJ(109).NE.1) THEN
42051 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
42052 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
42053 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
42054 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
42056 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
42057 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
42058 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
42059 SIGA=X2**2*ST12/SQ2
42060 SIGP=2D0*(X1**2-X2**2*CT12)
42062 C...Differential cross-sect for scalar gluons (no mass effects).
42066 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
42067 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
42068 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
42069 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
42070 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
42071 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
42072 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
42073 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
42074 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
42075 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
42076 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
42080 C...Upper bounds for differential cross-section.
42085 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
42086 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
42087 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
42088 &2D0*HF2A*ABS(SIGP)
42090 C...Generate angular orientation according to differential cross-sect.
42091 100 CHI=PARU(2)*PYR(0)
42092 CTHE=2D0*PYR(0)-1D0
42100 C2PHI=COS(2D0*(PHI-PARJ(134)))
42101 S2PHI=SIN(2D0*(PHI-PARJ(134)))
42102 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
42103 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
42104 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
42105 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
42106 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
42107 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
42108 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
42109 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
42114 C*********************************************************************
42117 C...Generates Upsilon and toponium decays into three gluons
42118 C...or two gluons and a photon.
42120 SUBROUTINE PYONIA(KFL,ECM)
42122 C...Double precision and integer declarations.
42123 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42124 INTEGER PYK,PYCHGE,PYCOMP
42126 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42127 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42128 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42129 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42131 C...Printout. Check input parameters.
42132 IF(MSTU(12).GE.1) CALL PYLIST(0)
42133 IF(KFL.LT.0.OR.KFL.GT.8) THEN
42134 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
42135 IF(MSTU(21).GE.1) RETURN
42137 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
42138 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
42139 IF(MSTU(21).GE.1) RETURN
42142 C...Initial e+e- and onium state (optional).
42144 IF(MSTJ(115).GE.2) THEN
42146 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
42148 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
42152 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
42158 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
42164 C...Choose x1 and x2 according to matrix element.
42169 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
42170 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
42173 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
42174 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
42176 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
42177 MSTU(111)=MSTJ(108)
42178 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
42180 PARU(112)=PARJ(121)
42181 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
42183 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
42184 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
42187 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
42188 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
42190 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
42191 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
42194 ECMC=SQRT(1D0-X1)*ECM
42195 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
42200 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
42201 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
42202 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
42203 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
42205 IF(ECMC.LT.4D0*PARJ(127)) THEN
42209 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
42215 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
42218 C...Differential cross-sections. Upper limit for cross-section.
42219 IF(MSTJ(106).EQ.1) THEN
42221 HF1=1D0-PARJ(131)*PARJ(132)
42223 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
42224 ST13=SQRT(1D0-CT13**2)
42225 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
42226 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
42228 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
42229 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
42230 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
42232 C...Angular orientation of event.
42233 120 CHI=PARU(2)*PYR(0)
42234 CTHE=2D0*PYR(0)-1D0
42242 C2PHI=COS(2D0*(PHI-PARJ(134)))
42243 S2PHI=SIN(2D0*(PHI-PARJ(134)))
42244 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
42245 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
42246 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
42247 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
42248 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
42249 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
42250 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
42251 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
42254 C...Generate parton shower. Rearrange along strings and check.
42255 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
42256 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
42258 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
42259 IF(MSTJ(105).GE.0) MSTU(28)=0
42262 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
42265 C...Generate fragmentation. Information for PYTABU:
42266 IF(MSTJ(105).EQ.1) CALL PYEXEC
42267 MSTU(161)=110*KFLC+3
42273 C*********************************************************************
42276 C...Books a histogram.
42278 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
42280 C...Double precision declaration.
42281 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42283 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42285 C...Local character variables.
42286 CHARACTER TITLE*(*), TITFX*60
42288 C...Check that input is sensible. Find initial address in memory.
42289 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42290 &'(PYBOOK:) not allowed histogram number')
42291 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
42292 &'(PYBOOK:) not allowed number of bins')
42293 IF(XL.GE.XU) CALL PYERRM(28,
42294 &'(PYBOOK:) x limits in wrong order')
42296 IHIST(4)=IHIST(4)+28+NX
42297 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
42298 &'(PYBOOK:) out of histogram space')
42301 C...Store histogram size and reset contents.
42305 BIN(IS+4)=(XU-XL)/NX
42308 C...Store title by conversion to integer to double precision.
42311 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
42312 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
42318 C*********************************************************************
42321 C...Fills entry in histogram.
42323 SUBROUTINE PYFILL(ID,X,W)
42325 C...Double precision declaration.
42326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42328 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42331 C...Find initial address in memory. Increase number of entries.
42332 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42333 &'(PYFILL:) not allowed histogram number')
42335 IF(IS.EQ.0) CALL PYERRM(28,
42336 &'(PYFILL:) filling unbooked histogram')
42337 BIN(IS+5)=BIN(IS+5)+1D0
42339 C...Find bin in x, including under/overflow, and fill.
42340 IF(X.LT.BIN(IS+2)) THEN
42341 BIN(IS+6)=BIN(IS+6)+W
42342 ELSEIF(X.GE.BIN(IS+3)) THEN
42343 BIN(IS+8)=BIN(IS+8)+W
42345 BIN(IS+7)=BIN(IS+7)+W
42346 IX=(X-BIN(IS+2))/BIN(IS+4)
42347 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
42348 BIN(IS+9+IX)=BIN(IS+9+IX)+W
42354 C*********************************************************************
42357 C...Multiplies histogram contents by factor.
42359 SUBROUTINE PYFACT(ID,F)
42361 C...Double precision declaration.
42362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42364 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42367 C...Find initial address in memory. Multiply all contents bins.
42368 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42369 &'(PYFACT:) not allowed histogram number')
42371 IF(IS.EQ.0) CALL PYERRM(28,
42372 &'(PYFACT:) scaling unbooked histogram')
42373 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
42380 C*********************************************************************
42383 C...Performs operations between histograms.
42385 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
42387 C...Double precision declaration.
42388 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42390 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42392 C...Character variable.
42395 C...Find initial addresses in memory, and histogram size.
42396 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
42397 &'(PYFACT:) not allowed histogram number')
42399 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
42400 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
42401 NX=NINT(BIN(IS3+1))
42402 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
42404 C...Update info on number of histogram entries.
42405 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
42406 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
42407 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
42408 BIN(IS3+5)=BIN(IS1+5)
42411 C...Operations on pair of histograms: addition, subtraction,
42412 C...multiplication, division.
42413 IF(OPER.EQ.'+') THEN
42415 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
42417 ELSEIF(OPER.EQ.'-') THEN
42419 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
42421 ELSEIF(OPER.EQ.'*') THEN
42423 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
42425 ELSEIF(OPER.EQ.'/') THEN
42428 IF(ABS(FA2).LE.1D-20) THEN
42431 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
42435 C...Operations on single histogram: multiplication+addition,
42436 C...square root+addition, logarithm+addition.
42437 ELSEIF(OPER.EQ.'A') THEN
42439 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
42441 ELSEIF(OPER.EQ.'S') THEN
42443 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
42445 ELSEIF(OPER.EQ.'L') THEN
42448 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
42449 & ZMIN=0.8D0*BIN(IS1+IX)
42452 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
42455 C...Operation on two or three histograms: average and
42456 C...standard deviation.
42457 ELSEIF(OPER.EQ.'M') THEN
42459 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42462 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
42465 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42468 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
42472 BIN(IS1+IX)=F1*BIN(IS1+IX)
42479 C*********************************************************************
42482 C...Prints and resets all histograms.
42486 C...Double precision declaration.
42487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42489 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42492 C...Loop over histograms, print and reset used ones.
42493 DO 100 ID=1,IHIST(1)
42495 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
42504 C*********************************************************************
42507 C...Prints a histogram (but does not reset it).
42509 SUBROUTINE PYPLOT(ID)
42511 C...Double precision declaration.
42512 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42514 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42515 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42516 SAVE /PYDAT1/,/PYBINS/
42517 C...Local arrays and character variables.
42518 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
42519 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
42521 C...Steps in histogram scale. Character sequence.
42522 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
42523 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
42525 C...Find initial address in memory; skip if empty histogram.
42526 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42529 IF(NINT(BIN(IS+5)).LE.0) THEN
42530 WRITE(MSTU(11),5000) ID
42534 C...Number of histogram lines and x bins.
42538 C...Extract title by conversion from double precision via integer.
42540 IEQ=NINT(BIN(IS+8+NX+IT))
42541 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
42542 & //CHAR(MOD(IEQ,256))
42545 C...Find time; print title.
42547 IF(IDATI(1).GT.0) THEN
42548 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
42550 WRITE(MSTU(11),5200) ID, TITLE
42553 C...Find minimum and maximum bin content.
42556 DO 110 IX=IS+10,IS+8+NX
42557 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
42558 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
42561 C...Determine scale and step size for y axis.
42562 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
42563 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
42564 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
42565 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
42566 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
42567 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
42570 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
42574 C...Convert bin contents to integer form; fractional fill in top row.
42576 CTA=ABS(BIN(IS+8+IX))/DY
42577 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
42578 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
42580 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
42581 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
42583 C...Print histogram row by row.
42584 DO 150 IR=IRMA,IRMI,-1
42585 IF(IR.EQ.0) GOTO 150
42588 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
42589 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
42591 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
42594 C...Print sign and value of bin contents.
42595 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
42598 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
42599 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
42601 WRITE(MSTU(11),5400) OUT
42604 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42606 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
42609 C...Print sign and value of lower bin edge.
42610 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
42614 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
42615 & OUT(IX:IX)=CHA(11)
42616 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
42618 WRITE(MSTU(11),5600) OUT
42621 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42623 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
42627 C...Calculate and print statistics.
42632 CTA=ABS(BIN(IS+8+IX))
42633 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
42636 CXXSUM=CXXSUM+CTA*X**2
42638 XMEAN=CXSUM/MAX(CSUM,1D-20)
42639 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
42640 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
42641 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
42643 C...Formats for output.
42644 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
42645 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
42647 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
42648 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
42649 5400 FORMAT(/8X,'Contents',3X,A100)
42650 5500 FORMAT(9X,'*10**',I2,3X,A100)
42651 5600 FORMAT(/8X,'Low edge',3X,A100)
42652 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
42653 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
42654 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
42659 C*********************************************************************
42662 C...Resets bin contents of a histogram.
42664 SUBROUTINE PYNULL(ID)
42666 C...Double precision declaration.
42667 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42669 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42672 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42675 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
42682 C*********************************************************************
42685 C...Dumps histogram contents on file for reading by other program.
42686 C...Can also read back own dump.
42688 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
42690 C...Double precision declaration.
42691 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42693 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42695 C...Local arrays and character variables.
42696 DIMENSION IHI(*),ISS(100),VAL(5)
42697 CHARACTER TITLE*60,FORMAT*13
42699 C...Dump all histograms that have been booked,
42700 C...including titles and ranges, one after the other.
42701 IF(MDUMP.EQ.1) THEN
42703 C...Loop over histograms and find which are wanted and booked.
42718 C...Write title, histogram size, filling statistics.
42721 IEQ=NINT(BIN(IS+8+NX+IT))
42722 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
42723 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
42725 WRITE(LFN,5100) ID,TITLE
42726 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
42727 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
42731 C...Write histogram contents, in groups of five.
42732 DO 120 IXG=1,(NX+4)/5
42736 VAL(IXV)=BIN(IS+8+IX)
42741 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
42744 C...Go to next histogram; finish.
42745 ELSEIF(NHI.GT.0) THEN
42746 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
42750 C...Read back in histograms dumped MDUMP=1.
42751 ELSEIF(MDUMP.EQ.2) THEN
42753 C...Read histogram number, title and range, and book.
42754 140 READ(LFN,5100,END=170) ID,TITLE
42755 READ(LFN,5200) NX,XL,XU
42756 CALL PYBOOK(ID,TITLE,NX,XL,XU)
42759 C...Read filling statistics.
42760 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
42761 BIN(IS+5)=DBLE(NENTRY)
42763 C...Read histogram contents, in groups of five.
42764 DO 160 IXG=1,(NX+4)/5
42765 READ(LFN,5400) (VAL(IXV),IXV=1,5)
42768 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
42772 C...Go to next histogram; finish.
42776 C...Write histogram contents in column format,
42777 C...convenient e.g. for GNUPLOT input.
42778 ELSEIF(MDUMP.EQ.3) THEN
42780 C...Find addresses to wanted histograms.
42794 IF(IS.NE.0.AND.NSS.LT.100) THEN
42797 ELSEIF(NSS.GE.100) THEN
42798 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
42799 ELSEIF(NHI.GT.0) THEN
42800 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
42804 C...Check that they have common number of x bins. Fix format.
42805 NX=NINT(BIN(ISS(1)+1))
42807 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
42808 CALL PYERRM(8,'(PYDUMP:) different number of bins')
42812 FORMAT='(1P,000E12.4)'
42813 WRITE(FORMAT(5:7),'(I3)') NSS+1
42815 C...Write histogram contents; first column x values.
42817 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
42818 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
42823 C...Formats for output.
42824 5100 FORMAT(I5,5X,A60)
42825 5200 FORMAT(I5,1P,2D12.4)
42826 5300 FORMAT(I12,1P,3D12.4)
42827 5400 FORMAT(1P,5D12.4)
42832 C*********************************************************************
42835 C...Dummy routine, which the user can replace in order to make cuts on
42836 C...the kinematics on the parton level before the matrix elements are
42837 C...evaluated and the event is generated. The cross-section estimates
42838 C...will automatically take these cuts into account, so the given
42839 C...values are for the allowed phase space region only. MCUT=0 means
42840 C...that the event has passed the cuts, MCUT=1 that it has failed.
42842 SUBROUTINE PYKCUT(MCUT)
42844 C...Double precision and integer declarations.
42845 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42846 INTEGER PYK,PYCHGE,PYCOMP
42848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42849 COMMON/PYINT1/MINT(400),VINT(400)
42850 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42851 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
42853 C...Set default value (accepting event) for MCUT.
42856 C...Read out subprocess number.
42860 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
42864 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
42866 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
42868 C...Calculate x_1, x_2, x_F.
42869 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
42870 X1=SQRT(TAU)*EXP(YST)
42871 X2=SQRT(TAU)*EXP(-YST)
42873 X1=SQRT(TAUP)*EXP(YST)
42874 X2=SQRT(TAUP)*EXP(-YST)
42878 C...Calculate shat, that, uhat, p_T^2.
42884 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
42885 RPTS=4D0*VINT(71)**2/SHAT
42886 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
42889 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
42890 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
42891 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
42892 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
42894 C...Decisions by user to be put here.
42896 C...Stop program if this routine is ever called.
42897 C...You should not copy these lines to your own routine.
42898 WRITE(MSTU(11),5000)
42899 IF(PYR(0).LT.10D0) STOP
42901 C...Format for error printout.
42902 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
42903 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
42904 &1X,'Execution stopped!')
42909 C*********************************************************************
42912 C...Dummy routine, which the user can replace in order to multiply the
42913 C...standard PYTHIA differential cross-section by a process- and
42914 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
42915 C...to generation of weighted events, with weight 1/WTXS, while for
42916 C...MSTP(142)=2 it corresponds to a modification of the underlying
42919 SUBROUTINE PYEVWT(WTXS)
42921 C...Double precision and integer declarations.
42922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42923 INTEGER PYK,PYCHGE,PYCOMP
42925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42926 COMMON/PYINT1/MINT(400),VINT(400)
42927 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42928 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
42930 C...Set default weight for WTXS.
42933 C...Read out subprocess number.
42937 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
42941 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
42943 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
42945 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
42954 C...Modifications by user to be put here.
42956 C...Stop program if this routine is ever called.
42957 C...You should not copy these lines to your own routine.
42958 WRITE(MSTU(11),5000)
42959 IF(PYR(0).LT.10D0) STOP
42961 C...Format for error printout.
42962 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
42963 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
42964 &1X,'Execution stopped!')
42969 C*********************************************************************
42972 C...Dummy copy of routine to be called by user to set up a user-defined
42975 SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX)
42977 C...Double precision and integer declarations.
42978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42979 INTEGER PYK,PYCHGE,PYCOMP
42981 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42982 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42983 COMMON/PYINT6/PROC(0:500)
42985 SAVE /PYDAT1/,/PYINT2/,/PYINT6/
42986 C...Local character variable.
42987 CHARACTER*(*) TITLE
42989 C...Check that subprocess number free.
42990 IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN
42991 WRITE(MSTU(11),5000) ISUB
42995 C...Fill information on new process.
42997 COEF(ISUB,1)=SIGMAX
42998 PROC(ISUB)=TITLE//' '
43000 C...Format for error output.
43001 5000 FORMAT(1X,'Error: user-defined subprocess code ',I4,
43002 &' not allowed.'//1X,'Execution stopped!')
43007 C*********************************************************************
43010 C...Dummy routine, to be replaced by user. When called from PYTHIA
43011 C...the subprocess number ISUB will be given, and PYUPEV is supposed
43012 C...to generate an event of this type, to be stored in the PYUPPR
43013 C...commonblock. SIGEV gives the differential cross-section associated
43014 C...with the event, i.e. the acceptance probability of the event is
43015 C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
43018 SUBROUTINE PYUPEV(ISUB,SIGEV)
43020 C...Double precision and integer declarations.
43021 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43022 INTEGER PYK,PYCHGE,PYCOMP
43024 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43025 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
43026 SAVE /PYDAT1/,/PYUPPR/
43028 C...Stop program if this routine is ever called.
43029 C...You should not copy these lines to your own routine.
43030 WRITE(MSTU(11),5000)
43031 IF(PYR(0).LT.10D0) STOP
43034 C...Format for error printout.
43035 5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ',
43036 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43037 &1X,'Execution stopped!')
43042 C*********************************************************************
43045 C...Dummy routine, to be replaced by user, to handle the decay of a
43046 C...polarized tau lepton.
43048 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
43049 C...IORIG is the position where the mother of the tau is stored;
43050 C... is 0 when the mother is not stored.
43051 C...KFORIG is the flavour of the mother of the tau;
43052 C... is 0 when the mother is not known.
43053 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
43054 C... e.g. in B hadron semileptonic decays the W propagator
43055 C... is not explicitly stored but the W code is still unambiguous.
43057 C...NDECAY is the number of decay products in the current tau decay.
43058 C...These decay products should be added to the /PYJETS/ common block,
43059 C...in positions N+1 through N+NDECAY. For each product I you must
43060 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
43061 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
43063 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
43065 C...Double precision and integer declarations.
43066 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43067 INTEGER PYK,PYCHGE,PYCOMP
43069 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43070 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43071 SAVE /PYJETS/,/PYDAT1/
43073 C...Stop program if this routine is ever called.
43074 C...You should not copy these lines to your own routine.
43075 NDECAY=ITAU+IORIG+KFORIG
43076 WRITE(MSTU(11),5000)
43077 IF(PYR(0).LT.10D0) STOP
43079 C...Format for error printout.
43080 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
43081 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43082 &1X,'Execution stopped!')
43087 C*********************************************************************
43090 C...Finds current date and time.
43091 C...Since this task is not standardized in Fortran 77, the routine
43092 C...is dummy, to be replaced by the user. Examples are given for
43093 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
43094 C...you do not have access to suitable routines.
43096 SUBROUTINE PYTIME(IDATI)
43098 C...Double precision and integer declarations.
43099 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43100 INTEGER PYK,PYCHGE,PYCOMP
43103 INTEGER IDATI(6),IDTEMP(3)
43105 C...Example 0: if you do not have suitable routines.
43110 C...Example 1: Fortran 90 routine.
43112 C CALL DATE_AND_TIME(VALUES=IVAL)
43120 C...Example 2: DEC Fortran 77.
43121 C CALL IDATE(IMON,IDAY,IYEAR)
43122 C IDATI(1)=1900+IYEAR
43125 C CALL ITIME(IHOUR,IMIN,ISEC)
43130 C...Example 3: DEC Fortran
43131 C CALL IDATE(IMON,IDAY,IYEAR)
43132 C IDATI(1)=1900+IYEAR
43139 C READ(ATIME(1:2),'(I2)') IHOUR
43140 C READ(ATIME(4:5),'(I2)') IMIN
43141 C READ(ATIME(7:8),'(I2)') ISEC
43146 C...Example 4: GNU LINUX libU77.
43147 C CALL IDATE(IDTEMP)
43148 C IDATI(1)=IDTEMP(3)
43149 C IDATI(2)=IDTEMP(2)
43150 C IDATI(3)=IDTEMP(1)
43151 C CALL ITIME(IDTEMP)
43152 C IDATI(4)=IDTEMP(1)
43153 C IDATI(5)=IDTEMP(2)
43154 C IDATI(6)=IDTEMP(3)
git://git.uio.no / u / mrichter / AliRoot.git / blob