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*********************************************************************
215 C...Default values for switches and parameters,
216 C...and particle, decay and process data.
220 C...Double precision and integer declarations.
221 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
222 INTEGER PYK,PYCHGE,PYCOMP
224 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
225 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
226 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
227 COMMON/PYDAT4/CHAF(500,2)
229 COMMON/PYDATR/MRPY(6),RRPY(100)
230 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
231 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
232 COMMON/PYINT1/MINT(400),VINT(400)
233 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
234 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
235 COMMON/PYINT4/MWID(500),WIDS(500,5)
236 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
237 COMMON/PYINT6/PROC(0:500)
239 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
240 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
241 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
243 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
244 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
245 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
246 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYBINS/
248 C...PYDAT1, containing status codes and most parameters.
250 & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
251 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
252 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
253 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
254 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
255 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
256 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
258 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
259 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
262 & 3.141592653589793D0, 6.283185307179586D0,
263 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
264 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
265 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
266 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
267 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
268 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
269 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
271 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
272 & 0D0, 0D0, 0D0, 0D0, 0D0,
273 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
274 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
275 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
276 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
277 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
278 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
279 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
280 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
281 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
282 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
284 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
285 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
286 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
287 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
288 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
289 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
291 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
292 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
295 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
296 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
297 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
298 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
299 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0,2.5D0,0.6D0,0D0,
300 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0,
301 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
302 5 -0.00001D0, -0.00001D0, -0.00001D0, 1.0D0, 0D0,
303 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
304 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0, 0D0, 0D0,
305 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0, 0D0,
306 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
307 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
308 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
309 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
310 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
311 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
314 C...PYDAT2, with particle data and flavour treatment parameters.
315 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
316 &-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,
317 &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,
318 &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,
319 &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,
320 &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,
321 &-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,
322 &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,
323 &2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
324 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
325 &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,
326 &-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,
328 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,
329 &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,
330 &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,
331 &3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
332 DATA (KCHG(I,4),I= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
333 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
334 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
335 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
336 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
337 &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
338 &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
339 &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
340 &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
341 &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
342 &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
343 &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
344 &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
345 &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
346 &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
347 &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
348 &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
349 &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
350 &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
351 &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
352 DATA (KCHG(I,4),I= 294, 500)/20443,20513,20523,20533,20543,20553,
353 &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
354 &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
355 &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
356 &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
357 &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
358 DATA (PMAS(I,1),I= 1, 214)/0.0099D0,0.0056D0,0.199D0,1.35D0,
359 &5D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,
360 &400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0,
361 &3*300D0,350D0,200D0,5000D0,10*0D0,3*100D0,3*200D0,26*0D0,1D0,2D0,
362 &5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,0.49767D0,0D0,0.13957D0,
363 &0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,1.275D0,2*0.49767D0,
364 &0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,0D0,0.95777D0,
365 &1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,2.0067D0,2.46D0,
366 &1.9685D0,2.1124D0,2.5735D0,0D0,2.9798D0,3.09688D0,3.5562D0,
367 &5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,5.3693D0,
368 &5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,9.9132D0,
369 &0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,0.93957D0,1.233D0,
370 &0.77133D0,0D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
371 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
372 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
373 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
374 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
375 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
376 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
377 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0/
378 DATA (PMAS(I,1),I= 215, 500)/5.641D0,5.84D0,7.00575D0,5.38897D0,
379 &5.40145D0,5.8D0,5.81D0,5.8D0,5.81D0,5.84D0,7.00575D0,5.56725D0,
380 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
381 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
382 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
383 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
384 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
385 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
386 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
387 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
388 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
389 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
391 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.4D0,16*0D0,2.47833D0,
392 &2.069D0,0.00295D0,6*0D0,14.67788D0,0D0,16.79392D0,8.45231D0,
393 &4.93534D0,5.80468D0,19.1898D0,0.39162D0,417.35283D0,62*0D0,
394 &0.151D0,0.107D0,3*0D0,0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0,
395 &2*0D0,0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0D0,0.0002D0,
396 &0.00443D0,0.076D0,2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0,
397 &0.0013D0,0D0,0.002D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,
398 &2*0D0,0.02D0,4*0D0,0.12D0,4*0D0,0.12D0,3*0D0,2*0.12D0,3*0D0,
399 &0.0394D0,4*0D0,0.036D0,0D0,0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,
400 &74*0D0,0.06D0,0.142D0,0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,
401 &0.287D0,0.09D0,0.25D0,0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,
402 &0D0,0.014D0,0.01D0,8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,
403 &0.053D0,3*0.05D0,0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,
404 &1D0,0D0,1D0,0D0,2.60511D0,2.60839D0,0.42904D0,0.41921D0,163*0D0/
405 DATA (PMAS(I,3),I= 1, 500)/5*0D0,14D0,16*0D0,24.78326D0,
406 &20.69D0,0.02954D0,6*0D0,146.77876D0,0D0,167.93924D0,84.52308D0,
407 &49.35344D0,58.04675D0,191.89803D0,3.91624D0,4173.5283D0,62*0D0,
408 &0.4D0,0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0,
409 &0.12D0,0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
410 &2*0D0,0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,
411 &2*0D0,0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0,
412 &3*0D0,2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,
413 &0.05D0,0D0,0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,
414 &0.4D0,0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,
415 &0.08D0,0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,
416 &2*0.3D0,0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,
417 &3*0D0,19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,
418 &0.00001D0,26.05109D0,26.08388D0,4.29043D0,4.19206D0,163*0D0/
419 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
420 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,0D0,7804.5D0,6*0D0,
421 &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
422 &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*0D0,
423 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
424 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
425 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
426 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,83*0D0,163*0D0/
428 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
429 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
430 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
431 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
432 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
433 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
434 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
435 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
436 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
437 9 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
438 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
439 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
440 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
442 4 0.2D0, 0.5D0, 8*0D0,
444 DATA ((VCKM(I,J),J=1,4),I=1,4)/
445 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
446 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
447 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
448 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
450 C...PYDAT3, with particle decay parameters and data.
451 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
452 &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,
453 &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,
454 &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,
456 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80,
457 &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414,
458 &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0,
459 &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696,
460 &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923,
461 &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095,
462 &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124,
463 &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155,
464 &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248,
465 &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284,
466 &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343,
467 &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419,
468 &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519,
469 &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559,
470 &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584,
471 &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623,
472 &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731,
473 &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0,
474 &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489,
476 DATA (MDCY(I,3),I= 1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3,
477 &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,
478 &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,
479 &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,
480 &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,
481 &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,
482 &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,
483 &9*2,11,14,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0,
485 DATA (MDME(I,1),I= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
486 &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,
487 &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,
488 &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,
489 &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,
491 DATA (MDME(I,2),I= 1,4000)/43*102,4*0,102,0,4*53,3*102,4*0,102,
492 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
493 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,21*0,62*53,8*32,14*0,
494 &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,
495 &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,
496 &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,
497 &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,
498 &6*0,12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,
499 &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,
500 &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,
501 &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,
502 &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,
503 &9*42,0,162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,
504 &4*32,2*4,5*0,828*53,1515*0/
505 DATA (BRAT(I) ,I= 1, 418)/43*0D0,0.00003D0,0.00177D0,0.9982D0,
506 &33*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,0.003D0,
507 &0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,0.0071D0,
508 &0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,0.0034D0,0.08D0,
509 &0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,0.0067D0,0.0005D0,
510 &0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,0.00075D0,0.0001D0,
511 &0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,0.0004D0,0.0001D0,
512 &2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,0.00025D0,35*0D0,
513 &0.15403D0,0.11945D0,0.15402D0,0.11931D0,0.15215D0,3*0D0,
514 &0.03357D0,0.0668D0,0.03357D0,0.0668D0,0.0335D0,0.0668D0,2*0D0,
515 &0.32139D0,0.0165D0,2*0D0,0.0165D0,0.32067D0,2*0D0,0.00001D0,
516 &0.00059D0,6*0D0,2*0.10814D0,0.10806D0,3*0D0,0.00031D0,0.04438D0,
517 &0.88031D0,4*0D0,0.0002D0,0.05531D0,0D0,0.01838D0,0.00071D0,0D0,
518 &0.00009D0,0.00032D0,62*0D0,0.14449D0,0.11223D0,0.14449D0,
519 &0.11223D0,0.14443D0,0.05782D0,2*0D0,0.03172D0,0.06305D0,
520 &0.03172D0,0.06305D0,0.03172D0,0.06305D0,8*0D0,0.24928D0,0.0128D0,
521 &0.00001D0,0D0,0.0128D0,0.24882D0,0.00039D0,0D0,0.00001D0,
522 &0.00046D0,0.22153D0,5*0D0,2*0.08464D0,0.08463D0,7*0D0,0.00005D0,
523 &0.00097D0,5*0D0,0.00007D0,0D0,0.00049D0,0.00001D0,0.00006D0,
524 &0.30591D0,0.68863D0,0D0,0.0038D0,66*0D0,0.00008D0,0.00167D0/
525 DATA (BRAT(I) ,I= 419, 722)/5*0D0,0.00013D0,0D0,0.00294D0,
526 &0.00001D0,3*0D0,0.99517D0,63*0D0,0.00002D0,0.07231D0,2*0D0,
527 &0.00001D0,0.00269D0,0D0,0.92497D0,18*0D0,0.0024D0,0.99483D0,
528 &0.00278D0,1D0,3*0.21511D0,0.21478D0,2*0D0,2*0.06995D0,2*0D0,1D0,
529 &3*0D0,0.95D0,0.05D0,3*0D0,4*0.25D0,16*0D0,4*0.25D0,20*0D0,1D0,
530 &17*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,
531 &0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,0.998739D0,
532 &0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,0.144D0,
533 &0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,
534 &2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,
535 &0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,
536 &0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,
537 &0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,
538 &0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,
539 &2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,
540 &0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,
541 &0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,
542 &0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,
543 &0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,
544 &0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0,0.48947D0/
545 DATA (BRAT(I) ,I= 723, 897)/0.34D0,3*0.043D0,0.027D0,0.0126D0,
546 &0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,
547 &2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,
548 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,
549 &0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,
550 &0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,
551 &0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,
552 &0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,
553 &0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,
554 &0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
555 &0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,
556 &2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,
557 &3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,
558 &0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,
559 &0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,
560 &0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,
561 &0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,
562 &0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,
563 &0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
564 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
565 DATA (BRAT(I) ,I= 898,1063)/0.079D0,0.095D0,0.052D0,0.0078D0,
566 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
567 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
568 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
569 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
570 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
571 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
572 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
573 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
574 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
575 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
576 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
577 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
578 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
579 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
580 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
581 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
582 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
583 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
584 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
585 DATA (BRAT(I) ,I=1064,1254)/0.122D0,0.006D0,0.012D0,0.035D0,
586 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
587 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
588 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
589 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
590 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
591 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
592 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
593 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
594 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
595 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
596 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
597 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
598 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
599 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
600 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
601 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
602 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
603 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
604 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
605 DATA (BRAT(I) ,I=1255,1447)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
606 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
607 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
608 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
609 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
610 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
611 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
612 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
613 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
614 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,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 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
624 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
625 DATA (BRAT(I) ,I=1448,1648)/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,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
632 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
633 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
634 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
635 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
636 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
637 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
638 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
639 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
640 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
641 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
642 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
643 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
644 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
645 DATA (BRAT(I) ,I=1649,4000)/0.008D0,0.024D0,0.425D0,0.02D0,
646 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,827*0D0,0.8516D0,
647 &0.00539D0,0.04483D0,0.09819D0,0.85053D0,0.02152D0,0.02989D0,
648 &0.09806D0,0.29439D0,0.10943D0,0.59618D0,0.38983D0,0.61017D0,
650 DATA (KFDP(I,1),I= 1, 375)/21,22,23,4*-24,25,21,22,23,4*24,25,
651 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
652 &4*24,25,37,1000022,1000023,1000025,1000035,21,22,23,4*-24,25,
653 &2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,22,23,-24,25,
654 &23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,-37,23,24,37,
655 &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,
656 &11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,
657 &3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,2*1000023,
658 &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
659 &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003,
660 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
661 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
662 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
663 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
664 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
665 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
666 &24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,
667 &4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,1000022,2*1000023,
668 &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
669 &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/
670 DATA (KFDP(I,1),I= 376, 606)/1000003,-1000003,1000004,2000004,
671 &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
672 &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
673 &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
674 &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
675 &1000015,-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,
676 &8,11,13,15,17,21,2*22,23,24,23,1000022,2*1000023,3*1000025,
677 &4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,-1000001,
678 &1000002,2000002,1000002,-1000002,1000003,2000003,1000003,
679 &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
680 &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
681 &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
682 &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
683 &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
684 &1000016,-1000016,-1,-3,-5,-7,-11,-13,-15,-17,24,2*1000022,
685 &2*1000023,2*1000025,2*1000035,1000006,2000006,1000006,2000006,
686 &-1000001,-1000003,-1000011,-1000013,-1000015,-2000015,5,6,21,2,1,
687 &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,
688 &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,
689 &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/
690 DATA (KFDP(I,1),I= 607,1001)/-11,-13,2*2,-12,-14,-16,2*-2,2*-4,
691 &-2,-4,2*22,211,111,221,13,11,213,-213,221,223,321,130,310,111,
692 &331,111,211,-12,12,-14,14,211,111,22,-13,-11,2*211,213,113,221,
693 &223,321,211,331,22,111,211,2*22,211,22,111,211,22,211,221,111,11,
694 &211,111,2*211,321,130,310,221,111,211,111,130,310,321,2*311,321,
695 &311,323,313,323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,
696 &313,323,313,323,311,4*321,211,111,3*22,111,321,130,-213,113,213,
697 &211,22,111,11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,
698 &-313,-311,-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,
699 &2*113,2*223,2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,
700 &-321,211,2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,
701 &423,413,421,411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
702 &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
703 &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
704 &-321,3*-311,211,113,321,2*421,411,421,413,423,413,423,411,421,
705 &-15,5*-11,5*-13,221,331,333,221,331,333,10221,211,213,211,213,
706 &321,323,321,323,2212,221,331,333,221,2*2,2*431,421,411,423,413,
707 &82,11,13,82,443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,
708 &2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,
709 &511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443/
710 DATA (KFDP(I,1),I=1002,1428)/2*20443,2*2,2*4,2,4,521,511,521,513,
711 &523,513,523,511,521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,
712 &3*441,3*443,3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,
713 &2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,
714 &521,513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,
715 &2212,2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,
716 &3222,3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,
717 &3322,3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,
718 &7*-13,2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,
719 &2*3322,3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,
720 &2*3214,2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,
721 &2*2,3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,
722 &-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,
723 &-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,
724 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,
725 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,
726 &-14,-16,2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,
727 &-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
728 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
729 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12/
730 DATA (KFDP(I,1),I=1429,1710)/-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
731 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
732 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
733 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
734 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
735 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
736 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
737 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
738 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
739 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
740 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
741 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
742 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
743 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
744 &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
745 &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
746 &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
747 &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024,
748 &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003,
749 &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/
750 DATA (KFDP(I,1),I=1711,1900)/1000025,1000035,1000006,2000006,
751 &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023,
752 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
753 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
754 &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022,
755 &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039,
756 &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014,
757 &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023,
758 &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024,
759 &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016,
760 &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
761 &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001,
762 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
763 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
764 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
765 &6*1000022,6*1000023,6*1000025,6*1000035,1000024,-1000024,1000024,
766 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
767 &1000037,-1000037,10*1000039,16*1000022,1000024,-1000024,1000024,
768 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
769 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/
770 DATA (KFDP(I,1),I=1901,2095)/-1000037,1000037,-1000037,1000037,
771 &-1000037,1000037,-1000037,1000024,-1000024,1000037,-1000037,
772 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
773 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
774 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
775 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
776 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
777 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
778 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
779 &2*1000039,6*1000022,6*1000023,6*1000025,6*1000035,1000022,
780 &1000023,1000025,1000035,1000002,2000002,-1000001,-2000001,
781 &1000004,2000004,-1000003,-2000003,1000006,2000006,-1000005,
782 &-2000005,1000012,2000012,-1000011,-2000011,1000014,2000014,
783 &-1000013,-2000013,1000016,2000016,-1000015,-2000015,2*1000021,
784 &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
785 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
786 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
787 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
788 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
789 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/
790 DATA (KFDP(I,1),I=2096,2323)/2000003,-2000003,1000004,-1000004,
791 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
792 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
793 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
794 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
795 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
796 &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
797 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
798 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
799 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
800 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
801 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
802 &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
803 &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
804 &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
805 &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
806 &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
807 &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
808 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
809 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/
810 DATA (KFDP(I,1),I=2324,4000)/-1000003,-2000003,1000006,2000006,
811 &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014,
812 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
813 &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
814 &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021,
815 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
816 &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039,
817 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
818 &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037,
819 &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003,
820 &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022,
821 &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006,
822 &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
823 &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021,
824 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
825 &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024,
826 &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014,
827 &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022,
828 &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016,
829 &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/
830 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,
831 &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,
832 &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,
833 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
834 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
835 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
836 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
837 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
838 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
839 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
840 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
841 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
842 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
843 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
844 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
845 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
846 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
847 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
848 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
849 &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/
850 DATA (KFDP(I,2),I= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23,
851 &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
852 &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
853 &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
854 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
855 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
856 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
857 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
858 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
859 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
860 &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
861 &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
862 &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
863 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
864 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
865 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
866 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
867 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
868 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
869 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
870 DATA (KFDP(I,2),I= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5,
871 &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7,
872 &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2,
873 &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
874 &-13,-14,-15,-16,-17,-18,-82,12,14,-1,-3,11,13,15,1,4,3,4,1,3,22,
875 &11,-211,2*22,-13,-11,-211,211,111,211,-321,130,310,22,2*111,-211,
876 &11,-11,13,-13,-211,111,22,14,12,111,22,111,3*211,-311,22,211,22,
877 &111,-211,211,11,-211,13,22,-211,111,-211,22,111,-11,-211,111,
878 &2*-211,-321,130,310,221,111,-211,111,2*0,-211,111,22,-211,111,
879 &-211,111,-211,211,-213,113,223,221,14,111,211,111,-11,-13,211,
880 &111,22,211,111,211,111,2*211,213,113,223,221,22,-211,111,113,223,
881 &22,111,-321,310,211,111,2*-211,221,22,-11,-13,-211,-321,130,310,
882 &221,-211,111,11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,
883 &213,211,213,211,213,211,213,211,213,211,213,3*211,213,211,2*321,
884 &8*211,2*113,3*211,111,22,211,111,211,111,4*211,8*12,8*14,2*211,
885 &2*213,2*111,221,2*113,223,333,20213,211,2*321,323,2*311,313,-211,
886 &111,113,2*211,321,2*211,311,321,310,211,-211,4*211,321,4*211,113,
887 &2*211,-321,111,22,-211,111,-211,111,-211,211,-211,211,16,5*12,
888 &5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,
889 &2*-1,22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13/
890 DATA (KFDP(I,2),I= 941,1318)/2*-15,211,213,20213,211,213,20213,
891 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
892 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
893 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1,
894 &-4,-3,-4,-1,-3,22,211,111,211,111,4*211,6*-11,6*-13,2*-15,211,
895 &213,20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,
896 &221,331,333,-1,-4,-3,-4,-1,-3,22,-321,-311,-321,-311,-15,-3,-1,
897 &2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,
898 &2*14,2,1,22,411,421,411,421,21,-11,-13,-15,-1,-2,-3,-4,2*21,22,
899 &21,2*-211,111,22,111,211,22,211,-211,11,2*-211,111,-211,111,22,
900 &11,22,111,-211,211,111,211,22,211,111,211,-211,22,11,13,11,-211,
901 &2*111,2*22,111,211,-321,-211,111,11,2*-211,7*12,7*14,-321,-323,
902 &-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,223,
903 &111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,333,
904 &10221,111,221,331,113,223,211,213,211,213,321,323,321,323,321,
905 &323,311,313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,12,
906 &14,-1,-3,2*111,2*211,12,14,-1,-3,22,111,2*22,111,22,12,14,-1,-3,
907 &22,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,
908 &12,14,-1,-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,
909 &-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/
910 DATA (KFDP(I,2),I=1319,1774)/3,2*111,2*211,11,13,15,1,4,3,4,1,3,
911 &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,
912 &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,
913 &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,
914 &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,
915 &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,
916 &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,
917 &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,-211,111,
918 &-321,130,310,-211,111,211,-211,111,-213,113,-211,111,223,211,111,
919 &213,113,211,111,223,-211,111,-321,130,310,2*-211,-311,311,-321,
920 &321,211,111,211,111,-211,111,-211,111,311,2*321,311,22,2*-82,
921 &-211,111,-211,111,211,111,211,111,-321,-311,-321,-311,411,421,
922 &411,421,22,2*21,-211,2*211,111,-211,111,2*211,111,-211,211,111,
923 &211,-321,2*-311,-321,22,-211,111,211,111,-311,311,-321,321,211,
924 &111,-211,111,321,311,22,-82,-211,111,211,111,-321,-311,411,421,
925 &22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
926 &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,
927 &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,
928 &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,
929 &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/
930 DATA (KFDP(I,2),I=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15,
931 &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,
932 &-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,
933 &-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,35,36,22,23,25,35,36,22,23,
934 &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
935 &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
936 &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,
937 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
938 &-16,16,-16,16,1,3,5,2,4,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,
939 &-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,
940 &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,
941 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
942 &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
943 &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
944 &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
945 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
946 &-16,16,-16,16,1,3,5,2,4,22,23,25,35,36,22,23,11,13,15,12,14,16,1,
947 &3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,
948 &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,
949 &-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37/
950 DATA (KFDP(I,2),I=2219,4000)/37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
951 &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
952 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
953 &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,-13,-15,-1,-3,24,
954 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
955 &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,
956 &-3,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36,
957 &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,
958 &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,
959 &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13,
960 &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24,
961 &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/
962 DATA (KFDP(I,3),I= 1,1087)/79*0,14,6*0,2*16,2*0,6*111,310,130,
963 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
964 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
965 &470*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
966 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
967 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
968 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
969 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
970 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
971 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
972 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
973 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
974 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
975 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
976 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
977 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
978 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
979 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
980 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
981 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
982 DATA (KFDP(I,3),I=1088,2186)/511,513,511,513,1,2,13*0,2*21,11*0,
983 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
984 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
985 &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,
986 &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,
987 &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,
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,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,
990 &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,
991 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
992 &-211,111,13*0,2*21,-211,111,167*0,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,
993 &-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,6,-2,2,-4,
994 &4,-6,6,12*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
995 &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
996 &-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,
997 &12,14,16,2,4,28*0,2,4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
998 &5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,
999 &16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,
1000 &-4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,
1001 &-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5/
1002 DATA (KFDP(I,3),I=2187,4000)/-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,
1003 &-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,
1004 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,4*0,12,14,16,2,4,0,12,14,
1005 &16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,1657*0/
1006 DATA (KFDP(I,4),I= 1,4000)/92*0,4*111,6*0,111,2*0,-211,0,-211,
1007 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1008 &6*111,310,2*130,470*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1009 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1010 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1011 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1012 &-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,
1013 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1014 &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,
1015 &162*81,31*0,-211,111,2450*0/
1016 DATA (KFDP(I,5),I= 1,4000)/94*0,2*111,17*0,111,7*0,2*111,0,
1017 &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1018 &3*111,-211,111,3127*0/
1020 C...PYDAT4, with particle names (character strings).
1021 DATA (CHAF(I,1),I= 1, 190)/'d','u','s','c','b','t','b''','t''',
1022 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1023 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1024 &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1025 &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1026 &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav',
1027 &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster',
1028 &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
1029 &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0',
1030 &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2',
1031 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''',
1032 &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+',
1033 &'D*_s+','D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0',
1034 &'B*_20','B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+',
1035 &'B*_c+','B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-',
1036 &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+',
1037 &'Delta+','Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0',
1038 &'su_0','su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-',
1039 &'Xi*-','Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0',
1040 &'Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1','Sigma_c+'/
1041 DATA (CHAF(I,1),I= 191, 317)/'Sigma*_c+','Sigma_c++',
1042 &'Sigma*_c++','Xi_c+','cs_0','cs_1','Xi''_c0','Xi*_c0','Xi''_c+',
1043 &'Xi*_c+','Omega_c0','Omega*_c0','cc_1','Xi_cc+','Xi*_cc+',
1044 &'Xi_cc++','Xi*_cc++','Omega_cc+','Omega*_cc+','Omega*_ccc++',
1045 &'bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0','Xi_b-',
1046 &'Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1047 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1048 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1049 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1050 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1051 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1052 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1053 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1054 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1055 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1056 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1057 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1058 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1059 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1060 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+'/
1061 DATA (CHAF(I,1),I= 318, 500)/'~chi_30','~chi_40','~chi_2+',
1062 &'~gravitino','~d_R','~u_R','~s_R','~c_R','~b_2','~t_2','~e_R-',
1063 &'~nu_eR','~mu_R-','~nu_muR','~tau_2-','~nu_tauR','d*','u*','e*-',
1065 DATA (CHAF(I,2),I= 1, 206)/'dbar','ubar','sbar','cbar','bbar',
1066 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1067 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1068 &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1069 &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar',
1070 &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0',
1071 &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0',
1072 &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0',
1073 &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0',
1074 &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+',
1075 &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar',
1076 &'p_diffrbar-','pbar-','Deltabar-','Deltabar--','sd_0bar',
1077 &'sd_1bar','Sigmabar+','Sigma*bar+','Lambdabar0','su_0bar',
1078 &'su_1bar','Sigmabar0','Sigma*bar0','Sigmabar-','Sigma*bar-',
1079 &'ss_1bar','Xibar+','Xi*bar+','Xibar0','Xi*bar0','Omegabar+',
1080 &'cd_0bar','cd_1bar','Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-',
1081 &'Xi_cbar0','cu_0bar','cu_1bar','Sigma_cbar-','Sigma*_cbar-',
1082 &'Sigma_cbar--','Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar',
1083 &'Xi''_cbar0','Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1084 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--'/
1085 DATA (CHAF(I,2),I= 207, 324)/'Xi*_ccbar--','Omega_ccbar-',
1086 &'Omega*_ccbar-','Omega*_cccbar-','bd_0bar','bd_1bar',
1087 &'Sigma_bbar+','Sigma*_bbar+','Lambda_bbar0','Xi_bbar+',
1088 &'Xi_bcbar0','bu_0bar','bu_1bar','Sigma_bbar0','Sigma*_bbar0',
1089 &'Sigma_bbar-','Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar',
1090 &'bs_1bar','Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0',
1091 &'Omega_bbar+','Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar',
1092 &'Xi''_bcbar0','Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-',
1093 &'Omega''_bcba','Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-',
1094 &'bb_1bar','Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0',
1095 &'Omega_bbbar+','Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1096 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1097 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1098 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1099 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1100 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1101 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1102 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1103 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1104 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar'/
1105 DATA (CHAF(I,2),I= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar',
1106 &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1107 &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1109 C...PYDATR, with initial values for the random number generator.
1110 DATA MRPY/19780503,0,0,97,33,0/
1112 C...Default values for allowed processes and kinematics constraints.
1115 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1116 &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,
1119 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1120 & 1.0D0, -10D0, 10D0, -10D0, 10D0,
1121 1 -10D0, 10D0, -10D0, 10D0, -10D0,
1122 1 10D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1123 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1124 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1125 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1126 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1127 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1128 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1129 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1130 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1133 C...Default values for main switches and parameters. Reset information.
1134 DATA (MSTP(I),I=1,100)/
1135 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1136 1 1, 0, 1, 0, 5, 0, 0, 0, 0, 0,
1137 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1138 3 1, 2, 0, 1, 0, 2, 1, 5, 2, 0,
1139 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1140 5 4, 1, 3, 1, 5, 1, 1, 6, 1, 7,
1141 6 1, 3, 2, 2, 1, 1, 2, 0, 0, 0,
1142 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1143 8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
1144 9 1, 4, 1, 2, 0, 0, 0, 0, 0, 0/
1145 DATA (MSTP(I),I=101,200)/
1146 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1147 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1148 2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
1149 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1150 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1151 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1152 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1153 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1154 8 6, 115, 1998, 01, 27, 0, 0, 0, 0, 0,
1155 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1156 DATA (PARP(I),I=1,100)/
1157 & 0.25D0, 10D0, 8*0D0,
1158 1 0D0, 0D0, 1.0D0, 0.01D0, 0.6D0, 1.0D0, 1.0D0, 3*0D0,
1160 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1161 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
1163 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1164 7 4.0D0, 0.25D0, 8*0D0,
1165 8 1.40D0,1.55D0,0.5D0, 0.2D0,0.33D0,0.66D0, 0.7D0, 0.5D0,2*0D0,
1166 9 0.44D0,0.20D0,2.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,0.44D0,2.0D0/
1167 DATA (PARP(I),I=101,200)/
1168 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 6*0D0,
1169 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1170 2 1.0D0, 0.4D0, 8*0D0,
1172 4 0.33333D0, 82D0, 1D0, 4D0, 200D0, 5*0D0,
1173 5 0D0, 0D0, 0D0, 0D0, 6*0D0,
1174 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 6*0D0,
1175 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1182 C...Constants for the generation of the various processes.
1183 DATA (ISET(I),I=1,100)/
1184 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1185 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1186 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1187 3 2, -1, 2, 2, 2, 2, -1, -1, -1, -1,
1188 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1189 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1190 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1191 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1192 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1193 9 0, 0, 0, 0, 0, 9, -2, -2, -2, -2/
1194 DATA (ISET(I),I=101,200)/
1195 & -1, 1, 1, -2, -2, 2, 2, 2, -2, 2,
1196 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1197 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1198 3 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1199 4 1, 1, 1, 1, 1, -2, 1, 1, 1, -2,
1200 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1201 6 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1202 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1203 8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
1204 9 1, 1, 1, 2, -2, -2, -2, -2, -2, -2/
1205 DATA (ISET(I),I=201,300)/
1206 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1207 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1208 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1209 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1210 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1211 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1212 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1213 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1214 8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1215 9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
1216 DATA (ISET(I),I=301,500)/200*-2/
1217 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1218 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1219 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1220 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1221 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1222 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1223 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1224 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1225 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1226 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1227 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1228 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1229 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1230 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1231 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1232 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1233 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1234 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1235 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1236 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1237 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1238 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1239 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1240 & 23, 0, 25, 0, 25, 0, 0, 0, 0, 0,
1241 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1242 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1243 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1244 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1245 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1246 3 23, 5, 0, 0, 0, 0, 0, 0, 0, 0,
1247 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1248 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
1249 4 0, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
1250 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1251 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1252 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1253 6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
1254 6 11, 0, 0, 4000001, 0, 4000002, 0, 0, 0, 0,
1255 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1256 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1257 8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
1258 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
1259 9 54, 0, 55, 0, 56, 0, 11, 0, 0, 0,
1260 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1261 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1262 & 1000011, 1000011, 2000011, 2000011, 1000011,
1263 & 2000011, 1000013, 1000013, 2000013, 2000013,
1264 & 1000013, 2000013, 1000015, 1000015, 2000015,
1265 & 2000015, 1000015, 2000015, 1000011, 1000012,
1266 1 1000015, 1000016, 2000015, 1000016, 1000012,
1267 1 1000012, 1000016, 1000016, 0, 0,
1268 1 1000022, 1000022, 1000023, 1000023, 1000025,
1269 1 1000025, 1000035, 1000035, 1000022, 1000023,
1270 2 1000022, 1000025, 1000022, 1000035, 1000023,
1271 2 1000025, 1000023, 1000035, 1000025, 1000035,
1272 2 1000024, 1000024, 1000037, 1000037, 1000024,
1273 2 1000037, 1000022, 1000024, 1000023, 1000024,
1274 3 1000025, 1000024, 1000035, 1000024, 1000022,
1275 3 1000037, 1000023, 1000037, 1000025, 1000037,
1276 3 1000035, 1000037, 1000021, 1000022, 1000021,
1277 3 1000023, 1000021, 1000025, 1000021, 1000035/
1278 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1279 4 1000021, 1000024, 1000021, 1000037, 1000021,
1280 4 1000021, 1000021, 1000021, 0, 0,
1281 4 1000002, 1000022, 2000002, 1000022, 1000002,
1282 4 1000023, 2000002, 1000023, 1000002, 1000025,
1283 5 2000002, 1000025, 1000002, 1000035, 2000002,
1284 5 1000035, 1000001, 1000024, 2000005, 1000024,
1285 5 1000001, 1000037, 2000005, 1000037, 1000002,
1286 5 1000021, 2000002, 1000021, 0, 0,
1287 6 1000006, 1000006, 2000006, 2000006, 1000006,
1288 6 2000006, 1000006, 1000006, 2000006, 2000006,
1291 7 1000002, 1000002, 2000002, 2000002, 1000002,
1292 7 2000002, 1000002, 1000002, 2000002, 2000002,
1293 7 1000002, 2000002, 1000002, 1000002, 2000002,
1294 7 2000002, 1000002, 1000002, 2000002, 2000002/
1295 DATA ((KFPR(I,J),J=1,2),I=281,500)/440*0/
1296 DATA COEF/10000*0D0/
1297 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1298 &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,
1299 &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,
1300 &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,
1301 &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,
1302 &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,
1303 &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,
1304 &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,
1305 &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,
1306 &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,
1307 &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/
1309 C...Treatment of resonances.
1310 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1311 &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1313 C...Character constants: name of processes.
1314 DATA PROC(0)/ 'All included subprocesses '/
1315 DATA (PROC(I),I=1,20)/
1316 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1317 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1318 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1319 &' ', 'W+ + W- -> h0 ',
1320 &' ', 'f + f'' -> f + f'' (QFD) ',
1321 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1322 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1323 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1324 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1325 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1326 DATA (PROC(I),I=21,40)/
1327 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1328 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1329 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1330 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1331 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1332 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1333 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1334 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1335 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1336 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1337 DATA (PROC(I),I=41,60)/
1338 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1339 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1340 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1341 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1342 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1343 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1344 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1345 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1346 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1347 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1348 DATA (PROC(I),I=61,80)/
1349 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1350 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1351 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1352 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1353 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1354 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1355 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1356 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1357 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1358 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1359 DATA (PROC(I),I=81,100)/
1360 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1361 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1362 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1363 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1364 8'g + g -> chi_2c + g ', ' ',
1365 9'Elastic scattering ', 'Single diffractive (XB) ',
1366 9'Single diffractive (AX) ', 'Double diffractive ',
1367 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1370 DATA (PROC(I),I=101,120)/
1371 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1372 &'gamma + gamma -> h0 ', ' ',
1373 &' ', 'g + g -> J/Psi + gamma ',
1374 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1375 &' ', 'f + fbar -> gamma + h0 ',
1376 1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
1377 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1378 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1379 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1381 DATA (PROC(I),I=121,140)/
1382 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1383 2'f + f'' -> f + f'' + h0 ',
1384 2'f + f'' -> f" + f"'' + h0 ',
1388 3'g + g -> Z0 + q + qbar ', ' ',
1393 DATA (PROC(I),I=141,160)/
1394 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1395 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1396 4'q + l -> LQ ', ' ',
1397 4'd + g -> d* ', 'u + g -> u* ',
1398 4'g + g -> eta_techni ', ' ',
1399 5'f + fbar -> H0 ', 'g + g -> H0 ',
1400 5'gamma + gamma -> H0 ', ' ',
1401 5' ', 'f + fbar -> A0 ',
1402 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1404 DATA (PROC(I),I=161,180)/
1405 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1406 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1407 6'f + fbar -> f'' + fbar'' (g/Z)',
1408 6'f +fbar'' -> f" + fbar"'' (W) ',
1409 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1411 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1412 7'f + f'' -> f + f'' + H0 ',
1413 7'f + f'' -> f" + f"'' + H0 ',
1414 7' ', 'f + fbar -> Z0 + A0 ',
1415 7'f + fbar'' -> W+/- + A0 ',
1416 7'f + f'' -> f + f'' + A0 ',
1417 7'f + f'' -> f" + f"'' + A0 ',
1419 DATA (PROC(I),I=181,200)/
1420 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1422 8' ', 'g + g -> Q + Qbar + A0 ',
1423 8'q + qbar -> Q + Qbar + A0 ', ' ',
1425 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
1426 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (technic)',
1430 DATA (PROC(I),I=201,220)/
1431 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1432 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1433 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1434 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1435 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1436 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1437 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1438 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1439 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1440 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1441 DATA (PROC(I),I=221,240)/
1442 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1443 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1444 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1445 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1446 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1447 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1448 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1449 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1450 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1451 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1452 DATA (PROC(I),I=241,260)/
1453 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1454 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1455 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1456 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1457 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1458 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1459 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1460 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1461 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1462 5'qj + g -> ~qj_R + ~g ', ' '/
1463 DATA (PROC(I),I=261,280)/
1464 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1465 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1466 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1469 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1470 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1471 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1472 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1473 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar '/
1474 DATA (PROC(I),I=281,500)/220*' '/
1476 C...Cross sections and slope offsets.
1479 C...Supersymmetry switches and parameters.
1481 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1484 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1485 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1486 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,24D17,2*0D0,
1489 C...Data for histogramming routines.
1490 DATA IHIST/1000,20000,55,1/
1495 C*********************************************************************
1497 *$ CREATE PYTEST.FOR
1500 C...A simple program (disguised as subroutine) to run at installation
1501 C...as a check that the program works as intended.
1503 SUBROUTINE PYTEST(MTEST)
1505 C...Double precision and integer declarations.
1506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1507 INTEGER PYK,PYCHGE,PYCOMP
1509 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1510 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1511 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1512 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
1513 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1514 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1515 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1517 DIMENSION PSUM(5),PINI(6),PFIN(6)
1519 C...Save defaults for values that are changed.
1536 C...First part: loop over simple events to be generated.
1537 IF(MTEST.GE.1) CALL PYTABU(20)
1541 C...Reset parameter values. Switch on some nonstandard features.
1556 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1558 C...Ten events each for some single jets configurations.
1562 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1563 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1564 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1565 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1566 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1567 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1569 C...Ten events each for some simple jet systems; string fragmentation.
1570 ELSEIF(IEV.LE.130) THEN
1572 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1573 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1574 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1575 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1576 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1577 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1578 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1579 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1580 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1582 C...Seventy events with independent fragmentation and momentum cons.
1583 ELSEIF(IEV.LE.200) THEN
1585 MSTJ(2)=1+MOD(IEV-131,4)
1586 MSTJ(3)=1+MOD((IEV-131)/4,4)
1587 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1588 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1589 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1590 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1591 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1592 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1594 C...A hundred events with random jets (check invariant mass).
1595 ELSEIF(IEV.LE.300) THEN
1602 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1603 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1604 EJET=5D0+20D0*PYR(0)
1605 THETA=ACOS(2D0*PYR(0)-1D0)
1607 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1608 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1609 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1610 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1612 PSUM(J)=PSUM(J)+P(I,J)
1615 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
1616 & (PSUM(5)+PARJ(32))**2) GOTO 100
1618 C...Fifty e+e- continuum events with matrix elements.
1619 ELSEIF(IEV.LE.350) THEN
1623 C...Fifty e+e- continuum event with varying shower options.
1624 ELSEIF(IEV.LE.400) THEN
1625 MSTJ(42)=1+MOD(IEV,2)
1626 MSTJ(43)=1+MOD(IEV/2,4)
1627 MSTJ(44)=MOD(IEV/8,3)
1630 C...Fifty e+e- continuum events with coherent shower.
1631 ELSEIF(IEV.LE.450) THEN
1632 CALL PYEEVT(0,500D0)
1634 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1636 CALL PYONIA(5,9.46D0)
1639 C...Generate event. Find total momentum, energy and charge.
1650 C...Check conservation of energy, momentum and charge;
1651 C...usually exact, but only approximate for single jets.
1654 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4D0)
1656 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
1657 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
1658 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
1661 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
1663 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
1665 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1666 & (PFIN(J),J=1,4),PFIN(6)
1668 C...Check that all KF codes are known ones, and that partons/particles
1669 C...satisfy energy-momentum-mass relation. Store particle statistics.
1671 IF(K(I,1).GT.20) GOTO 170
1672 IF(PYCOMP(K(I,2)).EQ.0) THEN
1673 WRITE(MSTU(11),5100) I
1676 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
1677 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
1679 WRITE(MSTU(11),5200) I
1683 IF(MTEST.GE.1) CALL PYTABU(21)
1685 C...List all erroneous events and some normal ones.
1686 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
1687 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1689 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
1693 C...Stop execution if too many errors.
1694 IF(MERR.NE.0) NERR=NERR+1
1696 WRITE(MSTU(11),6300)
1702 C...Summarize result of run.
1703 IF(MTEST.GE.1) CALL PYTABU(22)
1705 C...Reset commonblock variables changed during run.
1722 C...Second part: complete events of various kinds.
1723 C...Common initial values. Loop over initiating conditions.
1724 MSTP(122)=MAX(0,MIN(2,MTEST))
1725 MDCY(PYCOMP(111),1)=0
1728 C...Reset process type, kinematics cuts, and the flags used.
1745 C...Prompt photon production at fixed target.
1748 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
1752 CALL PYINIT('FIXT','pi+','p',PZSUM)
1754 C...QCD processes at ISR energies.
1755 ELSEIF(IPROC.EQ.2) THEN
1761 CALL PYINIT('CMS','p','p',PESUM)
1763 C...W production + multiple interactions at CERN Collider.
1764 ELSEIF(IPROC.EQ.3) THEN
1773 CALL PYINIT('CMS','p','pbar',PESUM)
1775 C...W/Z gauge boson pairs + pileup events at the Tevatron.
1776 ELSEIF(IPROC.EQ.4) THEN
1788 CALL PYINIT('CMS','p','pbar',PESUM)
1790 C...Higgs production at LHC.
1791 ELSEIF(IPROC.EQ.5) THEN
1803 CALL PYINIT('CMS','p','p',PESUM)
1805 C...Z' production at SSC.
1806 ELSEIF(IPROC.EQ.6) THEN
1815 CALL PYINIT('CMS','p','p',PESUM)
1817 C...W pair production at 1 TeV e+e- collider.
1818 ELSEIF(IPROC.EQ.7) THEN
1825 CALL PYINIT('CMS','e+','e-',PESUM)
1827 C...Deep inelastic scattering at a LEP+LHC ep collider.
1828 ELSEIF(IPROC.EQ.8) THEN
1841 CALL PYINIT('USER','p','e-',PESUM)
1844 C...Generate 20 events of each required type.
1848 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
1850 C...Check conservation of energy/momentum/flavour.
1861 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
1862 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
1863 DEVQ=ABS(PFIN(6)-PINI(6))
1864 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
1865 & DEVQ.GT.0.1D0) MERR=1
1866 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1867 & (PFIN(J),J=1,4),PFIN(6)
1869 C...Check that all KF codes are known ones, and that partons/particles
1870 C...satisfy energy-momentum-mass relation.
1872 IF(K(I,1).GT.20) GOTO 210
1873 IF(PYCOMP(K(I,2)).EQ.0) THEN
1874 WRITE(MSTU(11),5100) I
1877 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
1879 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
1880 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
1881 WRITE(MSTU(11),5200) I
1886 C...Listing of erroneous events, and first event of each type.
1887 IF(MERR.GE.1) NERR=NERR+1
1889 WRITE(MSTU(11),6300)
1893 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
1894 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1899 C...List statistics for each process type.
1900 IF(MTEST.GE.1) CALL PYSTAT(1)
1903 C...Summarize result of run.
1904 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
1905 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
1907 C...Format statements for output.
1908 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
1909 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
1910 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
1911 &4(1X,F12.5),1X,F8.2)
1912 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
1913 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
1915 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
1916 &'wrong.'/5X,'Execution will be stopped after listing of event.')
1917 6400 FORMAT(5X,'Faulty event follows:')
1918 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
1919 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
1920 &5X,'This should not have happened!')
1925 C*********************************************************************
1927 *$ CREATE PYHEPC.FOR
1930 C...Converts PYTHIA event record contents to or from
1931 C...the standard event record commonblock.
1933 SUBROUTINE PYHEPC(MCONV)
1935 C...Double precision and integer declarations.
1936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1937 INTEGER PYK,PYCHGE,PYCOMP
1939 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1940 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1941 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1942 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
1943 C...HEPEVT commonblock.
1944 PARAMETER (NMXHEP=4000)
1945 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
1946 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
1947 DOUBLE PRECISION PHEP,VHEP
1950 C...Conversion from PYTHIA to standard, the easy part.
1953 IF(N.GT.NMXHEP) CALL PYERRM(8,
1954 & '(PYHEPC:) no more space in /HEPEVT/')
1958 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
1959 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
1960 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
1961 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
1965 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
1979 C...Check if new event (from pileup).
1983 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
1986 C...Fill in missing mother information.
1987 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
1989 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
1993 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
1996 IF(I1.GE.I) CALL PYERRM(8,
1997 & '(PYHEPC:) translation of inconsistent event history')
1998 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
2000 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
2001 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
2003 ELSEIF(K(I,2).EQ.94) THEN
2005 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2006 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2007 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2008 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2009 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2012 C...Fill in missing daughter information.
2013 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2014 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2015 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2019 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2021 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2022 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2023 IF(JDAHEP(1,I1).EQ.0) THEN
2030 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2031 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2034 C...Conversion from standard to PYTHIA, the easy part.
2036 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2037 & '(PYHEPC:) no more space in /PYJETS/')
2043 IF(ISTHEP(I).EQ.1) K(I,1)=1
2044 IF(ISTHEP(I).EQ.2) K(I,1)=11
2045 IF(ISTHEP(I).EQ.3) K(I,1)=21
2057 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2059 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2060 & PHEP(5,I)/PHEP(4,I)
2063 C...Fill in missing information on colour connection in jet systems.
2064 IF(ISTHEP(I).EQ.1) THEN
2067 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2068 IF(KQ.NE.0) NKQ=NKQ+1
2069 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2070 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2072 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2073 IF(K(I+1,2).EQ.21) K(I,1)=2
2077 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2078 & '(PYHEPC:) input parton configuration not colour singlet')
2083 C*********************************************************************
2085 *$ CREATE PYINIT.FOR
2088 C...Initializes the generation procedure; finds maxima of the
2089 C...differential cross-sections to be used for weighting.
2091 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2093 C...Double precision and integer declarations.
2094 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2095 INTEGER PYK,PYCHGE,PYCOMP
2097 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2098 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2099 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2100 COMMON/PYDAT4/CHAF(500,2)
2102 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2103 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2104 COMMON/PYINT1/MINT(400),VINT(400)
2105 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2106 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2107 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2108 &/PYINT1/,/PYINT2/,/PYINT5/
2109 C...Local arrays and character variables.
2110 DIMENSION ALAMIN(20),NFIN(20)
2111 CHARACTER*(*) FRAME,BEAM,TARGET
2112 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHLH(2)*6
2114 C...Interface to PDFLIB.
2115 COMMON/W50512/QCDL4,QCDL5
2117 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2118 CHARACTER*20 PARM(20)
2119 DATA VALUE/20*0D0/,PARM/20*' '/
2121 C...Data:Lambda and n_f values for parton distributions; months.
2122 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2123 &14*0.2D0/,NFIN/20*4/
2124 DATA CHLH/'lepton','hadron'/
2126 C...Reset MINT and VINT arrays. Write headers.
2131 IF(MSTU(12).GE.1) CALL PYLIST(0)
2132 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2134 C...Maximum 4 generations; set maximum number of allowed flavours.
2135 MSTP(1)=MIN(4,MSTP(1))
2136 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2137 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2139 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2143 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2146 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2147 IPM=(5-ISIGN(1,I))/2
2149 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2150 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2152 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2157 C...Initialize parton distributions: PDFLIB.
2158 IF(MSTP(52).EQ.2) THEN
2162 VALUE(2)=MSTP(51)/1000
2164 VALUE(3)=MOD(MSTP(51),1000)
2167 CALL PDFSET(PARM,VALUE)
2168 MINT(93)=1000000+MSTP(51)
2171 C...Choose Lambda value to use in alpha-strong.
2173 IF(MSTP(3).GE.2) THEN
2176 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.10) THEN
2177 ALAM=ALAMIN(MSTP(51))
2179 ELSEIF(MSTP(52).EQ.2) THEN
2188 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2191 C...Initialize the SUSY generation: couplings, masses,
2192 C...decay modes, branching ratios, and so on.
2195 C...Initialize widths and partial widths for resonances.
2197 C...Set Z0 mass and width for e+e- routines.
2198 PARJ(123)=PMAS(23,1)
2199 PARJ(124)=PMAS(23,2)
2201 C...Identify beam and target particles and frame of process.
2205 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2206 IF(MINT(65).EQ.1) GOTO 170
2208 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2209 C...For e-gamma allow 2 alternatives.
2212 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2213 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2214 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2215 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2216 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2217 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2220 C...Set up kinematics of process.
2223 C...Precalculate flavour selection weights
2226 C...Loop over gamma-p or gamma-gamma alternatives.
2227 DO 160 IGA=1,MINT(121)
2230 C...Select partonic subprocesses to be included in the simulation.
2233 C...Count number of subprocesses on.
2236 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2237 & MSUB(ISUB).EQ.1) THEN
2238 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2240 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2241 WRITE(MSTU(11),5300) ISUB
2243 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2244 WRITE(MSTU(11),5400) ISUB
2246 ELSEIF(MSUB(ISUB).EQ.1) THEN
2250 IF(MINT(48).EQ.0) THEN
2251 WRITE(MSTU(11),5500)
2254 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2256 C...Reset variables for cross-section calculation.
2264 C...Find parametrized total cross-sections.
2267 C...Maxima of differential cross-sections.
2268 IF(MSTP(121).LE.1) CALL PYMAXI
2270 C...Initialize possibility of pileup events.
2271 IF(MINT(121).GT.1) MSTP(131)=0
2272 IF(MSTP(131).NE.0) CALL PYPILE(1)
2274 C...Initialize multiple interactions with variable impact parameter.
2275 IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2276 & MSTP(82).GE.2) CALL PYMULT(1)
2278 C...Save results for gamma-p and gamma-gamma alternatives.
2279 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2282 C...Initialization finished.
2283 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2285 C...Formats for initialization information.
2286 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2287 &'routines',1X,17('*'))
2288 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2289 &'-',A6,' interactions.'/1X,'Execution stopped!')
2290 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2291 &1X,'Execution stopped!')
2292 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2293 &1X,'Execution stopped!')
2294 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2295 &1X,'Execution stopped.')
2296 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2302 C*********************************************************************
2304 *$ CREATE PYEVNT.FOR
2307 C...Administers the generation of a high-pT event via calls to
2308 C...a number of subroutines.
2312 C...Double precision and integer declarations.
2313 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2314 INTEGER PYK,PYCHGE,PYCOMP
2316 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2317 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2318 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2319 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2320 COMMON/PYINT1/MINT(400),VINT(400)
2321 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2322 COMMON/PYINT4/MWID(500),WIDS(500,5)
2323 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2324 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
2325 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,
2326 &/PYINT4/,/PYINT5/,/PYUPPR/
2330 C...Initial values for some counters.
2341 C...If variable energies: redo incoming kinematics and cross-section.
2343 IF(MSTP(171).EQ.1) THEN
2345 IF(MSTI(61).EQ.1) THEN
2349 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2353 C...Loop over number of pileup events; check space left.
2354 IF(MSTP(131).LE.0) THEN
2360 DO 260 IPILE=1,NPILE
2361 IF(MINT(84)+100.GE.MSTU(4)) THEN
2363 & '(PYEVNT:) no more space in PYJETS for pileup events')
2364 IF(MSTU(21).GE.1) GOTO 270
2368 C...Generate variables of hard scattering.
2372 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2377 IF(MSTI(61).EQ.1) THEN
2381 IF(MINT(51).EQ.2) RETURN
2383 IF(MSTP(111).EQ.-1) GOTO 250
2385 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
2386 C...Hard scattering (including low-pT):
2387 C...reconstruct kinematics and colour flow of hard scattering.
2390 IF(MINT(51).EQ.1) GOTO 100
2393 IF(ISUB.EQ.95) GOTO 130
2395 C...Showering of initial state partons (optional).
2398 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2400 IF(MINT(51).EQ.1) GOTO 100
2402 C...Showering of final state partons (optional).
2405 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2409 IF(ISET(ISUB).EQ.5) IPU4=-3
2411 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2412 CALL PYSHOW(IPU3,IPU4,QMAX)
2413 ELSEIF(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN
2415 IPU3=IFUP(IUP,1)+MINT(84)
2416 IPU4=IFUP(IUP,2)+MINT(84)
2417 QMAX=SQRT(MAX(0D0,Q2UP(IUP)))
2418 CALL PYSHOW(IPU3,IPU4,QMAX)
2423 C...Decay of final state resonances.
2425 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2426 IF(MINT(51).EQ.1) GOTO 100
2429 C...Multiple interactions.
2430 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2433 C...Hadron remnants and primordial kT.
2434 130 CALL PYREMN(IPU1,IPU2)
2435 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2436 IF(MINT(51).EQ.1) GOTO 100
2439 C...Diffractive and elastic scattering.
2443 C...Check that no odd resonance left undecayed.
2444 IF(MSTP(111).GE.1) THEN
2446 DO 140 I=MINT(84)+1,NFIX
2447 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2448 & K(I,2).NE.22) THEN
2449 IF(MWID(PYCOMP(K(I,2))).NE.0) THEN
2451 IF(MINT(51).EQ.1) GOTO 100
2457 C...Recalculate energies from momenta and masses (if desired).
2458 IF(MSTP(113).GE.1) THEN
2459 DO 150 I=MINT(83)+1,N
2460 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2461 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2466 C...Rearrange partons along strings, check invariant mass cuts.
2468 IF(MSTP(111).LE.0) MSTJ(14)=-1
2469 CALL PYPREP(MINT(84)+1)
2471 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2472 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2473 DO 180 I=MINT(84)+1,N
2474 IF(K(I,2).EQ.94) THEN
2475 DO 170 I1=I+1,MIN(N,I+3)
2476 IF(K(I1,3).EQ.I) THEN
2477 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2478 IF(K(I1,3).EQ.0) THEN
2479 DO 160 II=MINT(84)+1,I-1
2480 IF(K(II,2).EQ.K(I1,2)) THEN
2481 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2482 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2485 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2493 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2494 IF(MSTP(125).EQ.0) MINT(4)=0
2495 DO 200 I=MINT(83)+1,N
2496 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2498 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2499 IF(K(I1,3).EQ.I) K(I,5)=I1
2505 C...Introduce separators between sections in PYLIST event listing.
2506 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2509 ELSEIF(IPILE.EQ.1) THEN
2516 C...Go back to lab frame (needed for vertices, also in fragmentation).
2519 C...Set nonvanishing production vertex (optional).
2520 IF(MSTP(151).EQ.1) THEN
2522 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2523 & SIN(PARU(2)*PYR(0))
2525 DO 230 I=MINT(83)+1,N
2527 V(I,J)=V(I,J)+VTX(J)
2532 C...Perform hadronization (if desired).
2533 IF(MSTP(111).GE.1) THEN
2535 IF(MSTU(24).NE.0) GOTO 100
2537 IF(MSTP(113).GE.1) THEN
2539 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
2540 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2543 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
2545 C...Store event information and calculate Monte Carlo estimates of
2546 C...subprocess cross-sections.
2547 250 IF(IPILE.EQ.1) CALL PYDOCU
2549 C...Set counters for current pileup event and loop to next one.
2551 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
2552 IF(MSTU70.LT.10) THEN
2557 MINT(84)=N+MSTP(126)
2558 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
2561 C...Generic information on pileup events. Reconstruct missing history.
2562 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
2566 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
2570 C...Transform to the desired coordinate frame.
2571 270 CALL PYFRAM(MSTP(124))
2578 C***********************************************************************
2580 *$ CREATE PYSTAT.FOR
2583 C...Prints out information about cross-sections, decay widths, branching
2584 C...ratios, kinematical limits, status codes and parameter values.
2586 SUBROUTINE PYSTAT(MSTAT)
2588 C...Double precision and integer declarations.
2589 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2590 INTEGER PYK,PYCHGE,PYCOMP
2591 C...Parameter statement to help give large particle numbers.
2592 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2596 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2597 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2598 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2599 COMMON/PYINT1/MINT(400),VINT(400)
2600 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2601 COMMON/PYINT4/MWID(500),WIDS(500,5)
2602 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2603 COMMON/PYINT6/PROC(0:500)
2605 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2606 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
2607 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/
2608 C...Local arrays, character variables and data.
2609 DIMENSION WDTP(0:200),WDTE(0:200,0:5)
2610 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
2611 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28
2613 &'VMD/hadron * VMD ','VMD/hadron * direct ',
2614 &'VMD/hadron * anomalous ','direct * direct ',
2615 &'direct * anomalous ','anomalous * anomalous '/
2616 DATA DISGA/'e * VMD','e * anomalous'/
2617 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
2618 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2619 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
2620 &' y*_small ',' eta*_large ',' eta*_small ',
2621 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
2622 &' x_2 ',' x_F ',' cos(theta_hard) ',
2623 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
2624 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
2629 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
2630 WRITE(MSTU(11),5000)
2631 WRITE(MSTU(11),5100)
2632 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
2634 IF(MSUB(I).NE.1) GOTO 100
2635 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
2637 IF(MINT(121).GT.1) THEN
2638 WRITE(MSTU(11),5300)
2639 DO 110 IGA=1,MINT(121)
2641 IF(MINT(121).EQ.2) THEN
2642 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
2645 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
2651 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
2652 & MAX(1D0,DBLE(NGEN(0,2)))
2654 C...Decay widths and branching ratios.
2655 ELSEIF(MSTAT.EQ.2) THEN
2656 WRITE(MSTU(11),5500)
2657 WRITE(MSTU(11),5600)
2660 CALL PYNAME(KF,CHKF)
2663 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
2664 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
2665 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
2666 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
2667 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
2669 IF(MWID(KC).LE.0) GOTO 140
2670 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
2671 & KF/KSUSY1.EQ.2)) GOTO 140
2673 C...Off-shell branchings.
2676 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
2677 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
2678 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
2679 DO 120 J=1,MDCY(KC,3)
2682 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2683 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2685 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2686 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2687 CALL PYNAME(KFDP(IDC,1),CHD1)
2688 CALL PYNAME(KFDP(IDC,2),CHD2)
2689 IF(KFDP(IDC,3).EQ.0) THEN
2690 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2691 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2692 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2694 CALL PYNAME(KFDP(IDC,3),CHD3)
2695 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2696 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2697 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2700 C...On-shell decays.
2702 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
2704 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
2705 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
2706 & STATE(MDCY(KC,1)),BRFIN
2707 DO 130 J=1,MDCY(KC,3)
2710 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2711 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2713 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2714 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2716 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
2717 CALL PYNAME(KFDP(IDC,1),CHD1)
2718 CALL PYNAME(KFDP(IDC,2),CHD2)
2719 IF(KFDP(IDC,3).EQ.0) THEN
2720 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2721 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2722 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
2723 & STATE(MDME(IDC,1)),BRFIN
2725 CALL PYNAME(KFDP(IDC,3),CHD3)
2726 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2727 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2728 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
2729 & STATE(MDME(IDC,1)),BRFIN
2734 WRITE(MSTU(11),6000)
2736 C...Allowed incoming partons/particles at hard interaction.
2737 ELSEIF(MSTAT.EQ.3) THEN
2738 WRITE(MSTU(11),6100)
2739 CALL PYNAME(MINT(11),CHAU)
2741 CALL PYNAME(MINT(12),CHAU)
2743 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
2747 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
2748 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
2750 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
2753 WRITE(MSTU(11),6400)
2755 C...User-defined limits on kinematical variables.
2756 ELSEIF(MSTAT.EQ.4) THEN
2757 WRITE(MSTU(11),6500)
2758 WRITE(MSTU(11),6600)
2760 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
2761 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
2762 PTHMIN=MAX(CKIN(3),CKIN(5))
2764 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
2765 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
2766 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
2768 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
2771 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
2772 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
2773 WRITE(MSTU(11),7000)
2775 C...Status codes and parameter values.
2776 ELSEIF(MSTAT.EQ.5) THEN
2777 WRITE(MSTU(11),7100)
2778 WRITE(MSTU(11),7200)
2780 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
2784 C...List of all processes implemented in the program.
2785 ELSEIF(MSTAT.EQ.6) THEN
2786 WRITE(MSTU(11),7400)
2787 WRITE(MSTU(11),7500)
2789 IF(ISET(I).LT.0) GOTO 180
2790 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
2792 WRITE(MSTU(11),7700)
2795 C...Formats for printouts.
2796 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
2797 &'Events and Cross-sections',1X,9('*'))
2798 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
2799 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
2800 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
2801 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
2802 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
2803 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
2805 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
2807 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
2808 &1X,'I',34X,'I',28X,'I',12X,'I')
2809 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
2810 &1X,'********* Fraction of events that fail fragmentation ',
2811 &'cuts =',1X,F8.5,' *********'/)
2812 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
2813 &'Ratios',1X,27('*'))
2814 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2815 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
2816 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
2817 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2819 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
2820 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
2821 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
2822 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
2823 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2824 &1P,D10.3,0P,1X,'I')
2825 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
2826 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2827 &1P,D10.3,0P,1X,'I')
2828 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
2829 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
2830 &'Particles at Hard Interaction',1X,7('*'))
2831 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
2832 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
2833 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
2834 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
2835 &78('=')/1X,'I',38X,'I',37X,'I')
2836 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
2837 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
2838 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
2839 &'Kinematical Variables',1X,12('*'))
2840 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
2841 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
2843 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
2844 &1X,'<',1X,1P,D10.3,0P,16X,'I')
2845 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
2846 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
2847 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
2848 &'Parameter Values',1X,12('*'))
2849 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
2851 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
2852 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
2854 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
2855 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
2856 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
2857 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
2858 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
2863 C*********************************************************************
2865 *$ CREATE PYINRE.FOR
2868 C...Calculates full and effective widths of gauge bosons, stores
2869 C...masses and widths, rescales coefficients to be used for
2870 C...resonance production generation.
2874 C...Double precision and integer declarations.
2875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2876 INTEGER PYK,PYCHGE,PYCOMP
2877 C...Parameter statement to help give large particle numbers.
2878 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2880 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2882 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2883 COMMON/PYDAT4/CHAF(500,2)
2885 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2886 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2887 COMMON/PYINT1/MINT(400),VINT(400)
2888 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2889 COMMON/PYINT4/MWID(500),WIDS(500,5)
2890 COMMON/PYINT6/PROC(0:500)
2892 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2893 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2894 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
2895 C...Local arrays and data.
2896 DIMENSION WDTP(0:200),WDTE(0:200,0:5),WDTPM(0:200),
2897 &WDTEM(0:200,0:5),KCORD(500),PMORD(500)
2899 C...Born level couplings in MSSM Higgs doublet sector.
2902 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
2904 IF(MSTP(4).EQ.2) THEN
2906 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
2910 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
2911 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
2913 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
2914 WRITE(MSTU(11),5000)
2917 PMAS(35,1)=SQRT(SQMHP)
2918 PMAS(36,1)=SQRT(SQMA)
2919 PMAS(37,1)=SQRT(SQMHC)
2920 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
2925 PARU(161)=-SIN(ALSU)/COS(BESU)
2926 PARU(162)=COS(ALSU)/SIN(BESU)
2928 PARU(164)=SIN(BESU-ALSU)
2930 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
2931 PARU(171)=COS(ALSU)/COS(BESU)
2932 PARU(172)=SIN(ALSU)/SIN(BESU)
2934 PARU(174)=COS(BESU-ALSU)
2936 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
2938 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
2939 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
2945 PARU(186)=COS(BESU-ALSU)
2946 PARU(187)=SIN(BESU-ALSU)
2950 PARU(195)=COS(BESU-ALSU)
2953 C...Reset effective widths of gauge bosons.
2960 C...Order resonances by increasing mass (except Z0 and W+/-).
2964 IF(KF.EQ.0) GOTO 140
2965 IF(MWID(KC).EQ.0) GOTO 140
2966 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
2967 IF(MSTP(1).LE.3) GOTO 140
2969 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
2970 IF(IMSS(1).LE.0) GOTO 140
2974 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
2975 DO 120 I1=NRES-1,1,-1
2976 IF(PMRES.GE.PMORD(I1)) GOTO 130
2977 KCORD(I1+1)=KCORD(I1)
2978 PMORD(I1+1)=PMORD(I1)
2984 C...Loop over possible resonances.
2989 C...Check that no fourth generation channels on by mistake.
2990 IF(MSTP(1).LE.3) THEN
2991 DO 150 J=1,MDCY(KC,3)
2993 KFA1=IABS(KFDP(IDC,1))
2994 KFA2=IABS(KFDP(IDC,2))
2995 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
2996 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3001 C...Check that no supersymmetric channels on by mistake.
3002 IF(IMSS(1).LE.0) THEN
3003 DO 160 J=1,MDCY(KC,3)
3005 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3006 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3007 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3012 C...Find mass and evaluate width.
3014 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3015 IF(MWID(KC).EQ.3) MINT(63)=1
3016 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3019 C...Evaluate suppression factors due to non-simulated channels.
3020 IF(KCHG(KC,3).EQ.0) THEN
3021 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3022 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3023 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3024 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3029 IF(MWID(KC).EQ.3) MINT(63)=1
3030 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3032 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3033 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3034 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3035 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3036 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3037 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3038 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3039 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3040 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3041 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3042 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3043 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3046 C...Set resonance widths and branching ratios;
3047 C...also on/off switch for decays.
3048 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3050 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3052 DO 170 J=1,MDCY(KC,3)
3055 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3060 C...Flavours of leptoquark: redefine charge and name.
3061 KFLQQ=KFDP(MDCY(39,2),1)
3062 KFLQL=KFDP(MDCY(39,2),2)
3063 KCHG(39,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3064 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3066 IF(IABS(KFLQL).EQ.13) LL=2
3067 IF(IABS(KFLQL).EQ.15) LL=3
3068 CHAF(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3069 &CHAF(IABS(KFLQL),1)(1:LL)//' '
3070 CHAF(39,2)=CHAF(39,2)(1:4+LL)//'bar '
3072 C...Special cases in treatment of gamma*/Z0: redefine process name.
3073 IF(MSTP(43).EQ.1) THEN
3074 PROC(1)='f + fbar -> gamma*'
3075 PROC(15)='f + fbar -> g + gamma*'
3076 PROC(19)='f + fbar -> gamma + gamma*'
3077 PROC(30)='f + g -> f + gamma*'
3078 PROC(35)='f + gamma -> f + gamma*'
3079 ELSEIF(MSTP(43).EQ.2) THEN
3080 PROC(1)='f + fbar -> Z0'
3081 PROC(15)='f + fbar -> g + Z0'
3082 PROC(19)='f + fbar -> gamma + Z0'
3083 PROC(30)='f + g -> f + Z0'
3084 PROC(35)='f + gamma -> f + Z0'
3085 ELSEIF(MSTP(43).EQ.3) THEN
3086 PROC(1)='f + fbar -> gamma*/Z0'
3087 PROC(15)='f + fbar -> g + gamma*/Z0'
3088 PROC(19)='f + fbar -> gamma + gamma*/Z0'
3089 PROC(30)='f + g -> f + gamma*/Z0'
3090 PROC(35)='f + gamma -> f + gamma*/Z0'
3093 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3094 IF(MSTP(44).EQ.1) THEN
3095 PROC(141)='f + fbar -> gamma*'
3096 ELSEIF(MSTP(44).EQ.2) THEN
3097 PROC(141)='f + fbar -> Z0'
3098 ELSEIF(MSTP(44).EQ.3) THEN
3099 PROC(141)='f + fbar -> Z''0'
3100 ELSEIF(MSTP(44).EQ.4) THEN
3101 PROC(141)='f + fbar -> gamma*/Z0'
3102 ELSEIF(MSTP(44).EQ.5) THEN
3103 PROC(141)='f + fbar -> gamma*/Z''0'
3104 ELSEIF(MSTP(44).EQ.6) THEN
3105 PROC(141)='f + fbar -> Z0/Z''0'
3106 ELSEIF(MSTP(44).EQ.7) THEN
3107 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3110 C...Special cases in treatment of WW -> WW: redefine process name.
3111 IF(MSTP(45).EQ.1) THEN
3112 PROC(77)='W+ + W+ -> W+ + W+'
3113 ELSEIF(MSTP(45).EQ.2) THEN
3114 PROC(77)='W+ + W- -> W+ + W-'
3115 ELSEIF(MSTP(45).EQ.3) THEN
3116 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3119 C...Format for error information.
3120 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3121 &'combination'/1X,'Execution stopped!')
3126 C*********************************************************************
3128 *$ CREATE PYINBM.FOR
3131 C...Identifies the two incoming particles and the choice of frame.
3133 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3135 C...Double precision and integer declarations.
3136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3137 INTEGER PYK,PYCHGE,PYCOMP
3139 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3142 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3143 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3144 COMMON/PYINT1/MINT(400),VINT(400)
3145 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3146 C...Local arrays, character variables and data.
3147 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
3148 &CHIDNT(3)*8,CHTEMP*8,CHCDE(29)*8,CHINIT*76
3149 DIMENSION LEN(3),KCDE(29),PM(2)
3150 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3151 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3152 DATA CHCDE/'e- ','e+ ','nu_e ','nu_ebar ',
3153 &'mu- ','mu+ ','nu_mu ','nu_mubar','tau- ',
3154 &'tau+ ','nu_tau ','nu_tauba','pi+ ','pi- ',
3155 &'n0 ','nbar0 ','p+ ','pbar- ','gamma ',
3156 &'lambda0 ','sigma- ','sigma0 ','sigma+ ','xi- ',
3157 &'xi0 ','omega- ','pi0 ','reggeon ','pomeron '/
3158 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3159 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3160 &3312,3322,3334,111,28,29/
3162 C...Store initial energy. Default frame.
3166 C...Convert character variables to lowercase and find their length.
3173 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
3175 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
3181 C...Fix up bar, underscore and charge in particle name (if needed).
3183 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
3185 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:6)//' '
3188 IF(CHIDNT(I)(7:7).EQ.'~') CHIDNT(I)(7:8)='ba'
3189 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
3191 CHIDNT(I)='nu_'//CHTEMP(3:7)
3192 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
3193 CHIDNT(I)(1:3)='n0 '
3194 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
3195 CHIDNT(I)(1:5)='nbar0'
3196 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
3197 CHIDNT(I)(1:3)='p+ '
3198 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
3199 & CHIDNT(I)(1:2).EQ.'p-') THEN
3200 CHIDNT(I)(1:5)='pbar-'
3201 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
3203 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
3204 CHIDNT(I)(1:7)='reggeon'
3205 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
3206 CHIDNT(I)(1:7)='pomeron'
3210 C...Identify free initialization.
3211 IF(CHCOM(1)(1:2).EQ.'no') THEN
3216 C...Identify incoming beam and target particles.
3219 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
3221 PM(I)=PYMASS(MINT(10+I))
3224 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
3225 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
3226 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
3228 C...Identify choice of frame and input energies.
3231 C...Events defined in the CM frame.
3232 IF(CHCOM(1)(1:2).EQ.'cm') THEN
3235 IF(MSTP(122).GE.1) THEN
3236 IF(CHCOM(2)(1:1).NE.'e') THEN
3237 LOFFS=(31-(LEN(2)+LEN(3)))/2
3238 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
3239 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3242 LOFFS=(30-(LEN(2)+LEN(3)))/2
3243 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
3244 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3247 WRITE(MSTU(11),5200) CHINIT
3248 WRITE(MSTU(11),5300) WIN
3251 C...Events defined in fixed target frame.
3252 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
3254 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
3255 IF(MSTP(122).GE.1) THEN
3256 LOFFS=(29-(LEN(2)+LEN(3)))/2
3257 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3258 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3259 & ' fixed target'//' '
3260 WRITE(MSTU(11),5200) CHINIT
3261 WRITE(MSTU(11),5400) WIN
3262 WRITE(MSTU(11),5500) SQRT(S)
3265 C...Frame defined by user three-vectors.
3266 ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
3270 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3271 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3272 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3273 & (P(1,3)+P(2,3))**2
3274 IF(MSTP(122).GE.1) THEN
3275 LOFFS=(12-(LEN(2)+LEN(3)))/2
3276 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3277 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3278 & ' user-specified configuration'//' '
3279 WRITE(MSTU(11),5200) CHINIT
3280 WRITE(MSTU(11),5600)
3281 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3282 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3283 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3286 C...Frame defined by user four-vectors.
3287 ELSEIF(CHCOM(1)(1:4).EQ.'four') THEN
3289 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3290 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3291 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3292 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3293 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3294 & (P(1,3)+P(2,3))**2
3295 IF(MSTP(122).GE.1) THEN
3296 LOFFS=(12-(LEN(2)+LEN(3)))/2
3297 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3298 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3299 & ' user-specified configuration'//' '
3300 WRITE(MSTU(11),5200) CHINIT
3301 WRITE(MSTU(11),5600)
3302 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3303 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3304 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3307 C...Frame defined by user five-vectors.
3308 ELSEIF(CHCOM(1)(1:4).EQ.'five') THEN
3310 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3311 & (P(1,3)+P(2,3))**2
3312 IF(MSTP(122).GE.1) THEN
3313 LOFFS=(12-(LEN(2)+LEN(3)))/2
3314 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3315 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3316 & ' user-specified configuration'//' '
3317 WRITE(MSTU(11),5200) CHINIT
3318 WRITE(MSTU(11),5600)
3319 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3320 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3321 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3324 C...Unknown frame. Error for too low CM energy.
3326 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
3329 IF(S.LT.PARP(2)**2) THEN
3330 WRITE(MSTU(11),5900) SQRT(S)
3334 C...Formats for initialization and error information.
3335 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
3336 &1X,'Execution stopped!')
3337 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
3338 &1X,'Execution stopped!')
3339 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
3340 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
3341 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
3342 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
3343 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
3344 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
3345 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
3346 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
3347 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
3348 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
3349 &1X,'Execution stopped!')
3350 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
3351 &'generation.'/1X,'Execution stopped!')
3356 C*********************************************************************
3358 *$ CREATE PYINKI.FOR
3361 C...Sets up kinematics, including rotations and boosts to/from CM frame.
3363 SUBROUTINE PYINKI(MODKI)
3365 C...Double precision and integer declarations.
3366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3367 INTEGER PYK,PYCHGE,PYCOMP
3369 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3372 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3373 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3374 COMMON/PYINT1/MINT(400),VINT(400)
3375 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3377 C...Set initial flavour state.
3384 C...Reset boost. Do kinematics for various cases.
3389 C...Set up kinematics for events defined in CM frame.
3390 IF(MINT(111).EQ.1) THEN
3392 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3400 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
3403 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3404 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
3406 C...Set up kinematics for fixed target events.
3407 ELSEIF(MINT(111).EQ.2) THEN
3409 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3417 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3420 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
3421 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
3422 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
3424 C...Set up kinematics for events in user-defined frame.
3425 ELSEIF(MINT(111).EQ.3) THEN
3428 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3429 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3431 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3433 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3434 VINT(7)=PYANGL(P(1,1),P(1,2))
3435 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3436 VINT(6)=PYANGL(P(1,3),P(1,1))
3437 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3438 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
3440 C...Set up kinematics for events with user-defined four-vectors.
3441 ELSEIF(MINT(111).EQ.4) THEN
3442 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3443 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3444 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3445 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3447 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3449 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3450 VINT(7)=PYANGL(P(1,1),P(1,2))
3451 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3452 VINT(6)=PYANGL(P(1,3),P(1,1))
3453 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3454 S=(P(1,4)+P(2,4))**2
3456 C...Set up kinematics for events with user-defined five-vectors.
3457 ELSEIF(MINT(111).EQ.5) THEN
3459 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3461 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3462 VINT(7)=PYANGL(P(1,1),P(1,2))
3463 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3464 VINT(6)=PYANGL(P(1,3),P(1,1))
3465 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3466 S=(P(1,4)+P(2,4))**2
3469 C...Return or error for too low CM energy.
3470 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
3471 IF(MSTP(172).LE.1) THEN
3473 & '(PYINKI:) too low invariant mass in this event')
3480 C...Save information on incoming particles.
3483 IF(MINT(111).GE.4) VINT(3)=P(1,5)
3484 IF(MINT(111).GE.4) VINT(4)=P(2,5)
3486 IF(MODKI.EQ.0) VINT(289)=S
3494 C...Store pT cut-off and related constants to be used in generation.
3495 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
3496 IF(MSTP(82).LE.1) THEN
3497 IF(MINT(121).GT.1) PARP(81)=1.30D0+0.15D0*LOG(VINT(1)/200D0)/
3501 IF(MINT(121).GT.1) PARP(82)=1.25D0+0.15D0*LOG(VINT(1)/200D0)/
3505 VINT(149)=4D0*PTMN**2/S
3510 C*********************************************************************
3512 *$ CREATE PYINPR.FOR
3515 C...Selects partonic subprocesses to be included in the simulation.
3519 C...Double precision and integer declarations.
3520 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3521 INTEGER PYK,PYCHGE,PYCOMP
3523 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3524 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3525 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3526 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3527 COMMON/PYINT1/MINT(400),VINT(400)
3528 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3529 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
3531 C...Reset processes to be included.
3538 C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous.
3539 IF(MINT(121).EQ.2) THEN
3541 MINT(123)=MINT(122)+1
3543 C...For gamma-p or gamma-gamma with MSTP(14)=10 allow mixture.
3544 C...Here also set a few parameters otherwise normally not touched.
3545 ELSEIF(MINT(121).GT.1) THEN
3547 C...Parton distributions dampened at small Q2; go to low energies,
3548 C...alpha_s <1; no minimum pT cut-off a priori.
3556 C...Define pT cut-off parameters and whether run involves low-pT.
3557 IF(MSTP(82).LE.1) THEN
3558 PTMVMD=1.30D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3560 PTMVMD=1.25D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3564 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
3565 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
3567 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
3568 IF(MSEL.EQ.2) IPTL=1
3570 C...Set up for p/VMD * VMD.
3571 IF(MINT(122).EQ.1) THEN
3579 IF(IPTL.EQ.1) MSUB(95)=1
3588 IF(IPTL.EQ.1) CKIN(3)=0D0
3590 C...Set up for p/VMD * direct gamma.
3591 ELSEIF(MINT(122).EQ.2) THEN
3593 IF(MINT(121).EQ.6) MINT(123)=5
3596 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3598 C...Set up for p/VMD * anomalous gamma.
3599 ELSEIF(MINT(122).EQ.3) THEN
3601 IF(MINT(121).EQ.6) MINT(123)=7
3608 IF(MSTP(82).GE.2) MSTP(85)=1
3609 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3611 C...Set up for direct * direct gamma (switch off leptons).
3612 ELSEIF(MINT(122).EQ.4) THEN
3615 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3616 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3618 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3620 C...Set up for direct * anomalous gamma.
3621 ELSEIF(MINT(122).EQ.5) THEN
3625 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3627 C...Set up for anomalous * anomalous gamma.
3628 ELSEIF(MINT(122).EQ.6) THEN
3636 IF(MSTP(82).GE.2) MSTP(85)=1
3637 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3640 C...End of special set up for gamma-p and gamma-gamma.
3644 C...Flavour information for individual beams.
3647 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
3648 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
3649 IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2
3650 MINT(44+I)=MINT(40+I)
3651 IF(MSTP(11).GE.1.AND.IABS(MINT(10+I)).EQ.11) MINT(44+I)=3
3654 C...If two gammas, whereof one direct, pick the first.
3655 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3656 IF(MINT(123).GE.4.AND.MINT(123).LE.6) THEN
3660 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
3661 IF(MINT(123).GE.4) CALL PYERRM(26,
3662 & '(PYINPR:) unallowed MSTP(14) code for single photon')
3665 C...Flavour information on combination of incoming particles.
3666 MINT(43)=2*MINT(41)+MINT(42)-2
3668 IF(MINT(123).LE.0) THEN
3669 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
3670 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
3671 ELSEIF(MINT(123).LE.3) THEN
3672 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
3673 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
3674 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3678 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
3679 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
3681 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
3682 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.MINT(123).GE.3)
3685 IF(MINT(11).EQ.22) THEN
3687 IF(MINT(123).GE.4) MINT(107)=0
3688 IF(MINT(123).EQ.7) MINT(107)=2
3691 IF(MINT(12).EQ.22) THEN
3693 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
3694 IF(MINT(123).EQ.7) MINT(108)=3
3697 C...Select default processes according to incoming beams
3698 C...(already done for gamma-p and gamma-gamma with MSTP(14)=10).
3699 IF(MINT(121).GT.1) THEN
3700 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
3702 IF(MINT(43).EQ.1) THEN
3703 C...Lepton + lepton -> gamma/Z0 or W.
3704 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
3705 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
3707 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
3708 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
3709 C...Unresolved photon + lepton: Compton scattering.
3712 ELSEIF(MINT(43).LE.3) THEN
3713 C...Lepton + hadron: deep inelastic scattering.
3716 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
3717 & MINT(12).EQ.22) THEN
3718 C...Two unresolved photons: fermion pair production.
3721 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
3722 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
3723 & MINT(12).EQ.22)) THEN
3724 C...Unresolved photon + hadron: photon-parton scattering.
3729 ELSEIF(MSEL.EQ.1) THEN
3730 C...High-pT QCD processes:
3737 IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
3738 IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
3739 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
3742 C...All QCD processes:
3756 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
3757 C...Heavy quark production.
3761 DO 130 J=1,MIN(8,MDCY(21,3))
3762 MDME(MDCY(21,2)+J-1,1)=0
3764 MDME(MDCY(21,2)+MSEL-1,1)=1
3766 DO 140 J=1,MIN(12,MDCY(22,3))
3767 MDME(MDCY(22,2)+J-1,1)=0
3769 MDME(MDCY(22,2)+MSEL-1,1)=1
3771 ELSEIF(MSEL.EQ.10) THEN
3772 C...Prompt photon production:
3777 ELSEIF(MSEL.EQ.11) THEN
3778 C...Z0/gamma* production:
3781 ELSEIF(MSEL.EQ.12) THEN
3782 C...W+/- production:
3785 ELSEIF(MSEL.EQ.13) THEN
3790 ELSEIF(MSEL.EQ.14) THEN
3795 ELSEIF(MSEL.EQ.15) THEN
3796 C...Z0 & W+/- pair production:
3803 ELSEIF(MSEL.EQ.16) THEN
3811 ELSEIF(MSEL.EQ.17) THEN
3812 C...h0 & Z0 or W+/- pair production:
3816 ELSEIF(MSEL.EQ.18) THEN
3817 C...h0 production; interesting processes in e+e-.
3823 ELSEIF(MSEL.EQ.19) THEN
3824 C...h0, H0 and A0 production; interesting processes in e+e-.
3838 ELSEIF(MSEL.EQ.21) THEN
3842 ELSEIF(MSEL.EQ.22) THEN
3843 C...W'+/- production:
3846 ELSEIF(MSEL.EQ.23) THEN
3847 C...H+/- production:
3850 ELSEIF(MSEL.EQ.24) THEN
3854 ELSEIF(MSEL.EQ.25) THEN
3855 C...LQ (leptoquark) production.
3861 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
3862 C...Production of one heavy quark (W exchange):
3864 DO 150 J=1,MIN(8,MDCY(21,3))
3865 MDME(MDCY(21,2)+J-1,1)=0
3867 MDME(MDCY(21,2)+MSEL-31,1)=1
3869 CMRENNA++Define SUSY alternatives.
3870 ELSEIF(MSEL.EQ.39) THEN
3871 C...Turn on all SUSY processes.
3872 IF(MINT(43).EQ.4) THEN
3873 C...Hadron-hadron processes.
3875 IF(ISET(I).GE.0) MSUB(I)=1
3877 ELSEIF(MINT(43).EQ.1) THEN
3878 C...Lepton-lepton processes: QED production of squarks.
3895 ELSEIF(MSEL.EQ.40) THEN
3896 C...Gluinos and squarks.
3897 IF(MINT(43).EQ.4) THEN
3909 ELSEIF(MINT(43).EQ.1) THEN
3914 ELSEIF(MSEL.EQ.41) THEN
3915 C...Stop production.
3919 IF(MINT(43).EQ.4) THEN
3924 ELSEIF(MSEL.EQ.42) THEN
3925 C...Slepton production.
3929 IF(MINT(43).NE.4) THEN
3935 ELSEIF(MSEL.EQ.43) THEN
3936 C...Neutralino/Chargino + Gluino/Squark.
3937 IF(MINT(43).EQ.4) THEN
3946 ELSEIF(MSEL.EQ.44) THEN
3947 C...Neutralino/Chargino pair production.
3948 IF(MINT(43).EQ.4) THEN
3952 ELSEIF(MINT(43).EQ.1) THEN
3959 C...Find heaviest new quark flavour allowed in processes 81-84.
3961 DO 260 I=1,MIN(8,MDCY(21,3))
3963 IF(MDME(IDC,1).LE.0) GOTO 260
3966 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
3977 C...Find heaviest new fermion flavour allowed in process 85.
3979 DO 270 I=1,MIN(12,MDCY(22,3))
3981 IF(MDME(IDC,1).LE.0) GOTO 270
3984 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
3985 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
3993 C*********************************************************************
3995 *$ CREATE PYXTOT.FOR
3998 C...Parametrizes total, elastic and diffractive cross-sections
3999 C...for different energies and beams. Donnachie-Landshoff for
4000 C...total and Schuler-Sjostrand for elastic and diffractive.
4001 C...Process code IPROC:
4008 C...= 7 : J/psi + p;
4009 C...= 11 : rho + rho;
4010 C...= 12 : rho + phi;
4011 C...= 13 : rho + J/psi;
4012 C...= 14 : phi + phi;
4013 C...= 15 : phi + J/psi;
4014 C...= 16 : J/psi + J/psi;
4015 C...= 21 : gamma + p (DL);
4016 C...= 22 : gamma + p (VDM).
4017 C...= 23 : gamma + pi (DL);
4018 C...= 24 : gamma + pi (VDM);
4019 C...= 25 : gamma + gamma (DL);
4020 C...= 26 : gamma + gamma (VDM).
4024 C...Double precision and integer declarations.
4025 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4026 INTEGER PYK,PYCHGE,PYCOMP
4028 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4029 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4030 COMMON/PYINT1/MINT(400),VINT(400)
4031 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4032 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4033 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
4035 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
4036 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
4037 &CEFFD(10,9),SIGTMP(6,0:5)
4039 C...Common constants.
4040 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
4041 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
4044 C...Number of multiple processes to be evaluated (= 0 : undefined).
4045 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4046 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4047 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
4048 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
4049 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
4051 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
4052 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
4053 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
4055 C...Beam and target hadron class:
4056 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4057 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4058 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
4059 C...Characteristic class masses, slope parameters, beta = sqrt(X).
4060 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
4061 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
4062 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
4064 C...Fitting constants used in parametrizations of diffractive results.
4065 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4066 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4067 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
4068 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
4069 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
4070 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
4071 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
4072 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
4073 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
4074 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
4075 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
4076 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
4077 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
4078 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
4079 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
4080 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
4081 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
4082 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
4083 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
4084 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
4085 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
4086 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
4087 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
4088 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
4089 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
4090 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
4091 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
4092 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
4093 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
4095 C...Parameters. Combinations of the energy.
4104 C...Ratio of gamma/pi (for rescaling in parton distributions).
4105 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
4106 &(XPAR(5)*SEPS+YPAR(5)*SETA)
4107 IF(MINT(50).NE.1) RETURN
4109 C...Order flavours of incoming particles: KF1 < KF2.
4110 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
4119 ISGN12=ISIGN(1,MINT(11)*MINT(12))
4121 C...Find process number (for lookup tables).
4122 IF(KF1.GT.1000) THEN
4124 IF(ISGN12.LT.0) IPROC=2
4125 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
4127 IF(ISGN12.LT.0) IPROC=4
4128 IF(KF1.EQ.111) IPROC=5
4129 ELSEIF(KF1.GT.100) THEN
4131 ELSEIF(KF2.GT.1000) THEN
4133 IF(MINT(123).EQ.2) IPROC=22
4134 ELSEIF(KF2.GT.100) THEN
4136 IF(MINT(123).EQ.2) IPROC=24
4139 IF(MINT(123).EQ.2) IPROC=26
4142 C... Number of multiple processes to be stored; beam/target side.
4148 ELSEIF(NPR.EQ.6) THEN
4153 IF(MINT(101).EQ.4) N1=4
4155 IF(MINT(102).EQ.4) N2=4
4157 C...Do not do any more for user-set or undefined cross-sections.
4158 IF(MSTP(31).LE.0) RETURN
4159 IF(NPR.EQ.0) CALL PYERRM(26,
4160 &'(PYXTOT:) cross section for this process not yet implemented')
4162 C...Parameters. Combinations of the energy.
4171 C...Loop over multiple processes (for VDM).
4175 ELSEIF(NPR.EQ.3) THEN
4177 IF(KF2.LT.1000) IPR=I+10
4178 ELSEIF(NPR.EQ.6) THEN
4182 C...Evaluate hadron species, mass, slope contribution and fit number.
4192 C...Skip if energy too low relative to masses.
4196 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
4198 C...Total cross-section. Elastic slope parameter and cross-section.
4199 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
4200 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
4201 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
4203 C...Diffractive scattering A + B -> X + B.
4206 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
4207 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4208 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4209 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
4210 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
4211 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
4212 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
4214 C...Diffractive scattering A + B -> A + X.
4217 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
4218 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4219 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4220 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
4221 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
4222 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
4223 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
4225 C...Order single diffractive correctly.
4228 SIGTMP(I,2)=SIGTMP(I,3)
4232 C...Double diffractive scattering A + B -> X1 + X2.
4233 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
4234 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
4235 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
4236 IF(YEFF.LE.0) SUM1=0D0
4237 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
4238 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
4239 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
4240 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
4242 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
4243 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
4244 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
4246 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
4247 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
4248 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
4249 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
4250 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
4252 C...Non-diffractive by unitarity.
4253 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
4257 C...Put temporary results in output array: only one process.
4258 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
4260 SIGT(0,0,J)=SIGTMP(1,J)
4263 C...Beam multiple processes.
4264 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
4266 CONV=AEM/PARP(160+I)
4269 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
4273 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4276 C...Target multiple processes.
4277 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
4279 CONV=AEM/PARP(160+I)
4282 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
4286 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
4289 C...Both beam and target multiple processes.
4293 CONV=AEM**2/(PARP(160+I1)*PARP(160+I2))
4296 ELSEIF(I2.LE.2) THEN
4298 ELSEIF(I1.EQ.I2) THEN
4305 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
4306 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
4312 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
4313 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
4315 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4319 C...Scale up uniformly for Donnachie-Landshoff parametrization.
4320 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
4321 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
4325 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
4334 C*********************************************************************
4336 *$ CREATE PYMAXI.FOR
4339 C...Finds optimal set of coefficients for kinematical variable selection
4340 C...and the maximum of the part of the differential cross-section used
4341 C...in the event weighting.
4345 C...Double precision and integer declarations.
4346 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4347 INTEGER PYK,PYCHGE,PYCOMP
4348 C...Parameter statement to help give large particle numbers.
4349 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
4351 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4352 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4353 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
4354 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4355 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4356 COMMON/PYINT1/MINT(400),VINT(400)
4357 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4358 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
4359 COMMON/PYINT4/MWID(500),WIDS(500,5)
4360 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4361 COMMON/PYINT6/PROC(0:500)
4363 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4364 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4365 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
4366 C...Local arrays, character variables and data.
4368 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
4369 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
4370 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
4371 DATA CVAR/'tau ','tau''','y* ','cth '/
4374 C...Select subprocess to study: skip cases not applicable.
4381 IF(ISET(ISUB).EQ.11) THEN
4382 XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
4385 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
4386 XSEC(ISUB,1)=SIGT(0,0,ISUB-90)
4387 IF(MSUB(ISUB).NE.1) GOTO 460
4390 ELSEIF(ISUB.EQ.96) THEN
4391 IF(MINT(50).EQ.0) GOTO 460
4392 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
4394 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
4395 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
4396 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
4397 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
4399 IF(MSUB(ISUB).NE.1) GOTO 460
4403 IF(ISUB.EQ.96) ISTSB=2
4404 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
4406 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
4407 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
4409 C...Find resonances (explicit or implicit in cross-section).
4412 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
4414 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
4415 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
4417 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
4418 & .OR.ISUB.EQ.177) THEN
4420 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
4422 IF(MSTP(46).EQ.5) THEN
4425 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
4427 ELSEIF(ISUB.EQ.194) THEN
4431 IF(CKMX.LE.0D0) CKMX=VINT(1)
4434 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
4435 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
4438 TAUR1=PMAS(KCR1,1)**2/VINT(2)
4439 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
4446 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
4448 IF(ISUB.EQ.194) KFR2=56
4450 TAUR2=PMAS(KCR2,1)**2/VINT(2)
4451 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
4452 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
4453 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
4454 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
4459 ELSEIF(KFR2.NE.0) THEN
4471 C...Find product masses and minimum pT of process.
4477 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4481 IF(KFPR(ISUB,I).EQ.0) THEN
4482 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
4484 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4485 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4488 C...This prevents SUSY/t particles from becoming too light.
4490 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
4493 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
4494 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
4495 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
4496 & PMAS(PYCOMP(KFDP(IDC,2)),1)
4497 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
4498 & PMAS(PYCOMP(KFDP(IDC,3)),1)
4499 PMMN(I)=MIN(PMMN(I),PMSUM)
4502 ELSEIF(KFLW.EQ.6) THEN
4503 PMMN(I)=PMAS(24,1)+PMAS(5,1)
4510 CKIN(41)=MAX(PMMN(1),CKIN(41))
4511 CKIN(43)=MAX(PMMN(2),CKIN(43))
4512 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
4515 IF(MINT(51).EQ.1) THEN
4516 WRITE(MSTU(11),5100) ISUB
4523 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
4524 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
4525 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
4526 IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08D0*PARP(82)
4531 C...Prepare for additional variable choices in 2 -> 3.
4534 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
4536 VINT(204)=PMAS(23,1)
4537 IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
4538 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
4539 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
4543 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
4544 NPTS(1)=2+2*MINT(72)
4545 IF(MINT(47).EQ.1) THEN
4546 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
4547 ELSEIF(MINT(47).EQ.5) THEN
4548 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
4551 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
4552 IF(MINT(47).GE.2) NPTS(2)=2
4553 IF(MINT(47).EQ.5) NPTS(2)=3
4556 IF(MINT(47).GE.4) NPTS(3)=3
4557 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
4558 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
4560 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
4561 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
4563 C...Reset coefficients of cross-section weighting.
4579 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
4580 C...in grid of phase space points.
4586 IF(METAU.EQ.1) GOTO 150
4587 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
4588 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
4589 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
4591 C...Special case when both resonances have same mass,
4592 C...as is often the case in process 194.
4593 IF(MINT(72).EQ.2) THEN
4594 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
4595 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
4596 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
4598 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
4603 CALL PYKMAP(1,MTAU,RTAU)
4604 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
4607 IF(METAUP.EQ.1) GOTO 150
4608 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
4610 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
4611 CALL PYKMAP(4,MTAUP,0.5D0)
4613 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
4617 IF(MEYST.EQ.1) GOTO 150
4618 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
4619 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
4620 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
4621 CALL PYKMAP(2,MYST,0.5D0)
4625 IF(MECTH.EQ.1) GOTO 150
4626 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4627 MCTH=1+MOD(ITRY-1,NPTS(4))
4628 CALL PYKMAP(3,MCTH,0.5D0)
4630 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
4632 C...Store position and limits.
4635 IF(MINT(51).EQ.1) GOTO 150
4638 MVARPT(NACC,2)=MTAUP
4642 VINTPT(NACC,J)=VINT(10+J)
4645 C...Normal case: calculate cross-section.
4647 CALL PYSIGH(NCHN,SIGS)
4653 C..2 -> 3: find highest value out of a number of tries.
4656 DO 140 IKIN3=1,MSTP(129)
4657 CALL PYKMAP(5,0,0D0)
4658 IF(MINT(51).EQ.1) GOTO 140
4659 CALL PYSIGH(NCHN,SIGTMP)
4664 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4668 C...Store cross-section.
4670 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
4671 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
4672 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
4675 WRITE(MSTU(11),5100) ISUB
4678 ELSEIF(SIGSAM.EQ.0D0) THEN
4679 WRITE(MSTU(11),5300) ISUB
4683 IF(ISUB.NE.96) NPOSI=NPOSI+1
4685 C...Calculate integrals in tau over maximal phase space limits.
4688 ATAU1=LOG(TAUMAX/TAUMIN)
4689 IF(NPTS(1).GE.2) THEN
4690 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
4692 IF(NPTS(1).GE.4) THEN
4693 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
4694 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
4697 IF(NPTS(1).GE.6) THEN
4698 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
4699 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
4702 IF(NPTS(1).GT.2+2*MINT(72)) THEN
4703 ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
4706 C...Reset. Sum up cross-sections in points calculated.
4708 IF(NPTS(IVAR).EQ.1) GOTO 320
4709 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
4720 IBIN=MVARPT(IACC,IVAR)
4721 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
4722 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
4723 NAREL(IBIN)=NAREL(IBIN)+1
4724 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
4726 C...Sum up tau cross-section pieces in points used.
4729 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4730 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
4732 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
4733 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
4734 & ((TAU-TAUR1)**2+GAMR1**2)
4737 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
4738 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
4739 & ((TAU-TAUR2)**2+GAMR2**2)
4741 IF(NBIN.GT.2+2*MINT(72)) THEN
4742 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
4743 & TAU/MAX(2D-6,1D0-TAU)
4746 C...Sum up tau' cross-section pieces in points used.
4747 ELSEIF(IVAR.EQ.2) THEN
4749 TAUP=VINTPT(IACC,16)
4750 TAUPMN=VINTPT(IACC,6)
4751 TAUPMX=VINTPT(IACC,26)
4752 ATAUP1=LOG(TAUPMX/TAUPMN)
4753 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
4754 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4755 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
4756 & (1D0-TAU/TAUP)**3/TAUP
4758 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
4759 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
4760 & TAUP/MAX(2D-6,1D0-TAUP)
4763 C...Sum up y* cross-section pieces in points used.
4764 ELSEIF(IVAR.EQ.3) THEN
4766 YSTMIN=VINTPT(IACC,2)
4767 YSTMAX=VINTPT(IACC,22)
4769 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
4771 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
4772 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
4773 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
4774 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
4775 IF(MINT(45).EQ.3) THEN
4776 TAUE=VINTPT(IACC,11)
4777 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4778 YST0=-0.5D0*LOG(TAUE)
4779 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
4780 & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
4781 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
4782 & MAX(1D-6,1D0-EXP(YST-YST0))
4784 IF(MINT(46).EQ.3) THEN
4785 TAUE=VINTPT(IACC,11)
4786 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4787 YST0=-0.5D0*LOG(TAUE)
4788 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
4789 & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
4790 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
4791 & MAX(1D-6,1D0-EXP(-YST-YST0))
4794 C...Sum up cos(theta-hat) cross-section pieces in points used.
4796 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
4798 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
4800 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
4803 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
4804 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
4805 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
4806 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
4808 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4809 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
4810 & MAX(RM34,RSQM-CTH)
4811 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
4812 & MAX(RM34,RSQM+CTH)
4813 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
4814 & MAX(RM34,RSQM-CTH)**2
4815 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
4816 & MAX(RM34,RSQM+CTH)**2
4820 C...Check that equation system solvable.
4821 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
4825 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
4826 & IRED=1,NBIN),WTREL(IBIN)
4827 IF(NAREL(IBIN).EQ.0) MSOLV=0
4828 WTRELS=WTRELS+WTREL(IBIN)
4830 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
4832 C...Solve to find relative importance of cross-section pieces.
4835 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
4837 DO 230 IRED=1,NBIN-1
4838 DO 220 IBIN=IRED+1,NBIN
4839 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
4843 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
4844 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
4845 DO 210 ICOE=IRED,NBIN
4846 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
4850 DO 250 IRED=NBIN,1,-1
4851 DO 240 ICOE=IRED+1,NBIN
4852 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
4854 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
4858 C...Share evenly if failure.
4859 260 IF(MSOLV.EQ.0) THEN
4863 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
4864 & WTREL(IBIN)/WTRELS)
4868 C...Normalize coefficients, with piece shared democratically.
4872 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
4873 COEFSU=COEFSU+COEFU(IBIN)
4874 WTRELS=WTRELS+WTRELN(IBIN)
4876 IF(COEFSU.GT.0D0) THEN
4878 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
4879 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
4883 COEFO(IBIN)=1D0/NBIN
4886 IF(IVAR.EQ.1) IOFF=0
4887 IF(IVAR.EQ.2) IOFF=17
4888 IF(IVAR.EQ.3) IOFF=7
4889 IF(IVAR.EQ.4) IOFF=12
4892 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
4893 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
4894 COEF(ISUB,ICOF)=COEFO(IBIN)
4896 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
4897 & (COEFO(IBIN),IBIN=1,NBIN)
4900 C...Find two most promising maxima among points previously determined.
4908 VINT(10+J)=VINTPT(IACC,J)
4911 CALL PYSIGH(NCHN,SIGS)
4918 DO 350 IKIN3=1,MSTP(129)
4919 CALL PYKMAP(5,0,0D0)
4920 IF(MINT(51).EQ.1) GOTO 350
4921 CALL PYSIGH(NCHN,SIGTMP)
4926 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4931 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
4934 DO 370 IMV=NMAX,1,-1
4936 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
4937 IACCMX(IMV+1)=IACCMX(IMV)
4938 SIGSMX(IMV+1)=SIGSMX(IMV)
4941 380 IACCMX(IIN)=IACC
4943 IF(NMAX.LE.1) NMAX=NMAX+1
4947 C...Read out starting position for search.
4948 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
4953 MTAUP=MVARPT(IACC,2)
4961 C...Starting point and step size in parameter space.
4964 IF(NPTS(IVAR).EQ.1) GOTO 420
4965 IF(IVAR.EQ.1) VVAR=VTAU
4966 IF(IVAR.EQ.2) VVAR=VTAUP
4967 IF(IVAR.EQ.3) VVAR=VYST
4968 IF(IVAR.EQ.4) VVAR=VCTH
4969 IF(IVAR.EQ.1) MVAR=MTAU
4970 IF(IVAR.EQ.2) MVAR=MTAUP
4971 IF(IVAR.EQ.3) MVAR=MYST
4972 IF(IVAR.EQ.4) MVAR=MCTH
4973 IF(IRPT.EQ.1) VDEL=0.1D0
4974 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
4976 IF(IRPT.EQ.1) VMAR=0.02D0
4977 IF(IRPT.EQ.2) VMAR=0.002D0
4979 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
4982 C...Define new point in parameter space.
4986 ELSEIF(IMOV.EQ.1) THEN
4989 ELSEIF(IMOV.EQ.2) THEN
4992 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
4993 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
4999 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
5000 & VVAR-2D0*VDEL.GT.VMAR) THEN
5006 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
5020 C...Convert to relevant variables and find derived new limits.
5024 CALL PYKMAP(1,MTAU,VTAU)
5025 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5027 IF(MINT(51).EQ.1) ILERR=1
5030 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
5032 IF(IVAR.EQ.2) VTAUP=VNEW
5033 CALL PYKMAP(4,MTAUP,VTAUP)
5035 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
5037 IF(MINT(51).EQ.1) ILERR=1
5039 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
5040 IF(IVAR.EQ.3) VYST=VNEW
5041 CALL PYKMAP(2,MYST,VYST)
5043 IF(MINT(51).EQ.1) ILERR=1
5045 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
5047 IF(IVAR.EQ.4) VCTH=VNEW
5048 CALL PYKMAP(3,MCTH,VCTH)
5050 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
5052 C...Evaluate cross-section. Save new maximum. Final maximum.
5055 ELSEIF(ISTSB.NE.5) THEN
5056 CALL PYSIGH(NCHN,SIGS)
5063 DO 400 IKIN3=1,MSTP(129)
5064 CALL PYKMAP(5,0,0D0)
5065 IF(MINT(51).EQ.1) GOTO 400
5066 CALL PYSIGH(NCHN,SIGTMP)
5071 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5075 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5076 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
5077 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5082 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
5083 XSEC(ISUB,1)=1.05D0*SIGSAM
5085 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
5086 & PARP(174)*XSEC(ISUB,1)
5087 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
5091 C...Print summary table.
5093 WRITE(MSTU(11),5900)
5096 IF(MSTP(122).GE.1) THEN
5097 WRITE(MSTU(11),6000)
5098 WRITE(MSTU(11),6100)
5100 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
5101 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
5102 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
5103 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
5104 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
5105 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
5106 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
5108 WRITE(MSTU(11),6300)
5111 C...Format statements for maximization results.
5112 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
5113 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
5114 &'cth',9X,'tau''',7X,'sigma')
5115 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
5116 &'phase space.'/1X,'Process switched off!')
5117 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
5118 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
5119 &'cross-section.'/1X,'Process switched off!')
5120 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
5121 5500 FORMAT(1X,1P,8D11.3)
5122 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
5123 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
5124 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
5125 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
5126 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
5127 &'cross-section.'/1X,'Execution stopped!')
5128 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
5129 &'cross-section maximum search',1X,8('*'))
5130 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
5131 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
5132 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
5133 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
5134 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
5139 C*********************************************************************
5141 *$ CREATE PYPILE.FOR
5144 C...Initializes multiplicity distribution and selects mutliplicity
5145 C...of pileup events, i.e. several events occuring at the same
5148 SUBROUTINE PYPILE(MPILE)
5150 C...Double precision and integer declarations.
5151 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5152 INTEGER PYK,PYCHGE,PYCOMP
5154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5155 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5156 COMMON/PYINT1/MINT(400),VINT(400)
5157 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5158 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
5159 C...Local arrays and saved variables.
5160 DIMENSION WTI(0:200)
5161 SAVE IMIN,IMAX,WTI,WTS
5163 C...Sum of allowed cross-sections for pileup events.
5165 VINT(131)=SIGT(0,0,5)
5166 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
5167 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
5168 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
5169 IF(MSTP(133).LE.0) RETURN
5171 C...Initialize multiplicity distribution at maximum.
5172 XNAVE=VINT(131)*PARP(131)
5173 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
5174 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
5177 WTN=WTI(INAVE)*INAVE
5179 C...Find shape of multiplicity distribution below maximum.
5181 DO 100 I=INAVE-1,1,-1
5182 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
5183 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
5184 IF(WTI(I).LT.1D-6) GOTO 110
5190 C...Find shape of multiplicity distribution above maximum.
5192 DO 120 I=INAVE+1,200
5193 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
5194 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
5195 IF(WTI(I).LT.1D-6) GOTO 130
5202 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
5203 & WTS/(WTS+WTI(1)/XNAVE)
5204 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
5205 IF(MSTP(133).GE.2) VINT(134)=XNAVE
5207 C...Pick multiplicity of pileup events.
5209 IF(MSTP(133).LE.0) THEN
5210 MINT(81)=MAX(1,MSTP(134))
5216 IF(WTR.LE.0D0) GOTO 150
5222 C...Format statement for error message.
5223 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
5224 &'crossing too large, ',1P,D12.4)
5229 C*********************************************************************
5231 *$ CREATE PYSAVE.FOR
5234 C...Saves and restores parameter and cross section values for the
5235 C...3 gamma-p and 6 gamma-gamma alnternatives. Also makes random
5236 C...choice between alternatives.
5238 SUBROUTINE PYSAVE(ISAVE,IGA)
5240 C...Double precision and integer declarations.
5241 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5242 INTEGER PYK,PYCHGE,PYCOMP
5244 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5245 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5246 COMMON/PYINT1/MINT(400),VINT(400)
5247 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5248 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5249 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/
5250 C...Local arrays and saved variables.
5251 DIMENSION NCP(10),NSUBCP(10,20),MSUBCP(10,20),COEFCP(10,20,20),
5252 &NGENCP(10,0:20,3),XSECCP(10,0:20,3),INTCP(10,20),RECP(10,20)
5253 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,INTCP,RECP
5255 C...Save list of subprocesses and cross-section information.
5259 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
5262 MSUBCP(IGA,ICP)=MSUB(I)
5264 COEFCP(IGA,ICP,J)=COEF(I,J)
5267 NGENCP(IGA,ICP,J)=NGEN(I,J)
5268 XSECCP(IGA,ICP,J)=XSEC(I,J)
5273 NGENCP(IGA,0,J)=NGEN(0,J)
5274 XSECCP(IGA,0,J)=XSEC(0,J)
5276 C...Save various common process variables.
5278 INTCP(IGA,J)=MINT(40+J)
5280 INTCP(IGA,11)=MINT(101)
5281 INTCP(IGA,12)=MINT(102)
5282 INTCP(IGA,13)=MINT(107)
5283 INTCP(IGA,14)=MINT(108)
5284 INTCP(IGA,15)=MINT(123)
5287 C...Save cross-section information only.
5288 ELSEIF(ISAVE.EQ.2) THEN
5289 DO 160 ICP=1,NCP(IGA)
5292 NGENCP(IGA,ICP,J)=NGEN(I,J)
5293 XSECCP(IGA,ICP,J)=XSEC(I,J)
5297 NGENCP(IGA,0,J)=NGEN(0,J)
5298 XSECCP(IGA,0,J)=XSEC(0,J)
5301 C...Choose between allowed alternatives.
5302 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
5305 DO 180 IG=1,MINT(121)
5306 XSUMCP=XSUMCP+XSECCP(IG,0,1)
5308 XSUMCP=XSUMCP*PYR(0)
5309 DO 190 IG=1,MINT(121)
5311 XSUMCP=XSUMCP-XSECCP(IG,0,1)
5312 IF(XSUMCP.LE.0D0) GOTO 200
5317 C...Restore cross-section information.
5321 DO 240 ICP=1,NCP(IGA)
5323 MSUB(I)=MSUBCP(IGA,ICP)
5325 COEF(I,J)=COEFCP(IGA,ICP,J)
5328 NGEN(I,J)=NGENCP(IGA,ICP,J)
5329 XSEC(I,J)=XSECCP(IGA,ICP,J)
5333 NGEN(0,J)=NGENCP(IGA,0,J)
5334 XSEC(0,J)=XSECCP(IGA,0,J)
5337 C...Restore various common process variables.
5339 MINT(40+J)=INTCP(IGA,J)
5341 MINT(101)=INTCP(IGA,11)
5342 MINT(102)=INTCP(IGA,12)
5343 MINT(107)=INTCP(IGA,13)
5344 MINT(108)=INTCP(IGA,14)
5345 MINT(123)=INTCP(IGA,15)
5349 C...Sum up cross-section info (for PYSTAT).
5350 ELSEIF(ISAVE.EQ.5) THEN
5361 DO 290 IG=1,MINT(121)
5362 DO 280 ICP=1,NCP(IG)
5364 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
5365 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
5366 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
5367 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
5369 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
5370 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
5371 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
5372 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
5379 C*********************************************************************
5381 *$ CREATE PYRAND.FOR
5384 C...Generates quantities characterizing the high-pT scattering at the
5385 C...parton level according to the matrix elements. Chooses incoming,
5386 C...reacting partons, their momentum fractions and one of the possible
5391 C...Double precision and integer declarations.
5392 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5393 INTEGER PYK,PYCHGE,PYCOMP
5394 C...Parameter statement to help give large particle numbers.
5395 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
5397 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5398 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5399 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
5400 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5401 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5402 COMMON/PYINT1/MINT(400),VINT(400)
5403 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5404 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5405 COMMON/PYINT4/MWID(500),WIDS(500,5)
5406 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5407 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5408 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
5409 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5410 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5411 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/PYMSSM/
5413 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
5415 C...Parameters and data used in elastic/diffractive treatment.
5416 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
5417 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5419 C...Initial values, specifically for (first) semihard interaction.
5426 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
5432 C...Choice of process type - first event of pileup.
5433 IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
5435 C...For gamma-p or gamma-gamma first pick between alternatives.
5436 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
5439 C...For gamma + gamma with different nature, flip at random.
5440 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
5441 & PYR(0).GT.0.5D0) THEN
5451 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
5454 C...Pick process type.
5455 RSUB=XSEC(0,1)*PYR(0)
5457 IF(MSUB(I).NE.1) GOTO 110
5460 IF(RSUB.LE.0D0) GOTO 120
5462 120 IF(ISUB.EQ.95) ISUB=96
5463 IF(ISUB.EQ.96) CALL PYMULT(2)
5465 C...Choice of inclusive process type - pileup events.
5466 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
5467 RSUB=VINT(131)*PYR(0)
5469 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
5470 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
5471 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
5472 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
5474 IF(ISUB.EQ.96) CALL PYMULT(2)
5476 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
5477 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
5478 IF(ISUB.EQ.96.AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
5479 &NGEN(97,1)=NGEN(97,1)+1
5483 C...Random choice of flavour for some SUSY processes.
5484 IF(ISUB.GE.201.AND.ISUB.LE.280) THEN
5485 C...~e_L ~nu_e or ~mu_L ~nu_mu.
5486 IF(ISUB.EQ.210) THEN
5487 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
5488 KFPR(ISUB,2)=KFPR(ISUB,1)+1
5489 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
5490 ELSEIF(ISUB.EQ.213) THEN
5491 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
5492 KFPR(ISUB,2)=KFPR(ISUB,1)
5493 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
5494 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
5495 IF(MOD(ISUB,2).EQ.0) THEN
5496 KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5498 KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5500 C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b.
5501 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
5502 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
5505 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
5508 ELSEIF(PYR(0).LT.0.5D0) THEN
5515 KFPR(ISUB,1)=KSU1+1+INT(5D0*PYR(0))
5516 KFPR(ISUB,2)=KSU2+1+INT(5D0*PYR(0))
5517 C...~q ~q(bar); ~q = ~d, ~u, ~s, ~c or ~b.
5518 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
5519 KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5520 KFPR(ISUB,2)=KFPR(ISUB,1)
5521 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
5522 KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5523 KFPR(ISUB,2)=KFPR(ISUB,1)
5527 C...Find resonances (explicit or implicit in cross-section).
5530 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5532 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
5533 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5535 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
5538 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5540 IF(MSTP(46).EQ.5) THEN
5543 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5545 ELSEIF(ISUB.EQ.194) THEN
5549 IF(CKMX.LE.0D0) CKMX=VINT(1)
5552 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5553 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5556 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5557 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5563 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
5565 IF(ISUB.EQ.194) KFR2=56
5567 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5568 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5569 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5570 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5571 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5576 ELSEIF(KFR2.NE.0) THEN
5587 C...Find product masses and minimum pT of process,
5588 C...optionally with broadening according to a truncated Breit-Wigner.
5593 IF(MINT(82).GE.2) VINT(71)=0D0
5595 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5599 IF(KFPR(ISUB,I).EQ.0) THEN
5600 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5602 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5605 C...This prevents SUSY/t particles from becoming too light.
5607 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5610 DO 130 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5611 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5612 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5613 & PMAS(PYCOMP(KFDP(IDC,2)),1)
5614 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5615 & PMAS(PYCOMP(KFDP(IDC,3)),1)
5616 PMMN(I)=MIN(PMMN(I),PMSUM)
5619 ELSEIF(KFLW.EQ.6) THEN
5620 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5627 CKIN(41)=MAX(PMMN(1),CKIN(41))
5628 CKIN(43)=MAX(PMMN(2),CKIN(43))
5629 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5632 IF(MINT(51).EQ.1) THEN
5633 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5643 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
5644 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5647 C...Prepare for additional variable choices in 2 -> 3.
5650 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5652 VINT(204)=PMAS(23,1)
5653 IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
5654 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
5655 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5659 C...Select incoming VDM particle (rho/omega/phi/J/psi).
5660 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
5661 &(MINT(123).EQ.2.OR.MINT(123).EQ.5.OR.MINT(123).EQ.7)) THEN
5662 VRN=PYR(0)*SIGT(0,0,5)
5663 IF(MINT(101).LE.1) THEN
5670 IF(MINT(102).LE.1) THEN
5681 VRN=VRN-SIGT(I1,I2,5)
5682 IF(VRN.LE.0D0) GOTO 170
5685 170 IF(MINT(101).GE.2) MINT(103)=KFV1
5686 IF(MINT(102).GE.2) MINT(104)=KFV2
5690 C...Elastic scattering or single or double diffractive scattering.
5692 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
5697 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
5699 VRN=PYR(0)*SIGT(0,0,JJ)
5700 IF(MINT(101).LE.1) THEN
5707 IF(MINT(102).LE.1) THEN
5718 VRN=VRN-SIGT(I1,I2,JJ)
5719 IF(VRN.LE.0D0) GOTO 200
5722 200 IF(MINT(101).GE.2) THEN
5726 IF(MINT(102).GE.2) THEN
5732 C...Side/sides of diffractive system.
5735 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
5736 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
5738 C...Find masses of particles and minimal masses of diffractive states.
5741 VINT(66+JT)=PDIF(JT)
5742 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
5749 SMRES1=(PMM(1)+PMRC)**2
5750 SMRES2=(PMM(2)+PMRC)**2
5752 C...Find elastic slope and lower limit diffractive slope.
5753 IHA=MAX(2,IABS(MINT(103))/110)
5755 IHB=MAX(2,IABS(MINT(104))/110)
5758 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
5759 ELSEIF(ISUB.EQ.92) THEN
5760 BMN=MAX(2D0,2D0*BHAD(IHB))
5761 ELSEIF(ISUB.EQ.93) THEN
5762 BMN=MAX(2D0,2D0*BHAD(IHA))
5763 ELSEIF(ISUB.EQ.94) THEN
5767 C...Determine maximum possible t range and coefficient of generation.
5768 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
5769 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5770 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5771 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5772 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5773 & (SQM1*SQM4-SQM2*SQM3)/SH
5774 THL=-0.5D0*(THA+THB)
5776 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
5778 C...Select diffractive mass/masses according to dm^2/m^2.
5780 IF(MINT(16+JT).EQ.0) THEN
5784 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
5785 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
5791 C..Additional mass factors, including resonance enhancement.
5792 IF(PDIF(3)+PDIF(4).GE.VINT(1)) GOTO 220
5794 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
5795 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5796 ELSEIF(ISUB.EQ.93) THEN
5797 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
5798 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5799 ELSEIF(ISUB.EQ.94) THEN
5800 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
5801 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
5802 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
5803 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 220
5806 C...Select t according to exp(Bmn*t) and correct to right slope.
5807 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
5810 BADD=2D0*ALP*LOG(SH/SQM3)
5811 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
5812 ELSEIF(ISUB.EQ.93) THEN
5813 BADD=2D0*ALP*LOG(SH/SQM4)
5814 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
5815 ELSEIF(ISUB.EQ.94) THEN
5816 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
5818 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 220
5821 C...Check whether m^2 and t choices are consistent.
5822 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5823 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5824 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5825 IF(THB.LE.1D-8) GOTO 220
5826 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5827 & (SQM1*SQM4-SQM2*SQM3)/SH
5828 THLM=-0.5D0*(THA+THB)
5830 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 220
5832 C...Information to output.
5835 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
5837 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
5841 C...Note: in the following, by In is meant the integral over the
5842 C...quantity multiplying coefficient cn.
5843 C...Choose tau according to h1(tau)/tau, where
5844 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
5845 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
5846 C...I1/I5*c5*1/(tau+tau_R') +
5847 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
5848 C...I1/I7*c7*tau/(1.-tau), and
5849 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
5850 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
5852 IF(MINT(51).NE.0) THEN
5853 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5862 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
5863 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
5864 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
5865 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
5867 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5868 & COEF(ISUB,5)) MTAU=6
5869 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5870 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
5871 CALL PYKMAP(1,MTAU,PYR(0))
5873 C...2 -> 3, 4 processes:
5874 C...Choose tau' according to h4(tau,tau')/tau', where
5875 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
5876 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
5877 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5879 IF(MINT(51).NE.0) THEN
5880 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5889 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
5890 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
5891 CALL PYKMAP(4,MTAUP,PYR(0))
5894 C...Choose y* according to h2(y*), where
5895 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
5896 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
5897 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
5898 C...and c1 + c2 + c3 + c4 + c5 = 1.
5900 IF(MINT(51).NE.0) THEN
5901 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5910 IF(RYST.GT.COEF(ISUB,8)) MYST=2
5911 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
5912 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
5913 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
5914 & COEF(ISUB,11)) MYST=5
5915 CALL PYKMAP(2,MYST,PYR(0))
5917 C...2 -> 2 processes:
5918 C...Choose cos(theta-hat) (cth) according to h3(cth), where
5919 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
5920 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
5921 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
5922 C...and c0 + c1 + c2 + c3 + c4 = 1.
5924 IF(MINT(51).NE.0) THEN
5925 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5932 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5935 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
5936 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
5937 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
5938 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
5939 & COEF(ISUB,16)) MCTH=5
5940 CALL PYKMAP(3,MCTH,PYR(0))
5943 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
5945 CALL PYKMAP(5,0,0D0)
5946 IF(MINT(51).NE.0) THEN
5947 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5956 C...Low-pT or multiple interactions (first semihard interaction).
5957 ELSEIF(ISTSB.EQ.9) THEN
5961 C...Generate user-defined process: kinematics plus weight.
5962 ELSEIF(ISTSB.EQ.11) THEN
5964 CALL PYUPEV(ISUB,SIGS)
5968 IF(MINT(82).EQ.1) THEN
5969 NGEN(0,1)=NGEN(0,1)-1
5970 NGEN(0,2)=NGEN(0,2)-1
5971 NGEN(ISUB,1)=NGEN(ISUB,1)-1
5973 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5977 C...Construct 'trivial' kinematical variables needed.
5980 VINT(41)=2D0*PUP(1,4)/VINT(1)
5981 VINT(42)=2D0*PUP(2,4)/VINT(1)
5982 VINT(21)=VINT(41)*VINT(42)
5983 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
5984 VINT(44)=VINT(21)*VINT(2)
5985 VINT(43)=SQRT(MAX(0D0,VINT(44)))
5987 VINT(55)=SQRT(MAX(0D0,VINT(56)))
5989 C...Construct other kinematical variables needed (approximately).
5992 VINT(45)=-0.5D0*VINT(44)
5993 VINT(46)=-0.5D0*VINT(44)
6003 IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+
6004 & PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(1)
6005 IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+
6008 VINT(47)=SQRT(VINT(48))
6010 C...Calculate parton distribution weights.
6011 IF(MINT(47).GE.2) THEN
6012 DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
6013 MINT(105)=MINT(102+I)
6014 MINT(109)=MINT(106+I)
6015 IF(MSTP(57).LE.1) THEN
6016 CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
6018 CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
6021 XSFX(I,KFL)=XPQ(KFL)
6027 C...Choose azimuthal angle.
6028 VINT(24)=PARU(2)*PYR(0)
6030 C...Check against user cuts on kinematics at parton level.
6032 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
6033 IF(MINT(51).NE.0) THEN
6034 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6041 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
6043 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
6046 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6055 C...Calculate differential cross-section for different subprocesses.
6056 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
6060 C...Multiply cross-section by user-defined weights.
6061 IF(MSTP(173).EQ.1) THEN
6064 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
6066 SIGLPT=PARP(173)*SIGLPT
6072 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
6073 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
6074 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
6077 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
6080 C...Calculations for Monte Carlo estimate of all cross-sections.
6081 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
6082 IF(MSTP(142).LE.1) THEN
6083 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6085 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
6087 ELSEIF(MINT(82).EQ.1) THEN
6088 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6090 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
6091 &XSEC(97,2)=XSEC(97,2)+SIGLPT
6093 C...Multiple interactions: store results of cross-section calculation.
6094 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
6099 C...Check that weight not negative.
6100 VIOL=SIGSWT/XSEC(ISUB,1)
6101 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
6102 IF(MSTP(123).LE.0) THEN
6103 IF(VIOL.LT.-1D-3) THEN
6104 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
6105 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6106 & VINT(22),VINT(23),VINT(26)
6110 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
6112 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
6113 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6114 & VINT(22),VINT(23),VINT(26)
6118 C...Weighting using estimate of maximum of differential cross-section.
6120 IF(VIOL.LT.PYR(0)) THEN
6121 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6124 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
6125 IF(VIOL.LT.PYR(0)) THEN
6127 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6131 RATND=SIGLPT/XSEC(95,1)
6132 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
6134 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6138 IF(VIOL.LT.PYR(0)) THEN
6139 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6144 C...Check for possible violation of estimated maximum of differential
6145 C...cross-section used in weighting.
6146 IF(MSTP(123).LE.0) THEN
6147 IF(VIOL.GT.1D0) THEN
6148 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
6149 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6150 & VINT(22),VINT(23),VINT(26)
6153 ELSEIF(MSTP(123).EQ.1) THEN
6154 IF(VIOL.GT.VINT(108)) THEN
6156 IF(VIOL.GT.1D0) THEN
6158 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6159 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6160 & VINT(22),VINT(23),VINT(26)
6163 ELSEIF(VIOL.GT.VINT(108)) THEN
6165 IF(VIOL.GT.1D0) THEN
6167 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
6168 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
6169 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
6170 & XSEC(0,1)=XSEC(0,1)+XDIF
6171 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6172 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6173 & VINT(22),VINT(23),VINT(26)
6175 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
6176 ELSEIF(ISUB.LE.99) THEN
6177 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
6179 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
6185 C...Multiple interactions: choose impact parameter.
6187 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
6188 &MSTP(82).GE.3) THEN
6190 IF(VINT(150).LT.PYR(0)) THEN
6191 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6199 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
6200 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
6201 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
6202 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
6204 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
6206 C...Choose flavour of reacting partons (and subprocess).
6207 IF(ISTSB.GE.11) GOTO 290
6210 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
6211 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
6212 &PYR(0).GT.RQQBAR)) THEN
6216 MINT(2)=ISIG(ICHN,3)
6217 RSIGS=RSIGS-SIGH(ICHN)
6218 IF(RSIGS.LE.0D0) GOTO 290
6221 C...Multiple interactions: choose qqbar preferentially at small pT.
6222 ELSEIF(ISUB.EQ.96) THEN
6225 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
6228 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
6231 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
6233 C...Low-pT: choose string drawing configuration.
6239 IF(RSIGS.GT.1D0) MINT(2)=2
6240 IF(RSIGS.GT.2D0) MINT(2)=3
6243 C...Reassign QCD process. Partons before initial state radiation.
6244 290 IF(MINT(2).GT.10) THEN
6246 MINT(2)=MOD(MINT(2),10)
6248 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
6259 C...Calculate x value of photon for parton inside photon inside e.
6264 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
6265 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
6266 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
6271 MINT(105)=MINT(102+JT)
6272 MINT(109)=MINT(106+JT)
6273 IF(MSTP(57).LE.1) THEN
6274 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
6276 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
6279 IF(MSTP(13).EQ.2) THEN
6280 Q2PMS=Q2HRD/PMAS(11,1)**2
6281 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
6284 XG=MIN(0.999999D0,XHRD/XE)
6285 IF(MSTP(57).LE.1) THEN
6286 CALL PYPDFU(22,XG,Q2HRD,XPQ)
6288 CALL PYPDFL(22,XG,Q2HRD,XPQ)
6290 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
6291 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
6292 IF(WT.LT.PYR(0)*WTMX) GOTO 300
6296 XSFX(JT,KFLS)=XPQ(KFLS)
6301 C...Pick scale where photon is resolved.
6302 IF(MINT(107).EQ.3) VINT(283)=PARP(15)**2*
6303 &(VINT(54)/PARP(15)**2)**PYR(0)
6304 IF(MINT(108).EQ.3) VINT(284)=PARP(15)**2*
6305 &(VINT(54)/PARP(15)**2)**PYR(0)
6306 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6308 C...Format statements for differential cross-section maximum violations.
6309 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
6310 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6311 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
6312 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
6313 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
6315 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
6316 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6317 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
6319 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
6320 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
6321 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
6326 C*********************************************************************
6328 *$ CREATE PYSCAT.FOR
6331 C...Finds outgoing flavours and event type; sets up the kinematics
6332 C...and colour flow of the hard scattering
6336 C...Double precision and integer declarations
6337 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6338 INTEGER PYK,PYCHGE,PYCOMP
6339 C...Parameter statement to help give large particle numbers.
6340 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
6342 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6343 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6344 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6345 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
6346 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6347 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6348 COMMON/PYINT1/MINT(400),VINT(400)
6349 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6350 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6351 COMMON/PYINT4/MWID(500),WIDS(500,5)
6352 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6353 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
6354 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
6356 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
6357 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/
6358 C...Local arrays and saved variables
6359 DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2),
6360 &PHI(2),KUPPO(20),VINTSV(41:66)
6363 C...Read out process
6367 C...Restore information for low-pT processes
6368 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
6370 100 VINT(J)=VINTSV(J)
6373 C...Convert H' or A process into equivalent H one
6376 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
6379 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
6381 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
6382 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
6383 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
6384 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
6385 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
6386 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
6387 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
6388 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
6389 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
6392 C...Choice of subprocess, number of documentation lines
6394 IF(ISUB.EQ.95) IDOC=8
6395 IF(ISET(ISUB).EQ.5) IDOC=9
6396 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
6398 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
6407 C...Reset K, P and V vectors. Store incoming particles
6408 DO 120 JT=1,MSTP(126)+20
6421 P(I,J)=VINT(285+5*JT+J)
6427 C...Store incoming partons in their CM-frame
6430 SHP=VINT(26)*VINT(2)
6433 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
6438 K(I,3)=MINT(83)+2+JT
6439 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
6443 C...Copy incoming partons to documentation lines
6455 C...Choose new quark/lepton flavour for relevant annihilation graphs
6456 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58) THEN
6458 IF(ISUB.EQ.58) IGLGA=22
6459 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
6460 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
6461 DO 190 I=1,MDCY(IGLGA,3)
6462 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
6463 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
6464 IF(RKFL.LE.0D0) GOTO 200
6467 IF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
6468 & IABS(KFLF).GE.3) THEN
6469 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
6471 FACCIB=VINT(46)**2/PARU(155)**4
6472 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
6473 ELSEIF(ISUB.EQ.54) THEN
6474 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
6475 ELSEIF(ISUB.EQ.58) THEN
6476 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
6480 C...Final state flavours and colour flow: default values
6487 KCS=ISIGN(1,MINT(15))
6489 IF(ISET(ISUB).EQ.11) THEN
6490 C...User-defined processes: find products
6493 IF(KUP(IUP,1).NE.1) THEN
6494 ELSEIF(IRUP.LE.5) THEN
6496 MINT(20+IRUP)=KUP(IUP,2)
6500 ELSEIF(ISUB.LE.10) THEN
6502 C...f + fbar -> gamma*/Z0
6505 ELSEIF(ISUB.EQ.2) THEN
6506 C...f + fbar' -> W+/-
6507 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6508 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6509 KFRES=ISIGN(24,KCH1+KCH2)
6511 ELSEIF(ISUB.EQ.3) THEN
6512 C...f + fbar -> h0 (or H0, or A0)
6515 ELSEIF(ISUB.EQ.4) THEN
6516 C...gamma + W+/- -> W+/-
6518 ELSEIF(ISUB.EQ.5) THEN
6523 PMQ(1)=PYMASS(MINT(21))
6524 PMQ(2)=PYMASS(MINT(22))
6525 220 JT=INT(1.5D0+PYR(0))
6526 ZMIN=2D0*PMQ(JT)/SHPR
6527 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6528 & (SHPR*(SHPR-PMQ(3-JT)))
6529 ZMAX=MIN(1D0-XH,ZMAX)
6530 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6531 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6532 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
6533 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6534 IF(SQC1.LT.1.D-8) GOTO 220
6536 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6537 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6538 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6539 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6540 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6541 IF(SQC1.LT.1.D-8) GOTO 220
6543 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6544 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6545 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6548 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6549 & SQRT(1D0-CTHE(2)**2)*CPHI
6551 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6552 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6553 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6554 & PMQ(3-JT)**2/SHP))
6555 ZMIN=2D0*PMQ(3-JT)/SHPR
6556 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6557 ZMAX=MIN(1D0-XH,ZMAX)
6558 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
6562 ELSEIF(ISUB.EQ.6) THEN
6563 C...Z0 + W+/- -> W+/-
6565 ELSEIF(ISUB.EQ.7) THEN
6568 ELSEIF(ISUB.EQ.8) THEN
6575 RVCKM=VINT(180+I)*PYR(0)
6578 IPM=(5-ISIGN(1,I))/2
6580 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
6581 MINT(20+JT)=ISIGN(IB,I)
6582 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6583 IF(RVCKM.LE.0D0) GOTO 250
6586 IB=2*((IA+1)/2)-1+MOD(IA,2)
6587 MINT(20+JT)=ISIGN(IB,I)
6589 250 PMQ(JT)=PYMASS(MINT(20+JT))
6591 JT=INT(1.5D0+PYR(0))
6592 ZMIN=2D0*PMQ(JT)/SHPR
6593 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6594 & (SHPR*(SHPR-PMQ(3-JT)))
6595 ZMAX=MIN(1D0-XH,ZMAX)
6596 IF(ZMIN.GE.ZMAX) GOTO 230
6597 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6598 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6599 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
6600 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6601 IF(SQC1.LT.1.D-8) GOTO 230
6603 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6604 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6605 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6606 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6607 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6608 IF(SQC1.LT.1.D-8) GOTO 230
6610 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6611 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6612 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6615 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6616 & SQRT(1D0-CTHE(2)**2)*CPHI
6618 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6619 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6620 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6621 & PMQ(3-JT)**2/SHP))
6622 ZMIN=2D0*PMQ(3-JT)/SHPR
6623 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6624 ZMAX=MIN(1D0-XH,ZMAX)
6625 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
6629 ELSEIF(ISUB.EQ.10) THEN
6630 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
6631 IF(MINT(2).EQ.1) THEN
6634 C...W exchange: need to mix flavours according to CKM matrix
6639 RVCKM=VINT(180+I)*PYR(0)
6642 IPM=(5-ISIGN(1,I))/2
6644 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
6645 MINT(20+JT)=ISIGN(IB,I)
6646 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6647 IF(RVCKM.LE.0D0) GOTO 280
6650 IB=2*((IA+1)/2)-1+MOD(IA,2)
6651 MINT(20+JT)=ISIGN(IB,I)
6658 ELSEIF(ISUB.LE.20) THEN
6660 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
6662 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
6664 ELSEIF(ISUB.EQ.12) THEN
6665 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
6666 MINT(21)=ISIGN(KFLF,MINT(15))
6670 ELSEIF(ISUB.EQ.13) THEN
6671 C...f + fbar -> g + g; th arbitrary
6676 ELSEIF(ISUB.EQ.14) THEN
6677 C...f + fbar -> g + gamma; th arbitrary
6678 IF(PYR(0).GT.0.5D0) JS=2
6683 ELSEIF(ISUB.EQ.15) THEN
6684 C...f + fbar -> g + Z0; th arbitrary
6685 IF(PYR(0).GT.0.5D0) JS=2
6690 ELSEIF(ISUB.EQ.16) THEN
6691 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6692 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6693 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6694 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6696 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6699 ELSEIF(ISUB.EQ.17) THEN
6700 C...f + fbar -> g + h0; th arbitrary
6701 IF(PYR(0).GT.0.5D0) JS=2
6706 ELSEIF(ISUB.EQ.18) THEN
6707 C...f + fbar -> gamma + gamma; th arbitrary
6711 ELSEIF(ISUB.EQ.19) THEN
6712 C...f + fbar -> gamma + Z0; th arbitrary
6713 IF(PYR(0).GT.0.5D0) JS=2
6717 ELSEIF(ISUB.EQ.20) THEN
6718 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
6719 C...(p(fbar')-p(W+))**2
6720 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6721 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6722 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6724 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6727 ELSEIF(ISUB.LE.30) THEN
6729 C...f + fbar -> gamma + h0; th arbitrary
6730 IF(PYR(0).GT.0.5D0) JS=2
6734 ELSEIF(ISUB.EQ.22) THEN
6735 C...f + fbar -> Z0 + Z0; th arbitrary
6739 ELSEIF(ISUB.EQ.23) THEN
6740 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6741 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6742 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6743 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6745 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6747 ELSEIF(ISUB.EQ.24) THEN
6748 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
6749 IF(PYR(0).GT.0.5D0) JS=2
6753 ELSEIF(ISUB.EQ.25) THEN
6754 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
6755 MINT(21)=-ISIGN(24,MINT(15))
6758 ELSEIF(ISUB.EQ.26) THEN
6759 C...f + fbar' -> W+/- + h0 (or H0, or A0);
6760 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6761 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6762 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6763 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
6764 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
6767 ELSEIF(ISUB.EQ.27) THEN
6768 C...f + fbar -> h0 + h0
6770 ELSEIF(ISUB.EQ.28) THEN
6771 C...f + g -> f + g; th = (p(f)-p(f))**2
6773 IF(MINT(15).EQ.21) KCC=KCC+2
6774 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
6775 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
6777 ELSEIF(ISUB.EQ.29) THEN
6778 C...f + g -> f + gamma; th = (p(f)-p(f))**2
6779 IF(MINT(15).EQ.21) JS=2
6782 KCS=ISIGN(1,MINT(14+JS))
6784 ELSEIF(ISUB.EQ.30) THEN
6785 C...f + g -> f + Z0; th = (p(f)-p(f))**2
6786 IF(MINT(15).EQ.21) JS=2
6789 KCS=ISIGN(1,MINT(14+JS))
6792 ELSEIF(ISUB.LE.40) THEN
6794 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
6795 IF(MINT(15).EQ.21) JS=2
6798 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6799 RVCKM=VINT(180+I)*PYR(0)
6802 IPM=(5-ISIGN(1,I))/2
6804 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
6805 MINT(20+JS)=ISIGN(IB,I)
6806 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6807 IF(RVCKM.LE.0D0) GOTO 300
6810 KCS=ISIGN(1,MINT(14+JS))
6812 ELSEIF(ISUB.EQ.32) THEN
6813 C...f + g -> f + h0; th = (p(f)-p(f))**2
6814 IF(MINT(15).EQ.21) JS=2
6817 KCS=ISIGN(1,MINT(14+JS))
6819 ELSEIF(ISUB.EQ.33) THEN
6820 C...f + gamma -> f + g; th=(p(f)-p(f))**2
6821 IF(MINT(15).EQ.22) JS=2
6824 KCS=ISIGN(1,MINT(14+JS))
6826 ELSEIF(ISUB.EQ.34) THEN
6827 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
6828 IF(MINT(15).EQ.22) JS=2
6830 KCS=ISIGN(1,MINT(14+JS))
6832 ELSEIF(ISUB.EQ.35) THEN
6833 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
6834 IF(MINT(15).EQ.22) JS=2
6838 ELSEIF(ISUB.EQ.36) THEN
6839 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
6840 IF(MINT(15).EQ.22) JS=2
6843 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6845 RVCKM=VINT(180+I)*PYR(0)
6848 IPM=(5-ISIGN(1,I))/2
6850 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
6851 MINT(20+JS)=ISIGN(IB,I)
6852 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6853 IF(RVCKM.LE.0D0) GOTO 320
6856 IB=2*((IA+1)/2)-1+MOD(IA,2)
6857 MINT(20+JS)=ISIGN(IB,I)
6861 ELSEIF(ISUB.EQ.37) THEN
6862 C...f + gamma -> f + h0
6864 ELSEIF(ISUB.EQ.38) THEN
6867 ELSEIF(ISUB.EQ.39) THEN
6868 C...f + Z0 -> f + gamma
6870 ELSEIF(ISUB.EQ.40) THEN
6871 C...f + Z0 -> f + Z0
6874 ELSEIF(ISUB.LE.50) THEN
6876 C...f + Z0 -> f' + W+/-
6878 ELSEIF(ISUB.EQ.42) THEN
6879 C...f + Z0 -> f + h0
6881 ELSEIF(ISUB.EQ.43) THEN
6882 C...f + W+/- -> f' + g
6884 ELSEIF(ISUB.EQ.44) THEN
6885 C...f + W+/- -> f' + gamma
6887 ELSEIF(ISUB.EQ.45) THEN
6888 C...f + W+/- -> f' + Z0
6890 ELSEIF(ISUB.EQ.46) THEN
6891 C...f + W+/- -> f' + W+/-
6893 ELSEIF(ISUB.EQ.47) THEN
6894 C...f + W+/- -> f' + h0
6896 ELSEIF(ISUB.EQ.48) THEN
6899 ELSEIF(ISUB.EQ.49) THEN
6900 C...f + h0 -> f + gamma
6902 ELSEIF(ISUB.EQ.50) THEN
6903 C...f + h0 -> f + Z0
6906 ELSEIF(ISUB.LE.60) THEN
6908 C...f + h0 -> f' + W+/-
6910 ELSEIF(ISUB.EQ.52) THEN
6911 C...f + h0 -> f + h0
6913 ELSEIF(ISUB.EQ.53) THEN
6914 C...g + g -> f + fbar; th arbitrary
6915 KCS=(-1)**INT(1.5D0+PYR(0))
6916 MINT(21)=ISIGN(KFLF,KCS)
6920 ELSEIF(ISUB.EQ.54) THEN
6921 C...g + gamma -> f + fbar; th arbitrary
6922 KCS=(-1)**INT(1.5D0+PYR(0))
6923 MINT(21)=ISIGN(KFLF,KCS)
6926 IF(MINT(16).EQ.21) KCC=28
6928 ELSEIF(ISUB.EQ.55) THEN
6929 C...g + Z0 -> f + fbar
6931 ELSEIF(ISUB.EQ.56) THEN
6932 C...g + W+/- -> f + fbar'
6934 ELSEIF(ISUB.EQ.57) THEN
6935 C...g + h0 -> f + fbar
6937 ELSEIF(ISUB.EQ.58) THEN
6938 C...gamma + gamma -> f + fbar; th arbitrary
6939 KCS=(-1)**INT(1.5D0+PYR(0))
6940 MINT(21)=ISIGN(KFLF,KCS)
6944 ELSEIF(ISUB.EQ.59) THEN
6945 C...gamma + Z0 -> f + fbar
6947 ELSEIF(ISUB.EQ.60) THEN
6948 C...gamma + W+/- -> f + fbar'
6951 ELSEIF(ISUB.LE.70) THEN
6953 C...gamma + h0 -> f + fbar
6955 ELSEIF(ISUB.EQ.62) THEN
6956 C...Z0 + Z0 -> f + fbar
6958 ELSEIF(ISUB.EQ.63) THEN
6959 C...Z0 + W+/- -> f + fbar'
6961 ELSEIF(ISUB.EQ.64) THEN
6962 C...Z0 + h0 -> f + fbar
6964 ELSEIF(ISUB.EQ.65) THEN
6965 C...W+ + W- -> f + fbar
6967 ELSEIF(ISUB.EQ.66) THEN
6968 C...W+/- + h0 -> f + fbar'
6970 ELSEIF(ISUB.EQ.67) THEN
6971 C...h0 + h0 -> f + fbar
6973 ELSEIF(ISUB.EQ.68) THEN
6974 C...g + g -> g + g; th arbitrary
6976 KCS=(-1)**INT(1.5D0+PYR(0))
6978 ELSEIF(ISUB.EQ.69) THEN
6979 C...gamma + gamma -> W+ + W-; th arbitrary
6984 ELSEIF(ISUB.EQ.70) THEN
6985 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
6986 IF(MINT(15).EQ.22) MINT(21)=23
6987 IF(MINT(16).EQ.22) MINT(22)=23
6991 ELSEIF(ISUB.LE.80) THEN
6992 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
6993 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
6997 PMQ(1)=PYMASS(MINT(21))
6998 PMQ(2)=PYMASS(MINT(22))
6999 330 JT=INT(1.5D0+PYR(0))
7000 ZMIN=2D0*PMQ(JT)/SHPR
7001 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7002 & (SHPR*(SHPR-PMQ(3-JT)))
7003 ZMAX=MIN(1D0-XH,ZMAX)
7004 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7005 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7006 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
7007 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7008 IF(SQC1.LT.1.D-8) GOTO 330
7010 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7011 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7012 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7013 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7014 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7015 IF(SQC1.LT.1.D-8) GOTO 330
7017 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7018 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7019 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7022 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7023 & SQRT(1D0-CTHE(2)**2)*CPHI
7025 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7026 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7027 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7028 & PMQ(3-JT)**2/SHP))
7029 ZMIN=2D0*PMQ(3-JT)/SHPR
7030 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7031 ZMAX=MIN(1D0-XH,ZMAX)
7032 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
7035 ELSEIF(ISUB.EQ.73) THEN
7036 C...Z0 + W+/- -> Z0 + W+/-
7043 RVCKM=VINT(180+I)*PYR(0)
7046 IPM=(5-ISIGN(1,I))/2
7048 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
7049 MINT(20+JT)=ISIGN(IB,I)
7050 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7051 IF(RVCKM.LE.0D0) GOTO 360
7054 IB=2*((IA+1)/2)-1+MOD(IA,2)
7055 MINT(20+JT)=ISIGN(IB,I)
7057 360 PMQ(JT)=PYMASS(MINT(20+JT))
7058 MINT(23-JT)=MINT(17-JT)
7059 PMQ(3-JT)=PYMASS(MINT(23-JT))
7060 JT=INT(1.5D0+PYR(0))
7061 ZMIN=2D0*PMQ(JT)/SHPR
7062 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7063 & (SHPR*(SHPR-PMQ(3-JT)))
7064 ZMAX=MIN(1D0-XH,ZMAX)
7065 IF(ZMIN.GE.ZMAX) GOTO 340
7066 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7067 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7068 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
7069 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7070 IF(SQC1.LT.1.D-8) GOTO 340
7072 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7073 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7074 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7075 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7076 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7077 IF(SQC1.LT.1.D-8) GOTO 340
7079 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7080 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7081 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7084 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7085 & SQRT(1D0-CTHE(2)**2)*CPHI
7087 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7088 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7089 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7090 & PMQ(3-JT)**2/SHP))
7091 ZMIN=2D0*PMQ(3-JT)/SHPR
7092 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7093 ZMAX=MIN(1D0-XH,ZMAX)
7094 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
7097 ELSEIF(ISUB.EQ.74) THEN
7098 C...Z0 + h0 -> Z0 + h0
7100 ELSEIF(ISUB.EQ.75) THEN
7101 C...W+ + W- -> gamma + gamma
7103 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
7104 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
7110 RVCKM=VINT(180+I)*PYR(0)
7113 IPM=(5-ISIGN(1,I))/2
7115 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
7116 MINT(20+JT)=ISIGN(IB,I)
7117 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7118 IF(RVCKM.LE.0D0) GOTO 390
7121 IB=2*((IA+1)/2)-1+MOD(IA,2)
7122 MINT(20+JT)=ISIGN(IB,I)
7124 390 PMQ(JT)=PYMASS(MINT(20+JT))
7126 JT=INT(1.5D0+PYR(0))
7127 ZMIN=2D0*PMQ(JT)/SHPR
7128 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7129 & (SHPR*(SHPR-PMQ(3-JT)))
7130 ZMAX=MIN(1D0-XH,ZMAX)
7131 IF(ZMIN.GE.ZMAX) GOTO 370
7132 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7133 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7134 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
7135 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7136 IF(SQC1.LT.1.D-8) GOTO 370
7138 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7139 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7140 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7141 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7142 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7143 IF(SQC1.LT.1.D-8) GOTO 370
7145 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7146 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7147 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7150 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7151 & SQRT(1D0-CTHE(2)**2)*CPHI
7153 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7154 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7155 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7156 & PMQ(3-JT)**2/SHP))
7157 ZMIN=2D0*PMQ(3-JT)/SHPR
7158 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7159 ZMAX=MIN(1D0-XH,ZMAX)
7160 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
7163 ELSEIF(ISUB.EQ.78) THEN
7164 C...W+/- + h0 -> W+/- + h0
7166 ELSEIF(ISUB.EQ.79) THEN
7167 C...h0 + h0 -> h0 + h0
7169 ELSEIF(ISUB.EQ.80) THEN
7170 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
7171 IF(MINT(15).EQ.22) JS=2
7174 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
7176 MINT(20+JS)=ISIGN(IB,I)
7180 ELSEIF(ISUB.LE.90) THEN
7182 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
7183 MINT(21)=ISIGN(MINT(55),MINT(15))
7187 ELSEIF(ISUB.EQ.82) THEN
7188 C...g + g -> Q + Qbar; th arbitrary
7189 KCS=(-1)**INT(1.5D0+PYR(0))
7190 MINT(21)=ISIGN(MINT(55),KCS)
7194 ELSEIF(ISUB.EQ.83) THEN
7195 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
7197 IF(MINT(2).EQ.2) KFOLD=MINT(15)
7199 IF(KFAOLD.GT.10) THEN
7200 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
7202 RCKM=VINT(180+KFOLD)*PYR(0)
7203 IPM=(5-ISIGN(1,KFOLD))/2
7204 KFANEW=-MOD(KFAOLD+1,2)
7206 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
7207 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
7208 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
7209 & VCKM(KFAOLD/2,(KFANEW+1)/2)
7210 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
7211 & VCKM(KFANEW/2,(KFAOLD+1)/2)
7213 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
7215 IF(MINT(2).EQ.1) THEN
7216 MINT(21)=ISIGN(MINT(55),MINT(15))
7217 MINT(22)=ISIGN(KFANEW,MINT(16))
7219 MINT(21)=ISIGN(KFANEW,MINT(15))
7220 MINT(22)=ISIGN(MINT(55),MINT(16))
7225 ELSEIF(ISUB.EQ.84) THEN
7226 C...g + gamma -> Q + Qbar; th arbitary
7227 KCS=(-1)**INT(1.5D0+PYR(0))
7228 MINT(21)=ISIGN(MINT(55),KCS)
7231 IF(MINT(16).EQ.21) KCC=28
7233 ELSEIF(ISUB.EQ.85) THEN
7234 C...gamma + gamma -> F + Fbar; th arbitary
7235 KCS=(-1)**INT(1.5D0+PYR(0))
7236 MINT(21)=ISIGN(MINT(56),KCS)
7240 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
7241 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
7242 MINT(21)=KFPR(ISUB,1)
7243 MINT(22)=KFPR(ISUB,2)
7245 KCS=(-1)**INT(1.5D0+PYR(0))
7248 ELSEIF(ISUB.LE.100) THEN
7250 C...Low-pT ( = energyless g + g -> g + g)
7252 KCS=(-1)**INT(1.5D0+PYR(0))
7254 ELSEIF(ISUB.EQ.96) THEN
7255 C...Multiple interactions (should be reassigned to QCD process)
7258 ELSEIF(ISUB.LE.110) THEN
7259 IF(ISUB.EQ.101) THEN
7260 C...g + g -> gamma*/Z0
7264 ELSEIF(ISUB.EQ.102) THEN
7265 C...g + g -> h0 (or H0, or A0)
7269 ELSEIF(ISUB.EQ.103) THEN
7270 C...gamma + gamma -> h0 (or H0, or A0)
7274 ELSEIF(ISUB.EQ.106) THEN
7275 C...g + g -> J/Psi + gamma
7276 MINT(21)=KFPR(ISUB,1)
7277 MINT(22)=KFPR(ISUB,2)
7280 ELSEIF(ISUB.EQ.107) THEN
7281 C...g + gamma -> J/Psi + g
7282 MINT(21)=KFPR(ISUB,1)
7283 MINT(22)=KFPR(ISUB,2)
7285 IF(MINT(16).EQ.22) KCC=33
7287 ELSEIF(ISUB.EQ.108) THEN
7288 C...gamma + gamma -> J/Psi + gamma
7289 MINT(21)=KFPR(ISUB,1)
7290 MINT(22)=KFPR(ISUB,2)
7292 ELSEIF(ISUB.EQ.110) THEN
7293 C...f + fbar -> gamma + h0; th arbitrary
7294 IF(PYR(0).GT.0.5D0) JS=2
7299 ELSEIF(ISUB.LE.120) THEN
7300 IF(ISUB.EQ.111) THEN
7301 C...f + fbar -> g + h0; th arbitrary
7302 IF(PYR(0).GT.0.5D0) JS=2
7307 ELSEIF(ISUB.EQ.112) THEN
7308 C...f + g -> f + h0; th = (p(f) - p(f))**2
7309 IF(MINT(15).EQ.21) JS=2
7312 KCS=ISIGN(1,MINT(14+JS))
7314 ELSEIF(ISUB.EQ.113) THEN
7315 C...g + g -> g + h0; th arbitrary
7316 IF(PYR(0).GT.0.5D0) JS=2
7319 KCS=(-1)**INT(1.5D0+PYR(0))
7321 ELSEIF(ISUB.EQ.114) THEN
7322 C...g + g -> gamma + gamma; th arbitrary
7323 IF(PYR(0).GT.0.5D0) JS=2
7328 ELSEIF(ISUB.EQ.115) THEN
7329 C...g + g -> g + gamma; th arbitrary
7330 IF(PYR(0).GT.0.5D0) JS=2
7333 KCS=(-1)**INT(1.5D0+PYR(0))
7335 ELSEIF(ISUB.EQ.116) THEN
7336 C...g + g -> gamma + Z0
7338 ELSEIF(ISUB.EQ.117) THEN
7339 C...g + g -> Z0 + Z0
7341 ELSEIF(ISUB.EQ.118) THEN
7342 C...g + g -> W+ + W-
7345 ELSEIF(ISUB.LE.140) THEN
7346 IF(ISUB.EQ.121) THEN
7347 C...g + g -> Q + Qbar + h0
7348 KCS=(-1)**INT(1.5D0+PYR(0))
7349 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
7351 KCC=11+INT(0.5D0+PYR(0))
7354 ELSEIF(ISUB.EQ.122) THEN
7355 C...q + qbar -> Q + Qbar + h0
7356 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
7361 ELSEIF(ISUB.EQ.123) THEN
7362 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
7367 ELSEIF(ISUB.EQ.124) THEN
7368 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
7374 RVCKM=VINT(180+I)*PYR(0)
7377 IPM=(5-ISIGN(1,I))/2
7379 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
7380 MINT(20+JT)=ISIGN(IB,I)
7381 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7382 IF(RVCKM.LE.0D0) GOTO 430
7385 IB=2*((IA+1)/2)-1+MOD(IA,2)
7386 MINT(20+JT)=ISIGN(IB,I)
7392 ELSEIF(ISUB.EQ.131) THEN
7393 C...g + g -> Z0 + q + qbar
7396 ELSEIF(ISUB.LE.160) THEN
7397 IF(ISUB.EQ.141) THEN
7398 C...f + fbar -> gamma*/Z0/Z'0
7401 ELSEIF(ISUB.EQ.142) THEN
7402 C...f + fbar' -> W'+/-
7403 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7404 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7405 KFRES=ISIGN(34,KCH1+KCH2)
7407 ELSEIF(ISUB.EQ.143) THEN
7408 C...f + fbar' -> H+/-
7409 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7410 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7411 KFRES=ISIGN(37,KCH1+KCH2)
7413 ELSEIF(ISUB.EQ.144) THEN
7415 KFRES=ISIGN(40,MINT(15)+MINT(16))
7417 ELSEIF(ISUB.EQ.145) THEN
7418 C...q + l -> LQ (leptoquark)
7419 IF(IABS(MINT(16)).LE.8) JS=2
7420 KFRES=ISIGN(39,MINT(14+JS))
7422 KCS=ISIGN(1,MINT(14+JS))
7424 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
7425 C...q + g -> q* (excited quark)
7426 IF(MINT(15).EQ.21) JS=2
7427 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
7429 KCS=ISIGN(1,MINT(14+JS))
7431 ELSEIF(ISUB.EQ.149) THEN
7432 C...g + g -> eta_techni
7435 KCS=(-1)**INT(1.5D0+PYR(0))
7438 ELSEIF(ISUB.LE.200) THEN
7439 IF(ISUB.EQ.161) THEN
7440 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
7441 IF(MINT(15).EQ.21) JS=2
7444 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
7445 IB=IA+MOD(IA,2)-MOD(IA+1,2)
7446 MINT(20+JS)=ISIGN(IB,I)
7448 KCS=ISIGN(1,MINT(14+JS))
7450 ELSEIF(ISUB.EQ.162) THEN
7451 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
7452 IF(MINT(15).EQ.21) JS=2
7453 MINT(20+JS)=ISIGN(39,MINT(14+JS))
7454 KFLQL=KFDP(MDCY(39,2),2)
7455 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
7457 KCS=ISIGN(1,MINT(14+JS))
7459 ELSEIF(ISUB.EQ.163) THEN
7460 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
7461 KCS=(-1)**INT(1.5D0+PYR(0))
7462 MINT(21)=ISIGN(39,KCS)
7466 ELSEIF(ISUB.EQ.164) THEN
7467 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
7468 MINT(21)=ISIGN(39,MINT(15))
7472 ELSEIF(ISUB.EQ.165) THEN
7473 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
7474 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7477 ELSEIF(ISUB.EQ.166) THEN
7478 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
7479 IF(MOD(MINT(15),2).EQ.0) THEN
7480 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
7481 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
7483 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7484 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
7487 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
7488 C...q + q' -> q" + q* (excited quark)
7490 KFQEXC=MOD(KFQSTR,KEXCIT)
7492 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
7493 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
7494 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
7497 ELSEIF(ISUB.EQ.191) THEN
7498 C...f + fbar -> rho_tech0.
7501 ELSEIF(ISUB.EQ.192) THEN
7502 C...f + fbar' -> rho_tech+/-
7503 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7504 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7505 KFRES=ISIGN(55,KCH1+KCH2)
7507 ELSEIF(ISUB.EQ.193) THEN
7508 C...f + fbar -> omega_tech0.
7511 ELSEIF(ISUB.EQ.194) THEN
7512 C...f + fbar -> f' + fbar' via mixture of s-channel
7513 C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
7514 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7519 ELSEIF(ISUB.LE.215) THEN
7520 IF(ISUB.EQ.201) THEN
7521 C...f + fbar -> ~e_L + ~e_Lbar
7522 MINT(21)=ISIGN(KSUSY1+11,KCS)
7525 ELSEIF(ISUB.EQ.202) THEN
7526 C...f + fbar -> ~e_R + ~e_Rbar
7527 MINT(21)=ISIGN(KSUSY2+11,KCS)
7530 ELSEIF(ISUB.EQ.203) THEN
7531 C...f + fbar -> ~e_R + ~e_Lbar
7533 IF(MINT(2).EQ.2) KCS=-1
7534 MINT(21)=ISIGN(KSUSY1+11,KCS)
7535 MINT(22)=-ISIGN(KSUSY2+11,KCS)
7537 ELSEIF(ISUB.EQ.204) THEN
7538 C...f + fbar -> ~mu_L + ~mu_Lbar
7539 MINT(21)=ISIGN(KSUSY1+13,KCS)
7542 ELSEIF(ISUB.EQ.205) THEN
7543 C...f + fbar -> ~mu_R + ~mu_Rbar
7544 MINT(21)=ISIGN(KSUSY2+13,KCS)
7547 ELSEIF(ISUB.EQ.206) THEN
7548 C...f + fbar -> ~mu_L + ~mu_Rbar
7550 IF(MINT(2).EQ.2) KCS=-1
7551 MINT(21)=ISIGN(KSUSY1+13,KCS)
7552 MINT(22)=-ISIGN(KSUSY2+13,KCS)
7554 ELSEIF(ISUB.EQ.207) THEN
7555 C...f + fbar -> ~tau_1 + ~tau_1bar
7556 MINT(21)=ISIGN(KSUSY1+15,KCS)
7559 ELSEIF(ISUB.EQ.208) THEN
7560 C...f + fbar -> ~tau_2 + ~tau_2bar
7561 MINT(21)=ISIGN(KSUSY2+15,KCS)
7564 ELSEIF(ISUB.EQ.209) THEN
7565 C...f + fbar -> ~tau_1 + ~tau_2bar
7567 IF(MINT(2).EQ.2) KCS=-1
7568 MINT(21)=ISIGN(KSUSY1+15,KCS)
7569 MINT(22)=-ISIGN(KSUSY2+15,KCS)
7571 ELSEIF(ISUB.EQ.210) THEN
7572 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
7573 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7574 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7575 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
7576 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
7578 ELSEIF(ISUB.EQ.211) THEN
7579 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
7580 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7581 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7582 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
7583 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7585 ELSEIF(ISUB.EQ.212) THEN
7586 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
7587 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7588 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7589 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
7590 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7592 ELSEIF(ISUB.EQ.213) THEN
7593 C...f + fbar -> ~nul + ~nulbar
7594 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7597 ELSEIF(ISUB.EQ.214) THEN
7598 C...f + fbar -> ~nutau + ~nutaubar
7599 MINT(21)=ISIGN(KSUSY1+16,KCS)
7603 ELSEIF(ISUB.LE.225) THEN
7604 IF(ISUB.EQ.216) THEN
7605 C...f + fbar -> ~chi01 + ~chi01
7609 ELSEIF(ISUB.EQ.217) THEN
7610 C...f + fbar -> ~chi02 + ~chi02
7614 ELSEIF(ISUB.EQ.218 ) THEN
7615 C...f + fbar -> ~chi03 + ~chi03
7619 ELSEIF(ISUB.EQ.219 ) THEN
7620 C...f + fbar -> ~chi04 + ~chi04
7624 ELSEIF(ISUB.EQ.220 ) THEN
7625 C...f + fbar -> ~chi01 + ~chi02
7626 IF(PYR(0).GT.0.5D0) JS=2
7627 MINT(20+JS)=KSUSY1+22
7628 MINT(23-JS)=KSUSY1+23
7630 ELSEIF(ISUB.EQ.221 ) THEN
7631 C...f + fbar -> ~chi01 + ~chi03
7632 IF(PYR(0).GT.0.5D0) JS=2
7633 MINT(20+JS)=KSUSY1+22
7634 MINT(23-JS)=KSUSY1+25
7636 ELSEIF(ISUB.EQ.222) THEN
7637 C...f + fbar -> ~chi01 + ~chi04
7638 IF(PYR(0).GT.0.5D0) JS=2
7639 MINT(20+JS)=KSUSY1+22
7640 MINT(23-JS)=KSUSY1+35
7642 ELSEIF(ISUB.EQ.223) THEN
7643 C...f + fbar -> ~chi02 + ~chi03
7644 IF(PYR(0).GT.0.5D0) JS=2
7645 MINT(20+JS)=KSUSY1+23
7646 MINT(23-JS)=KSUSY1+25
7648 ELSEIF(ISUB.EQ.224) THEN
7649 C...f + fbar -> ~chi02 + ~chi04
7650 IF(PYR(0).GT.0.5D0) JS=2
7651 MINT(20+JS)=KSUSY1+23
7652 MINT(23-JS)=KSUSY1+35
7654 ELSEIF(ISUB.EQ.225) THEN
7655 C...f + fbar -> ~chi03 + ~chi04
7656 IF(PYR(0).GT.0.5D0) JS=2
7657 MINT(20+JS)=KSUSY1+25
7658 MINT(23-JS)=KSUSY1+35
7661 ELSEIF(ISUB.LE.236) THEN
7662 IF(ISUB.EQ.226) THEN
7663 C...f + fbar -> ~chi+-1 + ~chi-+1
7664 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
7665 MINT(21)=ISIGN(KSUSY1+24,MINT(15))
7668 ELSEIF(ISUB.EQ.227) THEN
7669 C...f + fbar -> ~chi+-2 + ~chi-+2
7670 MINT(21)=ISIGN(KSUSY1+37,MINT(15))
7673 ELSEIF(ISUB.EQ.228) THEN
7674 C...f + fbar -> ~chi+-1 + ~chi-+2
7675 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
7676 C...js=1 if pyr<.5, js=2 if pyr>.5
7677 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
7678 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
7679 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
7680 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
7681 KCH1=ISIGN(1,MINT(15))
7683 IF(MINT(2).EQ.1) THEN
7684 MINT(22-KCH2)= -(KSUSY1+24)
7685 MINT(21+KCH2)= KSUSY1+37
7688 MINT(21+KCH2)= KSUSY1+24
7689 MINT(22-KCH2)= -(KSUSY1+37)
7693 ELSEIF(ISUB.EQ.229) THEN
7694 C...q + qbar' -> ~chi01 + ~chi+-1
7695 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
7696 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7697 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+24,KCH1+KCH2)
7703 ELSEIF(ISUB.EQ.230) THEN
7704 C...q + qbar' -> ~chi02 + ~chi+-1
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+24,KCH1+KCH2)
7711 ELSEIF(ISUB.EQ.231) THEN
7712 C...q + qbar' -> ~chi03 + ~chi+-1
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+24,KCH1+KCH2)
7719 ELSEIF(ISUB.EQ.232) THEN
7720 C...q + qbar' -> ~chi04 + ~chi+-1
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+24,KCH1+KCH2)
7727 ELSEIF(ISUB.EQ.233) THEN
7728 C...q + qbar' -> ~chi01 + ~chi+-2
7729 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7730 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7731 IF(MOD(MINT(15),2).NE.0) JS=2
7732 MINT(20+JS)=KSUSY1+22
7733 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7735 ELSEIF(ISUB.EQ.234) THEN
7736 C...q + qbar' -> ~chi02 + ~chi+-2
7737 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7738 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7739 IF(MOD(MINT(15),2).NE.0) JS=2
7740 MINT(20+JS)=KSUSY1+23
7741 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7743 ELSEIF(ISUB.EQ.235) THEN
7744 C...q + qbar' -> ~chi03 + ~chi+-2
7745 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7746 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7747 IF(MOD(MINT(15),2).NE.0) JS=2
7748 MINT(20+JS)=KSUSY1+25
7749 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7751 ELSEIF(ISUB.EQ.236) THEN
7752 C...q + qbar' -> ~chi04 + ~chi+-2
7753 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7754 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7755 IF(MOD(MINT(15),2).NE.0) JS=2
7756 MINT(20+JS)=KSUSY1+35
7757 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7760 ELSEIF(ISUB.LE.245) THEN
7761 IF(ISUB.EQ.237) THEN
7762 C...q + qbar -> ~chi01 + ~g
7764 IF(PYR(0).GT.0.5D0) JS=2
7765 MINT(20+JS)=KSUSY1+21
7766 MINT(23-JS)=KSUSY1+22
7769 ELSEIF(ISUB.EQ.238) THEN
7770 C...q + qbar -> ~chi02 + ~g
7772 IF(PYR(0).GT.0.5D0) JS=2
7773 MINT(20+JS)=KSUSY1+21
7774 MINT(23-JS)=KSUSY1+23
7777 ELSEIF(ISUB.EQ.239) THEN
7778 C...q + qbar -> ~chi03 + ~g
7780 IF(PYR(0).GT.0.5D0) JS=2
7781 MINT(20+JS)=KSUSY1+21
7782 MINT(23-JS)=KSUSY1+25
7785 ELSEIF(ISUB.EQ.240) THEN
7786 C...q + qbar -> ~chi04 + ~g
7788 IF(PYR(0).GT.0.5D0) JS=2
7789 MINT(20+JS)=KSUSY1+21
7790 MINT(23-JS)=KSUSY1+35
7793 ELSEIF(ISUB.EQ.241) THEN
7794 C...q + qbar' -> ~chi+-1 + ~g
7795 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7796 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7797 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7798 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7799 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7800 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7801 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7803 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7804 MINT(20+JS)=KSUSY1+21
7805 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7808 ELSEIF(ISUB.EQ.242) THEN
7809 C...q + qbar' -> ~chi+-2 + ~g
7810 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7811 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7812 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7813 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7814 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7815 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7816 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7818 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7819 MINT(20+JS)=KSUSY1+21
7820 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7823 ELSEIF(ISUB.EQ.243) THEN
7824 C...q + qbar -> ~g + ~g ; th arbitrary
7829 ELSEIF(ISUB.EQ.244) THEN
7830 C...g + g -> ~g + ~g ; th arbitrary
7832 KCS=(-1)**INT(1.5D0+PYR(0))
7837 ELSEIF(ISUB.LE.260) THEN
7838 IF(ISUB.EQ.246) THEN
7839 C...qj + g -> ~qj_L + ~chi01
7840 IF(MINT(15).EQ.21) JS=2
7843 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7844 MINT(23-JS)=KSUSY1+22
7846 KCS=ISIGN(1,MINT(14+JS))
7848 ELSEIF(ISUB.EQ.247) THEN
7849 C...qj + g -> ~qj_R + ~chi01
7850 IF(MINT(15).EQ.21) JS=2
7853 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7854 MINT(23-JS)=KSUSY1+22
7856 KCS=ISIGN(1,MINT(14+JS))
7858 ELSEIF(ISUB.EQ.248) THEN
7859 C...qj + g -> ~qj_L + ~chi02
7860 IF(MINT(15).EQ.21) JS=2
7863 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7864 MINT(23-JS)=KSUSY1+23
7866 KCS=ISIGN(1,MINT(14+JS))
7868 ELSEIF(ISUB.EQ.249) THEN
7869 C...qj + g -> ~qj_R + ~chi02
7870 IF(MINT(15).EQ.21) JS=2
7873 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7874 MINT(23-JS)=KSUSY1+23
7876 KCS=ISIGN(1,MINT(14+JS))
7878 ELSEIF(ISUB.EQ.250) THEN
7879 C...qj + g -> ~qj_L + ~chi03
7880 IF(MINT(15).EQ.21) JS=2
7883 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7884 MINT(23-JS)=KSUSY1+25
7886 KCS=ISIGN(1,MINT(14+JS))
7888 ELSEIF(ISUB.EQ.251) THEN
7889 C...qj + g -> ~qj_R + ~chi03
7890 IF(MINT(15).EQ.21) JS=2
7893 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7894 MINT(23-JS)=KSUSY1+25
7896 KCS=ISIGN(1,MINT(14+JS))
7898 ELSEIF(ISUB.EQ.252) THEN
7899 C...qj + g -> ~qj_L + ~chi04
7900 IF(MINT(15).EQ.21) JS=2
7903 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7904 MINT(23-JS)=KSUSY1+35
7906 KCS=ISIGN(1,MINT(14+JS))
7908 ELSEIF(ISUB.EQ.253) THEN
7909 C...qj + g -> ~qj_R + ~chi04
7910 IF(MINT(15).EQ.21) JS=2
7913 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7914 MINT(23-JS)=KSUSY1+35
7916 KCS=ISIGN(1,MINT(14+JS))
7918 ELSEIF(ISUB.EQ.254) THEN
7919 C...qj + g -> ~qk_L + ~chi+-1
7920 IF(MINT(15).EQ.21) JS=2
7923 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7924 IB=-IA+INT((IA+1)/2)*4-1
7925 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7927 KCS=ISIGN(1,MINT(14+JS))
7929 ELSEIF(ISUB.EQ.255) THEN
7930 C...qj + g -> ~qk_L + ~chi+-1
7931 IF(MINT(15).EQ.21) JS=2
7934 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7935 IB=-IA+INT((IA+1)/2)*4-1
7936 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7938 KCS=ISIGN(1,MINT(14+JS))
7940 ELSEIF(ISUB.EQ.256) THEN
7941 C...qj + g -> ~qk_L + ~chi+-2
7942 IF(MINT(15).EQ.21) JS=2
7945 IB=-IA+INT((IA+1)/2)*4-1
7946 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7947 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7949 KCS=ISIGN(1,MINT(14+JS))
7951 ELSEIF(ISUB.EQ.257) THEN
7952 C...qj + g -> ~qk_R + ~chi+-2
7953 IF(MINT(15).EQ.21) JS=2
7956 IB=-IA+INT((IA+1)/2)*4-1
7957 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7958 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7960 KCS=ISIGN(1,MINT(14+JS))
7962 ELSEIF(ISUB.EQ.258) THEN
7963 C...qj + g -> ~qj_L + ~g
7964 IF(MINT(15).EQ.21) JS=2
7967 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7968 MINT(23-JS)=KSUSY1+21
7970 IF(JS.EQ.2) KCC=KCC+2
7973 ELSEIF(ISUB.EQ.259) THEN
7974 C...qj + g -> ~qj_R + ~g
7975 IF(MINT(15).EQ.21) JS=2
7978 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7979 MINT(23-JS)=KSUSY1+21
7981 IF(JS.EQ.2) KCC=KCC+2
7985 ELSEIF(ISUB.LE.270) THEN
7986 IF(ISUB.EQ.261) THEN
7987 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
7988 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7990 C...Correct color combination
7991 IF(MINT(43).EQ.4) KCC=4
7993 ELSEIF(ISUB.EQ.262) THEN
7994 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
7995 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7997 C...Correct color combination
7998 IF(MINT(43).EQ.4) KCC=4
8000 ELSEIF(ISUB.EQ.263) THEN
8001 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
8002 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
8003 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
8004 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8005 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
8008 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
8009 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
8011 C...Correct color combination
8012 IF(MINT(43).EQ.4) KCC=4
8014 ELSEIF(ISUB.EQ.264) THEN
8015 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
8016 KCS=(-1)**INT(1.5D0+PYR(0))
8017 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8021 ELSEIF(ISUB.EQ.265) THEN
8022 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
8023 KCS=(-1)**INT(1.5D0+PYR(0))
8024 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8029 ELSEIF(ISUB.LE.280) THEN
8030 IF(ISUB.EQ.271) THEN
8031 C...qi + qj -> ~qi_L + ~qj_L
8033 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8034 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8035 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8037 ELSEIF(ISUB.EQ.272) THEN
8038 C...qi + qj -> ~qi_R + ~qj_R
8040 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8041 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8042 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8044 ELSEIF(ISUB.EQ.273) THEN
8045 C...qi + qj -> ~qi_L + ~qj_R
8046 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8047 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8049 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8051 ELSEIF(ISUB.EQ.274) THEN
8052 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
8053 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8054 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8056 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8058 ELSEIF(ISUB.EQ.275) THEN
8059 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8060 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8061 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8063 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8065 ELSEIF(ISUB.EQ.276) THEN
8066 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8067 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8068 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8070 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8072 ELSEIF(ISUB.EQ.277) THEN
8073 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
8075 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8076 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8078 IF(MINT(43).EQ.4) KCC=4
8080 ELSEIF(ISUB.EQ.278) THEN
8081 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
8083 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8084 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8086 IF(MINT(43).EQ.4) KCC=4
8088 ELSEIF(ISUB.EQ.279) THEN
8089 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
8091 KCS=(-1)**INT(1.5D0+PYR(0))
8092 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8096 ELSEIF(ISUB.EQ.280) THEN
8097 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
8098 KCS=(-1)**INT(1.5D0+PYR(0))
8099 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8107 IF(ISET(ISUB).EQ.11) THEN
8108 C...Store documentation for user-defined processes
8109 BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4))
8115 IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN
8125 IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3))
8132 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
8135 C...Store final state partons for user-defined processes
8140 IF(KUP(IUP,1).NE.1) K(N,1)=11
8142 IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN
8145 K(N,3)=MINT(84)+KUP(IUP,3)
8153 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
8155 C...Arrange colour flow for user-defined processes
8159 IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480
8160 IF(K(N,1).EQ.1) K(N,1)=3
8161 IF(K(N,1).EQ.11) K(N,1)=14
8162 IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+
8164 IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+
8166 IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84)
8167 IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84)
8170 ELSEIF(IDOC.EQ.7) THEN
8171 C...Resonance not decaying; store kinematics
8186 C...Special cases: colour flow in coloured resonances
8188 IF(KCHG(KCRES,2).NE.0) THEN
8192 IF(KCS.EQ.-1) JC=3-J
8193 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8194 & MINT(84)+ICOL(KCC,1,JC)
8195 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8196 & MINT(84)+ICOL(KCC,2,JC)
8197 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8198 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8207 ELSEIF(IDOC.EQ.8) THEN
8208 C...2 -> 2 processes: store outgoing partons in their CM-frame
8211 KCA=PYCOMP(MINT(20+JT))
8213 IF(KCHG(KCA,2).NE.0) K(I,1)=3
8215 K(I,3)=MINT(83)+IDOC+JT-2
8217 IF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,1).NE.0) THEN
8218 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8219 ELSEIF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,2).NE.0) THEN
8220 P(I,5)=SQRT(VINT(64))
8222 P(I,5)=PYMASS(K(I,2))
8224 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
8225 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
8227 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
8230 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
8238 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
8239 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
8240 P(IPU4,4)=SHR-P(IPU3,4)
8241 P(IPU4,3)=-P(IPU3,3)
8246 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
8247 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
8249 ELSEIF(IDOC.EQ.9) THEN
8250 C...2 -> 3 processes: store outgoing partons in their CM frame
8253 KCA=PYCOMP(MINT(20+JT))
8255 IF(KCHG(KCA,2).NE.0) K(I,1)=3
8257 K(I,3)=MINT(83)+IDOC+JT-3
8258 IF(IABS(K(I,2)).LE.22) THEN
8259 P(I,5)=PYMASS(K(I,2))
8261 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8263 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
8264 P(I,1)=PT*COS(VINT(198+5*JT))
8265 P(I,2)=PT*SIN(VINT(198+5*JT))
8269 K(IPU5,3)=MINT(83)+IDOC
8271 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8272 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8273 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
8274 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
8275 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
8277 P(IPU5,3)=PMT3*SINH(VINT(211))
8278 P(IPU5,4)=PMT3*COSH(VINT(211))
8279 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
8280 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
8281 IF(SQL12.LE.0D0) THEN
8285 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
8286 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
8287 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
8288 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
8289 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
8295 ELSEIF(IDOC.EQ.11) THEN
8296 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
8297 PHI(1)=PARU(2)*PYR(0)
8302 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8304 K(I,3)=MINT(83)+IDOC+JT-2
8305 P(I,5)=PYMASS(K(I,2))
8306 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
8310 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8311 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8312 P(I,1)=PTABS*COS(PHI(JT))
8313 P(I,2)=PTABS*SIN(PHI(JT))
8314 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8315 P(I,4)=0.5D0*SHPR*Z(JT)
8319 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
8323 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8324 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8325 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8332 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8333 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8334 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
8335 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
8344 ELSEIF(IDOC.EQ.12) THEN
8345 C...Z0 and W+/- scattering: store bosons and outgoing partons
8346 PHI(1)=PARU(2)*PYR(0)
8348 JTRAN=INT(1.5D0+PYR(0))
8352 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8354 K(I,3)=MINT(83)+IDOC+JT-2
8355 P(I,5)=PYMASS(K(I,2))
8356 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
8357 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8358 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8359 P(I,1)=PTABS*COS(PHI(JT))
8360 P(I,2)=PTABS*SIN(PHI(JT))
8361 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8362 P(I,4)=0.5D0*SHPR*Z(JT)
8365 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
8368 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
8373 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8374 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8375 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8378 K(IPU,2)=KFPR(ISUB,JT)
8379 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
8380 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
8381 K(IPU,3)=MINT(83)+8+JT
8382 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
8383 P(IPU,5)=PYMASS(K(IPU,2))
8385 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8387 MINT(22+JT)=K(IPU,2)
8389 C...Find rotation and boost for hard scattering subsystem
8392 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
8393 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
8394 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
8395 GAMCM=(P(I1,4)+P(I2,4))/SHR
8396 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
8397 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
8398 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
8399 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
8400 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
8402 C...Store hard scattering subsystem. Rotate and boost it
8403 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
8405 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
8407 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
8408 PHIWZ=VINT(24)-PHICM
8409 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
8410 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
8411 P(IPU5,3)=PABS*CTHWZ
8412 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
8413 P(IPU6,1)=-P(IPU5,1)
8414 P(IPU6,2)=-P(IPU5,2)
8415 P(IPU6,3)=-P(IPU5,3)
8416 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
8417 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
8432 IF(ISET(ISUB).EQ.11) THEN
8433 ELSEIF(IDOC.GE.8) THEN
8434 C...Store colour connection indices
8437 IF(KCS.EQ.-1) JC=3-J
8438 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8439 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
8440 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8441 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
8442 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8443 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8444 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8445 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8448 C...Copy outgoing partons to documentation lines
8450 IF(IDOC.EQ.9) IMAX=3
8452 I1=MINT(83)+IDOC-IMAX+I
8456 IF(IDOC.LE.9) K(I1,3)=0
8457 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
8463 ELSEIF(IDOC.EQ.9) THEN
8464 C...Store colour connection indices
8467 IF(KCS.EQ.-1) JC=3-J
8468 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8469 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
8470 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
8471 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8472 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
8473 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
8474 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8475 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8476 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
8477 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8480 C...Copy outgoing partons to documentation lines
8482 I1=MINT(83)+IDOC-3+I
8493 C...Low-pT events: remove gluons used for string drawing purposes
8495 K(IPU3,1)=K(IPU3,1)+10
8496 K(IPU4,1)=K(IPU4,1)+10
8501 DO 650 I=MINT(83)+5,MINT(83)+8
8511 C*********************************************************************
8513 *$ CREATE PYSSPA.FOR
8516 C...Generates spacelike parton showers.
8518 SUBROUTINE PYSSPA(IPU1,IPU2)
8520 C...Double precision and integer declarations.
8521 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8522 INTEGER PYK,PYCHGE,PYCOMP
8524 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8525 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8526 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8527 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8528 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8529 COMMON/PYINT1/MINT(400),VINT(400)
8530 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8531 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8532 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8534 C...Local arrays and data.
8535 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
8536 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
8537 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
8538 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
8539 &THEFIS(2,2),ISFI(2)
8542 C...Read out basic information; set global Q^2 scale.
8547 IF(ISET(ISUB).EQ.2) Q2MX=PARP(67)*VINT(56)
8549 C...Initialize QCD evolution and check phase space.
8552 IF(MSTP(66).EQ.1.AND.MINT(107).EQ.3)
8553 &Q2MNCS(1)=MAX(Q2MNC,VINT(283))
8555 IF(MSTP(66).EQ.1.AND.MINT(108).EQ.3)
8556 &Q2MNCS(2)=MAX(Q2MNC,VINT(284))
8558 XEC0=2D0*PARP(65)/VINT(1)
8563 IF(MINT(47).GE.2.AND.(MINT(47).NE.5.OR.MSTP(12).GE.1)) THEN
8565 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
8566 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
8567 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
8568 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
8572 C...Initialize QED evolution and check phase space.
8579 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
8582 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
8584 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
8586 C...Initial values: flavours, momenta, virtualities.
8591 KFBEAM(JT)=MINT(10+JT)
8592 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
8593 KFLS(JT)=MINT(14+JT)
8596 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
8604 XFS(JT,KFL)=XSFX(JT,KFL)
8608 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
8610 C...Find if interference with final state partons.
8612 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
8616 KCA=PYCOMP(IABS(KFLS(I)))
8617 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
8619 IF(KCFI(I).NE.0) THEN
8620 IF(I.EQ.1) IPFS=IPUS1
8621 IF(I.EQ.2) IPFS=IPUS2
8623 ICSI=MOD(K(IPFS,3+J),MSTU(5))
8624 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
8625 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
8627 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
8629 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
8634 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
8637 C...Pick up leg with highest virtuality.
8640 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
8641 IF(MORE(JT).EQ.0) JT=3-JT
8645 XFB(KFL)=XFS(JT,KFL)
8650 C...Check if allowed to branch.
8652 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
8654 XEC=MAX(XEC0,XB*(1D0/(1D0-PARP(66))-1D0))
8655 IF(XB.GE.1D0-2D0*XEC) MCEV=0
8658 IF(MINT(44+JT).EQ.3) THEN
8660 IF(XB.GE.1D0-2D0*XEE) MEEV=0
8661 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
8663 C***Currently kill QED shower for resolved photoproduction.
8664 IF(MINT(18+JT).EQ.1) MEEV=0
8665 C***Currently kill shower for W inside electron.
8666 IF(IABS(KFLB).EQ.24) THEN
8671 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8676 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
8680 IF(MSTP(62).LE.1) THEN
8681 IF(ZS(JT).GT.0.99999D0) THEN
8684 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
8685 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
8686 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
8688 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8689 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8692 ALSDUM=PYALPS(FQ2C*Q2B)
8693 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
8695 B0=(33D0-2D0*MSTU(118))/6D0
8700 C...Select side for interference with final state partons.
8701 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
8704 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
8706 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
8707 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
8708 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
8710 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
8714 C...Calculate Altarelli-Parisi weights.
8721 IF(IABS(KFLB).LE.10) THEN
8722 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
8723 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
8724 C...f -> f, gamma -> f.
8725 ELSEIF(IABS(KFLB).LE.20) THEN
8726 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
8727 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
8728 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
8729 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
8731 ELSEIF(KFLB.EQ.21) THEN
8732 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
8733 DO 180 KFL=1,MSTP(58)
8737 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
8738 C...f -> gamma, W+, W-.
8739 ELSEIF(KFLB.EQ.22) THEN
8740 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
8743 ELSEIF(KFLB.EQ.24) THEN
8744 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8745 & (XEE*(XB+XEE)))/XB
8746 ELSEIF(KFLB.EQ.-24) THEN
8747 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8748 & (XEE*(XB+XEE)))/XB
8751 C...Calculate parton distribution weights and sum.
8754 IF(NTRY.GT.500) THEN
8760 XFBO=MAX(1D-10,XFB(KFLB))
8762 WTSF(KFL)=XFB(KFL)/XFBO
8763 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
8764 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
8766 WTSUMC=MAX(0.0001D0,WTSUMC)
8767 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
8769 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
8772 IF(NTRY2.GT.500) THEN
8777 IF(MSTP(64).LE.0) THEN
8778 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
8779 ELSEIF(MSTP(64).EQ.1) THEN
8780 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
8782 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
8786 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
8787 & (PARU(101)*FWTE*WTSUME*TEMX)))
8790 C...Translate t into Q2 scale; choose between QCD and QED evolution.
8791 220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
8792 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
8794 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8795 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
8796 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
8797 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
8798 IF(Q2EB.GT.Q2MNE) MCE=2
8799 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
8801 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
8802 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
8805 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
8806 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
8809 C...Evolution possibly ended. Update t values.
8813 ELSEIF(MCE.EQ.1) THEN
8816 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8820 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8823 C...Select flavour for branching parton.
8824 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
8825 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
8828 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
8829 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
8830 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 230
8836 C...Choose z value and corrective weight.
8839 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
8840 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
8841 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
8842 WTZ=0.5D0*(1D0+Z**2)
8844 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
8845 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
8846 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
8848 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
8849 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
8850 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
8851 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
8853 Z=XB+XB*(XEE/(1D0-XEE))*
8854 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8856 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
8858 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
8859 Z=XB+XB*(XEE/(1D0-XEE))*
8860 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8861 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
8863 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
8864 Z=XB+XB*(XEE/(1D0-XEE))*
8865 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8866 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
8867 & (Q2B/(Q2B+PMAS(24,1)**2))
8869 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
8870 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
8871 WTZ=1D0-2D0*Z*(1D0-Z)
8873 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
8874 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
8875 WTZ=(1D0-Z*(1D0-Z))**2
8876 C...gamma -> f + fbar.
8877 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
8878 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
8879 WTZ=1D0-2D0*Z*(1D0-Z)
8881 IF(MCE.EQ.2) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
8883 C...Option with resummation of soft gluon emission as effective z shift.
8885 IF(MSTP(65).GE.1) THEN
8887 IF(KFLB.NE.21) RSOFT=8D0/3D0
8888 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
8889 IF(Z.LE.XB) GOTO 210
8892 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
8893 IF(MSTP(64).GE.2) THEN
8894 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 210
8895 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
8896 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210
8897 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
8900 C...Impose angular constraint in first branching from interference
8901 C...with final state partons.
8902 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
8903 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
8904 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
8905 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 210
8906 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
8907 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210
8911 C...Option with angular ordering requirement.
8912 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
8913 THE2T=(4D0*Z**2*Q2B)/(VINT(2)*(1D0-Z)*XB**2)
8914 IF(THE2T.GT.THE2(JT)) GOTO 210
8918 C...Weighting with new parton distributions.
8919 MINT(105)=MINT(102+JT)
8920 MINT(109)=MINT(106+JT)
8921 IF(MSTP(57).LE.1) THEN
8922 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
8924 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
8927 IF(XFBN.LT.1D-20) THEN
8928 IF(KFLA.EQ.KFLB) THEN
8934 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
8935 TEVCB=0.5D0*(TEVCBS+TEVCB)
8937 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
8938 TEVEB=0.5D0*(TEVEBS+TEVEB)
8949 IF(MSTP(57).LE.1) THEN
8950 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
8952 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
8955 IF(XFAN.LT.1D-20) GOTO 190
8957 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190
8959 C...Define two hard scatterers in their CM-frame.
8960 250 IF(N.EQ.NS+2) THEN
8962 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
8965 IF(JR.EQ.1) IPO=IPUS1
8966 IF(JR.EQ.2) IPO=IPUS2
8976 P(I,3)=DPLCM*(-1)**(JR+1)
8977 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
8978 P(I,5)=-SQRT(DQ2(JR))
8981 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
8982 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
8985 C...Find maximum allowed mass of timelike parton.
8986 ELSEIF(N.GT.NS+2) THEN
8991 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
8992 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
8993 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
8994 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
8995 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
8997 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
8998 & 1D-10*DPD(1)) IKIN=1
8999 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
9000 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
9001 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
9002 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
9004 C...Generate timelike parton shower (if required).
9012 C...f -> f + g (gamma).
9013 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
9015 IF(IABS(KFLB).GE.11) K(IT,2)=22
9016 C...f -> g (gamma, W+-) + f.
9017 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
9019 IF(KFLS(JT+2).EQ.24) THEN
9021 ELSEIF(KFLS(JT+2).EQ.-24) THEN
9024 C...g (gamma) -> f + fbar, g + g.
9027 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
9029 P(IT,5)=PYMASS(K(IT,2))
9030 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
9031 IF(MSTP(63).GE.1.AND.MCE.EQ.1) THEN
9034 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
9035 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
9036 IF(MSTP(63).EQ.1) THEN
9038 ELSEIF(MSTP(63).EQ.2) THEN
9039 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
9043 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9044 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
9045 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
9046 PARJ(85)=SQRT(MAX(0D0,DPT2))*
9047 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
9049 CALL PYSHOW(IT,0,SQRT(Q2TIM))
9052 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
9055 C...Reconstruct kinematics of branching: timelike parton shower.
9057 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9058 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
9059 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
9060 & (4D0*DSH*DPC(3)**2)
9061 IF(DPT2.LT.0D0) GOTO 100
9062 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
9063 & DSHR)/DPC(3)-DPC(3)
9065 P(IT,3)=DPB(1)*(-1)**(JT+1)
9066 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
9068 DPB(1)=SQRT(DPB(1)**2+DPT2)
9069 DPB(2)=SQRT(DPB(1)**2+DMS)
9071 DPB(4)=SQRT(DPB(3)**2+DMS)
9072 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
9074 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
9075 THE=PYANGL(P(IT,3),P(IT,1))
9076 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
9079 C...Reconstruct kinematics of branching: spacelike parton.
9088 P(N+1,3)=P(IT,3)+P(IS(JT),3)
9089 P(N+1,4)=P(IT,4)+P(IS(JT),4)
9090 P(N+1,5)=-SQRT(DQ2(3))
9092 C...Define colour flow of branching.
9097 C...f -> f + gamma (Z, W).
9098 IF(IABS(K(IT,2)).GE.22) THEN
9102 C...f -> gamma (Z, W) + f.
9103 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
9106 C...gamma -> q + qbar, g + g.
9107 ELSEIF(K(N+1,2).EQ.22) THEN
9113 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
9117 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
9120 C...qbar -> qbar + g.
9121 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
9124 C...qbar -> g + qbar.
9125 ELSEIF(K(N+1,2).LT.0) THEN
9128 C...g -> g + g; g -> q + qbar.
9129 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
9136 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
9137 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
9138 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
9139 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
9141 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
9142 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
9146 C...Boost to new CM-frame.
9147 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
9148 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
9149 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
9150 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
9151 IR=N+(JT-1)*(IS(1)-N)
9152 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),PARU(2)*PYR(0),
9156 C...Update kinematics variables.
9159 IF(MSTP(62).GE.3) THE2(JT)=THE2T
9162 C...Save quantities; loop back.
9164 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
9165 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
9171 XFS(JT,KFL)=XFA(KFL)
9180 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
9181 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
9182 IF(MSTU(21).GE.1) N=NS
9183 IF(MSTU(21).GE.1) RETURN
9185 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
9187 C...Boost hard scattering partons to frame of shower initiators.
9189 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
9195 ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
9196 IF(ROBOT.GE.0.999999D0) THEN
9197 ROBOT=1.00001D0*SQRT(ROBOT)
9198 ROBO(3)=ROBO(3)/ROBOT
9199 ROBO(4)=ROBO(4)/ROBOT
9200 ROBO(5)=ROBO(5)/ROBOT
9202 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
9203 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
9204 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
9205 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
9208 C...Store user information. Reset Lambda value.
9209 K(IPU1,3)=MINT(83)+3
9210 K(IPU2,3)=MINT(83)+4
9212 MINT(12+JT)=KFLS(JT)
9214 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
9221 C*********************************************************************
9223 *$ CREATE PYRESD.FOR
9226 C...Allows resonances to decay (including parton showers for hadronic
9229 SUBROUTINE PYRESD(IRES)
9231 C...Double precision and integer declarations.
9232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9233 INTEGER PYK,PYCHGE,PYCOMP
9234 C...Parameter statement to help give large particle numbers.
9235 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
9237 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
9238 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9239 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9240 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
9241 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9242 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9243 COMMON/PYINT1/MINT(400),VINT(400)
9244 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9245 COMMON/PYINT4/MWID(500),WIDS(500,5)
9246 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
9247 &/PYINT1/,/PYINT2/,/PYINT4/
9248 C...Local arrays and complex and character variables.
9249 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
9250 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
9251 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
9252 &PHI(3),WDTP(0:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5)
9253 COMPLEX FGK,HA(6,6),HC(6,6)
9255 CHARACTER CODE*9,MASS*9
9257 C...The F, Xi and Xj functions of Gunion and Kunszt
9258 C...(Phys. Rev. D33, 665, plus errata from the authors).
9259 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
9260 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
9261 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
9262 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
9263 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
9264 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
9265 &2D0*(D34/D56+D56/D34))
9267 C...Some general constants.
9270 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
9273 GMMZ=PMAS(23,1)*PMAS(23,2)
9275 GMMW=PMAS(24,1)*PMAS(24,2)
9278 C...Reset original resonance configuration.
9283 C...Define initial one, two or three objects for subprocess.
9286 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
9287 IREF(1,1)=MINT(84)+2+ISET(ISUB)
9288 IREF(1,4)=MINT(83)+6+ISET(ISUB)
9289 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
9290 IREF(1,1)=MINT(84)+1+ISET(ISUB)
9291 IREF(1,2)=MINT(84)+2+ISET(ISUB)
9292 IREF(1,4)=MINT(83)+5+ISET(ISUB)
9293 IREF(1,5)=MINT(83)+6+ISET(ISUB)
9294 ELSEIF(ISET(ISUB).EQ.5) THEN
9295 IREF(1,1)=MINT(84)+3
9296 IREF(1,2)=MINT(84)+4
9297 IREF(1,3)=MINT(84)+5
9298 IREF(1,4)=MINT(83)+7
9299 IREF(1,5)=MINT(83)+8
9300 IREF(1,6)=MINT(83)+9
9303 C...Define original resonance for odd cases.
9309 C...Check if initial resonance has been moved (in resonance + jet).
9311 IF(IREF(1,JT).GT.0) THEN
9312 IF(K(IREF(1,JT),1).GT.10) THEN
9313 KFA=IABS(K(IREF(1,JT),2))
9314 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
9315 DO 110 I=IREF(1,JT)+1,N
9316 IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2))
9320 KDA=MOD(K(IREF(1,JT),4),MSTU(4))
9321 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
9327 C...Loop over decay history.
9333 IF(IREF(IP,2).EQ.0) JTMAX=1
9334 IF(IREF(IP,3).NE.0) JTMAX=3
9338 C...Start treatment of one, two or three resonances in parallel.
9349 C...Check whether particle can/is allowed to decay.
9350 IF(ID.EQ.0) GOTO 210
9353 IF(MWID(KCA).EQ.0) GOTO 210
9354 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 210
9355 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
9356 & KFA.EQ.18) IT4=IT4+1
9357 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
9358 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
9360 C...Info for selection of decay channel: sign, pairings.
9361 IF(KCHG(KCA,3).EQ.0) THEN
9364 IPM=(5-ISIGN(1,K(ID,2)))/2
9368 KFB=IABS(K(IREF(IP,3-JT),2))
9369 ELSEIF(JTMAX.EQ.3) THEN
9371 KFB=IABS(K(IREF(IP,JT2),2))
9373 JT2=JT+2-3*((JT+1)/3)
9374 KFB=IABS(K(IREF(IP,JT2),2))
9378 C...Select decay channel.
9379 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
9380 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
9381 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
9382 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
9383 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
9384 IF(WDTE0S.LE.0D0) GOTO 210
9388 IDC=IDL+MDCY(KCA,2)-1
9389 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
9390 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
9391 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 150
9393 C...Read out flavours and colour charges of decay channel chosen.
9394 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
9395 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
9396 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
9397 KFC1A=PYCOMP(IABS(KFL1(JT)))
9398 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
9399 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
9400 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
9401 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
9402 KFC2A=PYCOMP(IABS(KFL2(JT)))
9403 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
9404 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
9405 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
9406 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
9407 IF(KFL3(JT).NE.0) THEN
9408 KFC3A=PYCOMP(IABS(KFL3(JT)))
9409 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
9410 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
9411 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
9414 C...Set/save further info on channel.
9416 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
9422 C...Select masses; to begin with assume resonances narrow.
9433 IF(KFL3(JT).EQ.0) GOTO 170
9437 P(N+I,5)=PMAS(KCW,1)
9439 C...This prevents SUSY/t particles from becoming too light.
9440 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9442 DO 160 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9443 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9444 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9445 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9446 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9447 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9448 PMMN(I)=MIN(PMMN(I),PMSUM)
9452 ELSEIF(KFLW.EQ.6) THEN
9453 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9457 C...Check which two out of three are widest.
9462 KFLW1=IABS(KFL1(JT))
9463 KFLW2=IABS(KFL2(JT))
9464 IF(KFL3(JT).NE.0) THEN
9466 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
9469 KFLW1=IABS(KFL3(JT))
9470 ELSEIF(PWID3.GT.PWID2) THEN
9473 KFLW2=IABS(KFL3(JT))
9477 C...If all narrow then only check that masses consistent.
9478 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
9479 & PWID2.LT.PARP(41))) THEN
9481 C....Handle near degeneracy cases.
9482 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
9483 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
9484 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
9485 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
9489 IF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
9490 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
9495 C...For three wide resonances select narrower of three
9496 C...according to BW decoupled from rest.
9499 IF(KFL3(JT).NE.0) THEN
9501 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
9505 P(N+IWID3,5)=PYMASS(KFLW3)
9506 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 180
9507 PMTOT=PMTOT-P(N+IWID3,5)
9509 C...Select other two correlated within remaining phase space.
9513 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
9514 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
9515 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9520 CKIN(49)=PMMN(IWID1)
9521 CKIN(50)=PMMN(IWID2)
9522 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9527 IF(MINT(51).EQ.1) RETURN
9530 C...Begin fill decay products, with colour flow for coloured objects.
9536 C...1) Three-body decays of SUSY particles (plus special case top).
9537 IF(KFL3(JT).NE.0) THEN
9556 C...Set colour flow for t -> W + b + Z.
9560 IF(KCQM(JT).EQ.-1) ISID=5
9562 K(ID,ISID)=K(ID,ISID)+IDAU
9563 K(IDAU,ISID)=MSTU(5)*ID
9565 C...Set colour flow in three-body decays - programmed as special cases.
9566 ELSEIF(KFC2A.LE.6) THEN
9570 IF(KFL2(JT).LT.0) ISID=5
9571 K(N+2,ISID)=MSTU(5)*(N+3)
9572 K(N+3,9-ISID)=MSTU(5)*(N+2)
9574 IF(KFL1(JT).EQ.KSUSY1+21) THEN
9579 IF(KFL2(JT).LT.0) ISID=5
9580 K(N+1,ISID)=MSTU(5)*(N+2)
9581 K(N+1,9-ISID)=MSTU(5)*(N+3)
9582 K(N+2,ISID)=MSTU(5)*(N+1)
9583 K(N+3,9-ISID)=MSTU(5)*(N+1)
9585 IF(KFA.EQ.KSUSY1+21) THEN
9589 IF(KFL2(JT).LT.0) ISID=5
9590 K(ID,ISID)=K(ID,ISID)+(N+2)
9591 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
9592 K(N+2,ISID)=MSTU(5)*ID
9593 K(N+3,9-ISID)=MSTU(5)*ID
9598 C...2) Everything else two-body decay.
9600 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
9601 C...First set colour flow as if mother colour singlet.
9602 IF(KCQ1(JT).NE.0) THEN
9604 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
9605 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
9607 IF(KCQ2(JT).NE.0) THEN
9609 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
9610 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
9612 C...Then redirect colour flow if mother (anti)triplet.
9613 IF(KCQM(JT).EQ.0) THEN
9614 ELSEIF(KCQM(JT).NE.2) THEN
9616 IF(KCQM(JT).EQ.-1) ISID=5
9618 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
9619 K(ID,ISID)=K(ID,ISID)+IDAU
9620 K(IDAU,ISID)=MSTU(5)*ID
9621 C...Then redirect colour flow if mother octet.
9622 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
9624 IF(KCQ1(JT).EQ.0) IDAU=N
9625 K(ID,4)=K(ID,4)+IDAU
9626 K(ID,5)=K(ID,5)+IDAU
9627 K(IDAU,4)=MSTU(5)*ID
9628 K(IDAU,5)=MSTU(5)*ID
9631 IF(KCQ1(JT).EQ.-1) ISID=5
9632 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
9633 K(ID,ISID)=K(ID,ISID)+(N-1)
9634 K(ID,9-ISID)=K(ID,9-ISID)+N
9635 K(N-1,ISID)=MSTU(5)*ID
9636 K(N,9-ISID)=MSTU(5)*ID
9640 C...End loop over resonances for daughter flavour and mass selection.
9642 210 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
9644 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.KFL1(JT).EQ.0) THEN
9645 WRITE(CODE,'(I9)') K(ID,2)
9646 WRITE(MASS,'(F9.3)') P(ID,5)
9647 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
9648 & CODE//' with mass'//MASS)
9654 C...Check for allowed combinations. Skip if no decays.
9656 IF(KDCY(1).EQ.0) GOTO 560
9657 ELSEIF(JTMAX.EQ.2) THEN
9658 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 560
9659 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9660 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9661 ELSEIF(JTMAX.EQ.3) THEN
9662 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 560
9663 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9664 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9665 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9666 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9667 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9668 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9671 C...Special case: matrix element option for Z0 decay to quarks.
9672 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
9673 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
9675 C...Check consistency of MSTJ options set.
9676 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
9678 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
9681 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
9683 & '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
9687 C...Select alpha_strong behaviour.
9691 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9694 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9696 C...Find axial fraction in total cross section for scalar gluon model.
9698 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
9699 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
9700 POLL=1D0-PARJ(131)*PARJ(132)
9701 SFF=1D0/(16D0*XW*XW1)
9702 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
9703 & (PARJ(123)*PARJ(124))**2)
9704 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
9706 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
9707 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
9708 & (PARJ(132)-PARJ(131)))
9713 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
9714 & 1D0-(2D0*PMQ/P(ID,5))**2))
9715 VF=SIGN(1D0,QF)-4D0*QF*XW
9716 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
9717 & VF**2*HF1W)+VQ**3*HF1W
9718 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
9721 C...Choice of jet configuration.
9722 CALL PYXJET(P(ID,5),NJET,CUT)
9726 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
9727 ELSEIF(NJET.EQ.3) THEN
9728 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
9733 C...Fill jet configuration; return if incorrect kinematics.
9735 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
9736 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
9737 ELSEIF(NJET.EQ.2) THEN
9738 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
9739 ELSEIF(NJET.EQ.3) THEN
9740 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
9741 ELSEIF(KFLN.EQ.21) THEN
9742 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9745 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9748 IF(MSTU(24).NE.0) THEN
9755 C...Angular orientation according to matrix element.
9756 IF(MSTJ(106).EQ.1) THEN
9757 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHI,THE,PHI)
9758 IF(MINT(11).LT.0) THE=PARU(1)-THE
9760 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
9761 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
9764 C...Boost partons to Z0 rest frame.
9765 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
9766 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9768 C...Mark decayed resonance and add documentation lines,
9770 IDOC=MINT(83)+MINT(4)
9772 I1=MINT(83)+MINT(4)+1
9774 IF(MSTP(128).GE.1) K(I,3)=ID
9775 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
9786 C...Generate parton shower.
9787 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
9789 C... End special case for Z0: skip ahead.
9795 C...Order incoming partons and outgoing resonances.
9796 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9798 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
9799 IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
9800 ILIN(2)=2*MINT(84)+3-ILIN(1)
9802 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
9806 IF(K(IREF(IP,1),2).EQ.23) IORD=2
9807 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
9808 IAKIPD=IABS(K(IREF(IP,IORD),2))
9809 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
9810 IF(KDCY(IORD).EQ.0) IORD=3-IORD
9812 C...Order decay products of resonances.
9813 DO 250 JT=IORD,3-IORD,3-2*IORD
9814 IF(KDCY(JT).EQ.0) THEN
9815 ILIN(IMAX+1)=NSD(JT)
9817 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
9818 ILIN(IMAX+1)=N+2*JT-1
9821 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9822 K(N+2*JT,2)=K(NSD(JT)+2,2)
9825 ILIN(IMAX+2)=N+2*JT-1
9827 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9828 K(N+2*JT,2)=K(NSD(JT)+2,2)
9832 C...Find charge, isospin, left- and righthanded couplings.
9837 KFA=IABS(K(ILIN(I),2))
9838 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 270
9839 COUP(I,1)=KCHG(KFA,1)/3D0
9840 COUP(I,2)=(-1)**MOD(KFA,2)
9841 COUP(I,4)=-2D0*COUP(I,1)*XWV
9842 COUP(I,3)=COUP(I,2)+COUP(I,4)
9845 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
9849 IF(I.EQ.5) I1=3-IORD
9852 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
9853 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
9854 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
9859 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
9860 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
9861 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
9862 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
9863 IF(COWT12.LT.PYR(0)*COMX12) GOTO 140
9867 C...Select angular orientation type - Z'/W' only.
9869 IF(ISUB.EQ.141) THEN
9870 IF(PYR(0).LT.PARU(130)) MZPWP=1
9872 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
9873 IAKIR=IABS(K(IREF(2,2),2))
9874 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9877 ELSEIF(ISUB.EQ.142) THEN
9878 IF(PYR(0).LT.PARU(136)) MZPWP=1
9880 IAKIR=IABS(K(IREF(2,2),2))
9881 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9886 C...Select random angles (begin of weighting procedure).
9887 310 DO 320 JT=1,JTMAX
9888 IF(KDCY(JT).EQ.0) GOTO 320
9889 IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
9890 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
9891 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
9894 CTHE(JT)=2D0*PYR(0)-1D0
9895 PHI(JT)=PARU(2)*PYR(0)
9899 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9900 C...Construct massless four-vectors.
9909 IF(KDCY(JT).EQ.0) GOTO 350
9911 P(N+2*JT-1,3)=0.5D0*P(ID,5)
9912 P(N+2*JT-1,4)=0.5D0*P(ID,5)
9913 P(N+2*JT,3)=-0.5D0*P(ID,5)
9914 P(N+2*JT,4)=0.5D0*P(ID,5)
9915 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
9916 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9919 C...Store incoming and outgoing momenta, with random rotation to
9920 C...avoid accidental zeroes in HA expressions.
9923 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
9924 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
9925 P(N+4+I,5)=P(ILIN(I),5)
9927 P(N+4+I,J)=P(ILIN(I),J)
9930 380 THERR=ACOS(2D0*PYR(0)-1D0)
9931 PHIRR=PARU(2)*PYR(0)
9932 CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
9934 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2) GOTO 380
9940 C...Calculate internal products.
9941 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
9943 DO 420 I1=IMIN,IMAX-1
9945 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
9946 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
9947 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
9948 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
9949 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
9950 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
9951 HC(I1,I2)=CONJG(HA(I1,I2))
9952 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
9953 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
9954 HA(I2,I1)=-HA(I1,I2)
9955 HC(I2,I1)=-HC(I1,I2)
9964 DO 460 I1=IMIN,IMAX-1
9966 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
9967 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
9968 PKK(I2,I1)=PKK(I1,I2)
9973 KFAGM=IABS(IREF(IP,7))
9974 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
9975 C...Isotropic decay selected by user.
9979 ELSEIF(JTMAX.EQ.3) THEN
9980 C...Isotropic decay when three mother particles.
9984 ELSEIF(IT4.GE.1) THEN
9985 C... Isotropic decay t -> b + W etc for 4th generation q and l.
9989 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
9990 & IREF(IP,7).EQ.36) THEN
9991 C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
9992 IF(IP.EQ.1) WTMAX=SH**2
9993 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
9994 KFA=IABS(K(IREF(IP,1),2))
9996 KFLF1A=IABS(KFL1(1))
9997 EF1=KCHG(KFLF1A,1)/3D0
9998 AF1=SIGN(1D0,EF1+0.1D0)
10000 KFLF2A=IABS(KFL1(2))
10001 EF2=KCHG(KFLF2A,1)/3D0
10002 AF2=SIGN(1D0,EF2+0.1D0)
10003 VF2=AF2-4D0*EF2*XWV
10004 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
10005 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
10006 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
10007 ELSEIF(KFA.EQ.24) THEN
10008 WT=16D0*PKK(3,5)*PKK(4,6)
10013 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
10014 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
10016 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
10018 IF(MOD(KFAGM,2).EQ.0) THEN
10026 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
10027 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
10028 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
10029 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
10031 ELSEIF(ISUB.EQ.1) THEN
10032 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
10033 EI=KCHG(IABS(MINT(15)),1)/3D0
10034 AI=SIGN(1D0,EI+0.1D0)
10036 EF=KCHG(IABS(KFL1(1)),1)/3D0
10037 AF=SIGN(1D0,EF+0.1D0)
10039 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
10040 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10041 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
10042 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10043 & (VI**2+AI**2)*VINT(114)*VF**2)
10044 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
10045 & 4D0*VI*AI*VINT(114)*VF*AF)
10046 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
10047 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
10048 WTMAX=2D0*(WT1+ABS(WT3))
10050 ELSEIF(ISUB.EQ.2) THEN
10051 C...Angular weight for W+/- -> 2 quarks/leptons.
10052 WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2
10055 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
10056 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
10057 C...-> gluon/gamma + 2 quarks/leptons.
10058 CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10059 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10060 & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10061 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10062 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10063 & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10064 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10065 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10066 & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10067 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10068 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10069 & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10070 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
10071 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
10072 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10073 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
10075 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
10076 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
10077 C...-> gluon/gamma + 2 quarks/leptons.
10078 WT=PKK(1,3)**2+PKK(2,4)**2
10079 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
10081 ELSEIF(ISUB.EQ.22) THEN
10082 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
10083 S34=P(IREF(IP,IORD),5)**2
10084 S56=P(IREF(IP,3-IORD),5)**2
10085 TI=PKK(1,3)+PKK(1,4)+S34
10086 UI=PKK(1,5)+PKK(1,6)+S56
10089 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
10090 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
10091 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
10092 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
10093 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
10094 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
10095 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
10096 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
10098 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
10099 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
10100 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
10101 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
10102 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
10103 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
10104 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
10107 ELSEIF(ISUB.EQ.23) THEN
10108 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
10109 D34=P(IREF(IP,IORD),5)**2
10110 D56=P(IREF(IP,3-IORD),5)**2
10111 DT=PKK(1,3)+PKK(1,4)+D34
10112 DU=PKK(1,5)+PKK(1,6)+D56
10113 FACBW=1D0/((SH-SQMW)**2+SQMW*PMAS(24,2)**2)
10114 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10115 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10116 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
10117 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
10118 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
10119 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
10120 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10121 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
10122 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
10124 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
10125 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
10126 C...(or H0, or A0).
10127 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10128 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
10129 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
10130 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10131 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10133 ELSEIF(ISUB.EQ.25) THEN
10134 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
10135 D34=P(IREF(IP,IORD),5)**2
10136 D56=P(IREF(IP,3-IORD),5)**2
10137 DT=PKK(1,3)+PKK(1,4)+D34
10138 DU=PKK(1,5)+PKK(1,6)+D56
10139 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
10140 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
10141 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
10142 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
10143 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
10144 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
10145 & REAL(CBWW)*FGK(1,2,5,6,3,4))
10146 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10147 WT=FGK135**2+(CCWW*FGK253)**2
10148 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
10149 & CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
10151 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
10152 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
10153 C...(or H0, or A0).
10154 WT=PKK(1,3)*PKK(2,4)
10155 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10157 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
10158 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
10159 C...-> f + 2 quarks/leptons.
10160 CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10161 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10162 & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10163 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10164 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10165 & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10166 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10167 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10168 & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10169 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10170 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10171 & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10172 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
10173 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
10174 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
10175 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
10176 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10177 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
10179 ELSEIF(ISUB.EQ.31) THEN
10180 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons.
10181 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
10182 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
10183 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
10185 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
10187 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
10188 WT=16D0*PKK(3,5)*PKK(4,6)
10191 ELSEIF(ISUB.EQ.110) THEN
10192 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
10196 ELSEIF(ISUB.EQ.141) THEN
10197 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10198 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
10199 C...Couplings of incoming flavour.
10200 KFAI=IABS(MINT(15))
10201 EI=KCHG(KFAI,1)/3D0
10202 AI=SIGN(1D0,EI+0.1D0)
10205 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
10206 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
10207 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
10208 VPI=PARU(119+2*KFAIC)
10209 API=PARU(120+2*KFAIC)
10210 C...Couplings of final flavour.
10212 EF=KCHG(KFAF,1)/3D0
10213 AF=SIGN(1D0,EF+0.1D0)
10216 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
10217 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
10218 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
10219 VPF=PARU(119+2*KFAFC)
10220 APF=PARU(120+2*KFAFC)
10221 C...Asymmetry and weight.
10222 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
10223 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
10224 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
10225 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10226 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
10227 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
10228 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
10229 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10230 WTMAX=2D0+ABS(ASYM)
10231 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
10232 C...Angular weight for f + fbar -> Z' -> W+ + W-.
10233 RM1=P(NSD(1)+1,5)**2/SH
10234 RM2=P(NSD(1)+2,5)**2/SH
10235 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10236 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10237 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10239 WT=CFLAT+CCOS2*CTHE(1)**2
10240 WTMAX=CFLAT+MAX(0D0,CCOS2)
10241 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
10242 & IABS(KFL1(1)).EQ.37)) THEN
10243 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
10246 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10247 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
10248 RM1=P(NSD(1)+1,5)**2/SH
10249 RM2=P(NSD(1)+2,5)**2/SH
10250 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10251 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10252 WTMAX=1D0+FLAM2/(8D0*RM1)
10253 ELSEIF(MZPWP.EQ.0) THEN
10254 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10255 C...(W:s like if intermediate Z).
10256 D34=P(IREF(IP,IORD),5)**2
10257 D56=P(IREF(IP,3-IORD),5)**2
10258 DT=PKK(1,3)+PKK(1,4)+D34
10259 DU=PKK(1,5)+PKK(1,6)+D56
10260 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10261 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10262 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
10263 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
10264 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10265 ELSEIF(MZPWP.EQ.1) THEN
10266 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10267 C...(W:s approximately longitudinal, like if intermediate H).
10268 WT=16D0*PKK(3,5)*PKK(4,6)
10271 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
10272 C...H0 + A0 -> 4 quarks/leptons.
10277 ELSEIF(ISUB.EQ.142) THEN
10278 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10279 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
10280 KFAI=IABS(MINT(15))
10282 IF(KFAI.GT.10) KFAIC=2
10283 VI=PARU(129+2*KFAIC)
10284 AI=PARU(130+2*KFAIC)
10287 IF(KFAF.GT.10) KFAFC=2
10288 VF=PARU(129+2*KFAFC)
10289 AF=PARU(130+2*KFAFC)
10290 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
10291 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10292 WTMAX=2D0+ABS(ASYM)
10293 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
10294 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
10295 RM1=P(NSD(1)+1,5)**2/SH
10296 RM2=P(NSD(1)+2,5)**2/SH
10297 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10298 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10299 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10301 WT=CFLAT+CCOS2*CTHE(1)**2
10302 WTMAX=CFLAT+MAX(0D0,CCOS2)
10303 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10304 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
10305 RM1=P(NSD(1)+1,5)**2/SH
10306 RM2=P(NSD(1)+2,5)**2/SH
10307 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10308 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10309 WTMAX=1D0+FLAM2/(8D0*RM1)
10310 ELSEIF(MZPWP.EQ.0) THEN
10311 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10312 C...(W/Z like if intermediate W).
10313 D34=P(IREF(IP,IORD),5)**2
10314 D56=P(IREF(IP,3-IORD),5)**2
10315 DT=PKK(1,3)+PKK(1,4)+D34
10316 DU=PKK(1,5)+PKK(1,6)+D56
10317 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10318 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
10319 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10320 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
10321 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10322 ELSEIF(MZPWP.EQ.1) THEN
10323 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10324 C...(W/Z approximately longitudinal, like if intermediate H).
10325 WT=16D0*PKK(3,5)*PKK(4,6)
10328 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever.
10333 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
10335 C...Isotropic decay of leptoquarks (assumed spin 0).
10339 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
10340 C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-).
10342 IF(MINT(16).EQ.21) SIDE=-1D0
10343 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
10344 WT=1D0+SIDE*CTHE(1)
10346 ELSEIF(IP.EQ.1) THEN
10347 RM1=P(NSD(1)+1,5)**2/SH
10348 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10349 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10351 C...W/Z decay assumed isotropic, since not known.
10356 ELSEIF(ISUB.EQ.149) THEN
10357 C...Isotropic decay of techni-eta.
10361 ELSEIF(ISUB.EQ.191) THEN
10362 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10363 C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
10364 C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
10367 ELSEIF(IP.EQ.1) THEN
10368 C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
10369 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10370 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
10371 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10372 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10373 KFAI=IABS(MINT(15))
10374 EI=KCHG(KFAI,1)/3D0
10375 AI=SIGN(1D0,EI+0.1D0)
10379 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
10380 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
10382 EF=KCHG(KFAF,1)/3D0
10383 AF=SIGN(1D0,EF+0.1D0)
10387 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
10388 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
10389 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
10390 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
10391 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
10392 WTMAX=4D0*MAX(ASAME,AFLIP)
10394 C...Isotropic decay of W/pi_tech produced in rho_tech decay.
10399 ELSEIF(ISUB.EQ.192) THEN
10400 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10401 C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
10402 C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
10405 ELSEIF(IP.EQ.1) THEN
10406 C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
10407 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10411 C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
10416 ELSEIF(ISUB.EQ.193) THEN
10417 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10418 C...Angular weight for f + fbar -> omega_tech0 ->
10419 C...gamma pi_tech0 or Z0 pi_tech0.
10422 ELSEIF(IP.EQ.1) THEN
10423 C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
10424 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10425 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10426 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10427 KFAI=IABS(MINT(15))
10428 EI=KCHG(KFAI,1)/3D0
10429 AI=SIGN(1D0,EI+0.1D0)
10433 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
10434 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
10436 EF=KCHG(KFAF,1)/3D0
10437 AF=SIGN(1D0,EF+0.1D0)
10441 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
10442 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
10443 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
10444 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
10445 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
10446 WTMAX=4D0*MAX(BSAME,BFLIP)
10448 C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
10453 C...Obtain correct angular distribution by rejection techniques.
10458 IF(WT.LT.PYR(0)*WTMAX) GOTO 310
10460 C...Construct massive four-vectors using angles chosen.
10461 470 DO 540 JT=1,JTMAX
10462 IF(KDCY(JT).EQ.0) GOTO 540
10467 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
10469 IF(KFL3(JT).EQ.0) THEN
10470 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
10471 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10473 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
10474 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10478 C...Mark decayed resonances; trace history.
10482 IF(KCQM(JT).NE.0) THEN
10483 C...Do not kill colour flow through coloured resonance!
10487 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
10490 C...Add documentation lines.
10492 IDOC=MINT(83)+MINT(4)
10495 IF(KFL3(JT).NE.0) IHI=IHI+1
10496 DO 500 I=NSD(JT)+1,IHI
10498 I1=MINT(83)+MINT(4)+1
10500 IF(MSTP(128).GE.1) K(I,3)=ID
10501 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
10505 K(I1,3)=IREF(IP,JT+3)
10514 IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
10517 C...Do showering if any of the two/three products can shower.
10519 IF(MSTP(71).GE.1) THEN
10521 KFL1A=IABS(KFL1(JT))
10522 IF(KFL1A.LE.22) ISHOW1=1
10524 KFL2A=IABS(KFL2(JT))
10525 IF(KFL2A.LE.22) ISHOW2=1
10527 IF(KFL3(JT).NE.0) THEN
10528 KFL3A=IABS(KFL3(JT))
10529 IF(KFL3A.LE.22) ISHOW3=1
10531 IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN
10532 ELSEIF(KFL3(JT).EQ.0) THEN
10533 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
10537 IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN
10539 ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN
10542 PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2-
10543 & (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2-
10544 & (P(NSD1,3)+P(NSD2,3))**2))
10545 CALL PYSHOW(NSD1,NSD2,PMSHOW)
10549 IF(JT.EQ.1) NAFT1=N
10551 C...Check if decay products moved by shower.
10555 IF(NSHAFT.GT.NSHBEF) THEN
10556 IF(K(NSD1,1).GT.10) THEN
10557 DO 510 I=NSHBEF+1,NSHAFT
10558 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
10561 IF(K(NSD2,1).GT.10) THEN
10562 DO 520 I=NSHBEF+1,NSHAFT
10563 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
10564 & I.NE.NSD1) NSD2=I
10567 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
10568 DO 530 I=NSHBEF+1,NSHAFT
10569 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
10570 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
10575 C...Store decay products for further treatment.
10580 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
10584 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
10585 IREF(NP,7)=K(IREF(IP,JT),2)
10586 IREF(NP,8)=IREF(IP,JT)
10589 C...Fill information for 2 -> 1 -> 2.
10590 550 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
10591 MINT(7)=MINT(83)+6+2*ISET(ISUB)
10592 MINT(8)=MINT(83)+7+2*ISET(ISUB)
10598 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
10599 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
10600 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
10601 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
10602 VINT(47)=SQRT(VINT(48))
10605 C...Possibility of colour rearrangement in W+W- events.
10606 IF(ISUB.EQ.25.AND.MSTP(115).GE.1) THEN
10607 IAKF1=IABS(KFL1(1))
10608 IAKF2=IABS(KFL1(2))
10609 IAKF3=IABS(KFL2(1))
10610 IAKF4=IABS(KFL2(2))
10611 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
10612 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
10613 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
10616 C...Loop back if needed.
10617 560 IF(IP.LT.NP) GOTO 130
10622 C*********************************************************************
10624 *$ CREATE PYMULT.FOR
10627 C...Initializes treatment of multiple interactions, selects kinematics
10628 C...of hardest interaction if low-pT physics included in run, and
10629 C...generates all non-hardest interactions.
10631 SUBROUTINE PYMULT(MMUL)
10633 C...Double precision and integer declarations.
10634 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10635 INTEGER PYK,PYCHGE,PYCOMP
10637 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10638 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10639 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10640 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10641 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10642 COMMON/PYINT1/MINT(400),VINT(400)
10643 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10644 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10645 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10646 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
10647 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10648 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
10649 C...Local arrays and saved variables.
10650 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
10651 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
10653 C...Initialization of multiple interaction treatment.
10655 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
10663 C...Loop over phase space points: xT2 choice in 20 bins.
10666 NMUL(IXT2)=MSTP(83)
10668 DO 110 ITRY=1,MSTP(83)
10669 RSCA=0.05D0*((21-IXT2)-PYR(0))
10670 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
10671 XT2=MAX(0.01D0*VINT(149),XT2)
10674 C...Choose tau and y*. Calculate cos(theta-hat).
10675 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10676 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10677 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10679 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10685 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10686 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10687 CALL PYKMAP(2,MYST,PYR(0))
10688 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10690 C...Calculate differential cross-section.
10691 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10692 CALL PYSIGH(NCHN,SIGS)
10693 SIGM(IXT2)=SIGM(IXT2)+SIGS
10695 SIGSUM=SIGSUM+SIGM(IXT2)
10697 SIGSUM=SIGSUM/(20D0*MSTP(83))
10699 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
10700 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
10701 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) PARP(82),SIGSUM
10702 PARP(82)=0.9D0*PARP(82)
10703 VINT(149)=4D0*PARP(82)**2/VINT(2)
10706 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) PARP(82), SIGSUM
10708 C...Start iteration to find k factor.
10709 YKE=SIGSUM/SIGT(0,0,5)
10717 130 IF(IIT.EQ.0) THEN
10719 ELSEIF(IIT.EQ.1) THEN
10722 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
10725 C...Evaluate overlap integrals.
10726 IF(MSTP(82).EQ.2) THEN
10727 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
10730 IF(MSTP(82).EQ.3) DELTAB=0.02D0
10731 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
10736 IF(MSTP(82).EQ.3) THEN
10737 OV=EXP(-B**2)/PARU(2)
10740 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
10741 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
10742 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
10743 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
10745 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
10746 SP=SP+PARU(2)*B*DELTAB*PACC
10747 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
10748 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
10750 YK=PARU(1)*XK*SO/SP
10752 C...Continue iteration until convergence.
10762 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
10764 C...Store some results for subsequent use.
10769 C...Initialize iteration in xT2 for hardest interaction.
10770 ELSEIF(MMUL.EQ.2) THEN
10771 IF(MSTP(82).LE.0) THEN
10772 ELSEIF(MSTP(82).EQ.1) THEN
10774 XT2FAC=XSEC(96,1)/SIGT(0,0,5)*VINT(149)/(1D0-VINT(149))
10775 ELSEIF(MSTP(82).EQ.2) THEN
10777 XT2FAC=VINT(146)*XSEC(96,1)/SIGT(0,0,5)*VINT(149)*
10780 XC2=4D0*CKIN(3)**2/VINT(2)
10781 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
10784 ELSEIF(MMUL.EQ.3) THEN
10785 C...Low-pT or multiple interactions (first semihard interaction):
10786 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
10787 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
10789 IF(MSTP(82).LE.0) THEN
10791 ELSEIF(MSTP(82).EQ.1) THEN
10792 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10793 ELSEIF(MSTP(82).EQ.2) THEN
10794 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
10795 & VINT(149)))).GT.PYR(0)) XT2=1D0
10796 IF(XT2.GE.1D0) THEN
10797 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
10798 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
10801 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
10802 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
10805 XT2=MAX(0.01D0*VINT(149),XT2)
10807 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
10808 & PYR(0)*(1D0-XC2))-VINT(149)
10809 XT2=MAX(0.01D0*VINT(149),XT2)
10813 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
10814 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
10815 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
10816 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
10819 VINT(21)=0.01D0*VINT(149)
10822 VINT(25)=0.01D0*VINT(149)
10825 C...Multiple interactions (first semihard interaction).
10826 C...Choose tau and y*. Calculate cos(theta-hat).
10827 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10828 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10829 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10831 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10837 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10838 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10839 CALL PYKMAP(2,MYST,PYR(0))
10840 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10842 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
10844 C...Store results of cross-section calculation.
10845 ELSEIF(MMUL.EQ.4) THEN
10848 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
10849 IF(ISET(ISUB).EQ.2)
10850 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10851 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
10852 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
10853 & (XTS+VINT(149))))
10854 IRBIN=INT(1D0+20D0*RBIN)
10855 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
10856 NMUL(IRBIN)=NMUL(IRBIN)+1
10857 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
10860 C...Choose impact parameter.
10861 ELSEIF(MMUL.EQ.5) THEN
10862 IF(MSTP(82).EQ.3) THEN
10863 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
10867 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
10869 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
10870 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
10872 B2=-CQ2*LOG(PYR(0))
10874 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
10875 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
10876 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
10879 C...Multiple interactions (variable impact parameter) : reject with
10880 C...probability exp(-overlap*cross-section above pT/normalization).
10881 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
10882 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
10883 DO 150 IBIN=IRBIN+1,20
10884 RNCOR=RNCOR+NMUL(IBIN)
10885 SIGCOR=SIGCOR+SIGM(IBIN)
10887 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
10888 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
10889 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
10890 & SIGABV/SIGT(0,0,5)))
10892 C...Generate additional multiple semihard interactions.
10893 ELSEIF(MMUL.EQ.6) THEN
10901 C...Reconstruct strings in hard scattering.
10903 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
10904 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
10906 DO 180 I=MINT(84)+1,NMAX
10907 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
10908 IF(KCS.EQ.0) GOTO 180
10911 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170
10912 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170
10914 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
10916 IST=MOD(K(I,J+1),MSTU(5))
10918 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 170
10919 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170
10921 IF(J.EQ.1.OR.J.EQ.4) THEN
10931 C...Set up starting values for iteration in xT2.
10933 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
10934 IF(ISET(ISUBSV).EQ.2)
10935 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10936 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
10937 IF(MSTP(82).LE.1) THEN
10938 XT2FAC=XSEC(ISUB,1)*VINT(149)/((1D0-VINT(149))*SIGT(0,0,5))
10940 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/SIGT(0,0,5)*
10941 & VINT(149)*(1D0+VINT(149))
10945 VINT(143)=1D0-VINT(141)
10946 VINT(144)=1D0-VINT(142)
10948 C...Iterate downwards in xT2.
10949 190 IF(MSTP(82).LE.1) THEN
10950 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10951 IF(XT2.LT.VINT(149)) GOTO 240
10953 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240
10954 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
10955 & LOG(PYR(0)))-VINT(149)
10956 IF(XT2.LE.0D0) GOTO 240
10957 XT2=MAX(0.01D0*VINT(149),XT2)
10961 C...Choose tau and y*. Calculate cos(theta-hat).
10962 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10963 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10964 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10966 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10972 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10973 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10974 CALL PYKMAP(2,MYST,PYR(0))
10975 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10977 C...Check that x not used up. Accept or reject kinematical variables.
10978 X1M=SQRT(TAU)*EXP(VINT(22))
10979 X2M=SQRT(TAU)*EXP(-VINT(22))
10980 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 190
10981 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10982 CALL PYSIGH(NCHN,SIGS)
10983 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190
10985 C...Reset K, P and V vectors. Select some variables.
10994 PT=0.5D0*VINT(1)*SQRT(XT2)
10998 C...Add first parton to event record.
11001 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
11002 & 1+INT((2D0+PARJ(2))*PYR(0))
11003 P(N+1,1)=PT*COS(PHI)
11004 P(N+1,2)=PT*SIN(PHI)
11005 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
11006 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
11009 C...Add second parton to event record.
11012 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
11015 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
11016 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
11019 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
11020 C....Choose relevant string pieces to place gluons on.
11026 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
11027 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
11028 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
11029 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
11030 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
11038 C....Colour flow adjustments, new string pieces.
11039 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
11040 & MOD(K(IST1,4),MSTU(5))
11041 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
11042 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
11043 K(I,5)=MSTU(5)*IST1
11044 K(I,4)=MSTU(5)*IST2
11045 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
11046 & MOD(K(IST2,5),MSTU(5))
11047 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
11048 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
11051 KSTR(NSTR+1,2)=IST2
11055 C...String drawing and colour flow for gluon loop.
11056 ELSEIF(K(N+1,2).EQ.21) THEN
11057 K(N+1,4)=MSTU(5)*(N+2)
11058 K(N+1,5)=MSTU(5)*(N+2)
11059 K(N+2,4)=MSTU(5)*(N+1)
11060 K(N+2,5)=MSTU(5)*(N+1)
11067 C...String drawing and colour flow for qqbar pair.
11069 K(N+1,4)=MSTU(5)*(N+2)
11070 K(N+2,5)=MSTU(5)*(N+1)
11076 C...Update remaining energy; iterate.
11078 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11079 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
11080 IF(MSTU(21).GE.1) RETURN
11082 MINT(31)=MINT(31)+1
11083 VINT(151)=VINT(151)+VINT(41)
11084 VINT(152)=VINT(152)+VINT(42)
11085 VINT(143)=VINT(143)-VINT(41)
11086 VINT(144)=VINT(144)-VINT(42)
11087 IF(MINT(31).LT.240) GOTO 190
11095 C...Format statements for printout.
11096 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
11097 &'actions for MSTP(82) =',I2,' ******')
11098 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11099 &D9.2,' mb: rejected')
11100 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11101 &D9.2,' mb: accepted')
11106 C*********************************************************************
11108 *$ CREATE PYREMN.FOR
11111 C...Adds on target remnants (one or two from each side) and
11112 C...includes primordial kT for hadron beams.
11114 SUBROUTINE PYREMN(IPU1,IPU2)
11116 C...Double precision and integer declarations.
11117 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11118 INTEGER PYK,PYCHGE,PYCOMP
11120 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11121 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11122 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11123 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11124 COMMON/PYINT1/MINT(400),VINT(400)
11125 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
11127 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
11128 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
11130 C...Find event type and remaining energy.
11133 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
11134 VINT(143)=1D0-VINT(141)
11135 VINT(144)=1D0-VINT(142)
11138 C...Define initial partons.
11143 IF(JT.EQ.1) IPU=IPU1
11144 IF(JT.EQ.2) IPU=IPU2
11151 IF(MINT(47).EQ.1) THEN
11155 ELSEIF(ISUB.EQ.95) THEN
11160 C...No primordial kT, or chosen according to truncated Gaussian or
11161 C...exponential, or (for photon) predetermined or power law.
11162 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
11163 IF(MSTP(91).LE.0) THEN
11165 ELSEIF(MSTP(91).EQ.1) THEN
11166 PT=PARP(91)*SQRT(-LOG(PYR(0)))
11170 PT=-PARP(92)*LOG(RPT1*RPT2)
11172 IF(PT.GT.PARP(93)) GOTO 120
11173 ELSEIF(MINT(106+JT).EQ.3) THEN
11174 PT=SQRT(VINT(282+JT))
11175 PT=PT*0.8D0**MINT(57)
11176 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
11177 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
11178 IF(MSTP(93).LE.0) THEN
11180 ELSEIF(MSTP(93).EQ.1) THEN
11181 PT=PARP(99)*SQRT(-LOG(PYR(0)))
11182 ELSEIF(MSTP(93).EQ.2) THEN
11185 PT=-PARP(99)*LOG(RPT1*RPT2)
11186 ELSEIF(MSTP(93).EQ.3) THEN
11189 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
11193 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
11194 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
11196 IF(PT.GT.PARP(100)) GOTO 120
11204 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11207 IF(MINT(47).EQ.1) RETURN
11209 C...Kinematics construction for initial partons.
11212 IF(ISUB.EQ.95) THEN
11216 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
11217 & (P(I1,2)+P(I2,2))**2
11218 SHR=SQRT(MAX(0D0,SHS))
11219 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
11220 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
11221 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
11222 P(I2,4)=SHR-P(I1,4)
11225 C...Transform partons to overall CM-frame.
11226 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
11227 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
11228 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
11229 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
11230 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
11231 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
11232 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
11233 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
11234 ROBO(5)=MAX(-0.999999D0,MIN(0.999999D0,(VINT(141)-VINT(142))/
11235 & (VINT(141)+VINT(142))))
11236 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
11239 C...Optionally fix up x and Q2 definitions for leptoproduction.
11241 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
11242 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
11243 IF(IDISXQ.EQ.1) THEN
11245 C...Find where incoming and outgoing leptons/partons are sitting.
11247 IF(MINT(42).EQ.1) LESD=2
11248 LPIN=MINT(83)+3-LESD
11250 LQIN=MINT(84)+3-LESD
11251 LEOUT=MINT(84)+2+LESD
11252 LQOUT=MINT(84)+5-LESD
11253 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
11254 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
11256 DO 140 I=MINT(84)+5,N
11257 IF(K(I,2).EQ.94) THEN
11264 IF(LESD.EQ.1) LQBG=IPU2
11266 C...Calculate actual and wanted momentum transfer.
11269 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
11270 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
11271 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
11272 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
11273 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
11274 P(N+1,1)=FAC*P(LEOUT,1)
11275 P(N+1,2)=FAC*P(LEOUT,2)
11276 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
11277 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
11278 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
11281 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
11282 QNEW(J)=P(LEIN,J)-P(N+1,J)
11285 C...Boost outgoing electron and daughters.
11286 IF(LSCMS.EQ.0) THEN
11288 P(LEOUT,J)=P(N+1,J)
11292 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
11294 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
11296 DBE(J)=PINV*P(N+2,J)
11300 190 IORIG=K(IORIG,3)
11301 IF(IORIG.GT.LEOUT) GOTO 190
11302 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
11303 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
11307 C...Copy shower initiator and all outgoing partons.
11311 P(NCOP,J)=P(LQBG,J)
11313 DO 240 I=MINT(84)+1,N
11315 IF(K(I,1).GT.10) GOTO 240
11316 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
11320 220 IORIG=K(IORIG,3)
11321 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
11323 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
11336 C...Calculate relative rescaling factors.
11340 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
11343 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
11346 C...Transfer extra three-momentum of current.
11349 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
11351 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11354 C...Iterate change of initiator momentum to get energy right.
11357 PEEX=-P(N+1,4)-QNEW(4)
11358 PEMV=-P(N+1,3)/P(N+1,4)
11361 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
11363 IF(ABS(PEMV).LT.1D-10) THEN
11365 MINT(57)=MINT(57)+1
11369 P(N+1,3)=P(N+1,3)+PZCH
11370 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)
11372 P(I,3)=P(I,3)+V(I,1)*PZCH
11373 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11375 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
11377 C...Modify momenta in event record.
11378 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
11379 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
11380 IF(ABS(HBE).GT.0.999999D0) THEN
11382 MINT(57)=MINT(57)+1
11386 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
11395 C...Check minimum invariant mass of remnant system(s).
11396 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
11397 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
11398 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11399 PMIN(0)=SQRT(PMS(0))
11401 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
11402 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
11404 IF(MINT(44+JT).EQ.1) GOTO 340
11405 MINT(105)=MINT(102+JT)
11406 MINT(109)=MINT(106+JT)
11407 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
11408 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
11409 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
11410 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
11411 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
11412 & P(MINT(83)+JT+2,2)**2)
11414 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
11415 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
11418 MINT(57)=MINT(57)+1
11422 C...Loop over two remnants; skip if none there.
11426 IF(MINT(44+JT).EQ.1) GOTO 410
11427 IF(JT.EQ.1) IPU=IPU1
11428 IF(JT.EQ.2) IPU=IPU2
11430 C...Store first remnant parton.
11442 P(I,5)=PYMASS(K(I,2))
11444 C...First parton colour connections and kinematics.
11445 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
11448 K(I,4)=MSTU(5)*IPU+IPU
11449 K(I,5)=MSTU(5)*IPU+IPU
11450 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11451 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11452 ELSEIF(KCOL.NE.0) THEN
11454 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
11456 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11458 IF(KFLCH(JT).EQ.0) THEN
11459 P(I,1)=-P(MINT(83)+JT+2,1)
11460 P(I,2)=-P(MINT(83)+JT+2,2)
11461 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11462 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11466 C...When extra remnant parton or hadron: store extra remnant.
11478 P(I,5)=PYMASS(K(I,2))
11480 C...Find parton colour connections of extra remnant.
11481 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
11484 K(I,4)=MSTU(5)*IPU+IPU
11485 K(I,5)=MSTU(5)*IPU+IPU
11486 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11487 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11488 ELSEIF(KCOL.NE.0) THEN
11490 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
11492 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11495 C...Relative transverse momentum when two remnants.
11498 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
11499 IF(IABS(MINT(10+JT)).LT.20) THEN
11503 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
11504 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
11505 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
11506 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11508 C...Meson or baryon; photon as meson. For splitup below.
11510 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
11512 C***Relative distribution for electron into two electrons. Temporary!
11513 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
11517 C...Relative distribution of electron energy into electron plus parton.
11518 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
11521 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
11523 C...Relative distribution of energy for particle into two jets.
11524 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
11525 CHIK=PARP(92+2*IMB)
11526 IF(MSTP(92).LE.1) THEN
11527 IF(IMB.EQ.1) CHI(JT)=PYR(0)
11528 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11529 ELSEIF(MSTP(92).EQ.2) THEN
11530 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
11531 ELSEIF(MSTP(92).EQ.3) THEN
11532 CUT=2D0*0.3D0/VINT(1)
11533 380 CHI(JT)=PYR(0)**2
11534 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
11535 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
11536 ELSEIF(MSTP(92).EQ.4) THEN
11537 CUT=2D0*0.3D0/VINT(1)
11538 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11539 390 CHIR=CUT*CUTR**PYR(0)
11540 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
11541 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
11543 CUT=2D0*0.3D0/VINT(1)
11544 CUTA=CUT**(1D0-PARP(98))
11545 CUTB=(1D0+CUT)**(1D0-PARP(98))
11546 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11547 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
11548 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
11551 C...Relative distribution of energy for particle into jet plus particle.
11553 IF(MSTP(94).LE.1) THEN
11554 IF(IMB.EQ.1) CHI(JT)=PYR(0)
11555 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11556 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11557 ELSEIF(MSTP(94).EQ.2) THEN
11558 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
11559 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11560 ELSEIF(MSTP(94).EQ.3) THEN
11561 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
11564 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
11569 C...Construct total transverse mass; reject if too large.
11570 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
11571 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
11572 IF(LOOP.LT.10) THEN
11576 MINT(57)=MINT(57)+1
11580 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11581 VINT(158+JT)=CHI(JT)
11583 C...Subdivide longitudinal momentum according to value selected above.
11584 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
11585 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
11586 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
11587 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
11588 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
11593 C...Check if longitudinal boosts needed - if so pick two systems.
11594 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
11595 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
11596 IF(PDEV.LE.1D-6*VINT(1)) RETURN
11597 IF(ISN(1).EQ.0) THEN
11600 ELSEIF(ISN(2).EQ.0) THEN
11603 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
11606 ELSEIF(VINT(143).GT.0.2D0) THEN
11609 ELSEIF(VINT(144).GT.0.2D0) THEN
11612 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
11621 C...E+-pL wanted for system to be modified.
11622 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
11626 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
11627 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
11630 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
11631 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
11635 SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL))
11636 SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11637 RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3))
11639 RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3))
11641 BER=(RKR**2-1D0)/(RKR**2+1D0)
11642 BEL=-(RKL**2-1D0)/(RKL**2+1D0)
11643 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
11644 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
11648 DO 450 I=MINT(84)+1,NS
11649 IF(K(I,1).GT.10) GOTO 450
11652 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11654 IF(IORIG.GT.LPIN) GOTO 430
11655 IF(INCL.EQ.0) GOTO 450
11657 PSYS(0,J)=PSYS(0,J)+P(I,J)
11660 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11661 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
11662 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
11665 C...Construct longitudinal boosts.
11669 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
11670 IF(DSQLAM.LE.1D-6*DPMTB) THEN
11672 MINT(57)=MINT(57)+1
11675 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11676 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
11677 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
11678 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
11679 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
11680 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
11681 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
11683 C...Perform longitudinal boosts.
11684 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
11686 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
11687 ELSEIF(IR.EQ.1) THEN
11688 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
11689 ELSEIF(IDISXQ.EQ.1) THEN
11693 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11695 IF(IORIG.GT.LPIN) GOTO 460
11696 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
11699 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
11701 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
11703 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
11704 ELSEIF(IL.EQ.2) THEN
11705 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
11706 ELSEIF(IDISXQ.EQ.1) THEN
11710 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11712 IF(IORIG.GT.LPIN) GOTO 480
11713 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
11716 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
11719 C...Final check that energy-momentum conservation worked.
11722 DO 500 I=MINT(84)+1,N
11723 IF(K(I,1).GT.10) GOTO 500
11727 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
11728 IF(PDEV.GT.1D-4*VINT(1)) THEN
11730 MINT(57)=MINT(57)+1
11734 C...Calculate rotation and boost from overall CM frame to
11735 C...hadronic CM frame in leptoproduction.
11737 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
11740 IF(MINT(42).EQ.1) LESD=2
11741 LPIN=MINT(83)+3-LESD
11743 C...Sum upp momenta of everything not lepton or photon to define boost.
11748 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
11749 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
11750 IF(K(I,2).EQ.22) GOTO 530
11752 PSUM(J)=PSUM(J)+P(I,J)
11755 VINT(223)=-PSUM(1)/PSUM(4)
11756 VINT(224)=-PSUM(2)/PSUM(4)
11757 VINT(225)=-PSUM(3)/PSUM(4)
11759 C...Boost incoming hadron to hadronic CM frame to determine rotations.
11765 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
11766 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
11767 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
11769 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
11771 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
11778 C*********************************************************************
11780 *$ CREATE PYDIFF.FOR
11783 C...Handles diffractive and elastic scattering.
11787 C...Double precision and integer declarations.
11788 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11789 INTEGER PYK,PYCHGE,PYCOMP
11791 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11792 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11793 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11794 COMMON/PYINT1/MINT(400),VINT(400)
11795 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
11797 C...Reset K, P and V vectors. Store incoming particles.
11798 DO 110 JT=1,MSTP(126)+10
11818 P(I,J)=VINT(285+5*JT+J)
11823 C...Subprocess; kinematics.
11824 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
11825 PZ=SQRT(SQLAM)/(2D0*VINT(1))
11828 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
11831 C...Elastically scattered particle.
11832 IF(MINT(16+JT).LE.0) THEN
11837 P(N,3)=PZ*(-1)**(JT+1)
11839 P(N,5)=SQRT(VINT(62+JT))
11841 C...Decay rho from elastic scattering of gamma with sin**2(theta)
11842 C...distribution of decay products (in rho rest frame).
11843 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
11845 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
11849 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
11850 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
11851 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
11852 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
11853 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
11854 140 CTHE=2D0*PYR(0)-1D0
11855 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
11856 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
11858 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
11861 C...Diffracted particle: low-mass system to two particles.
11862 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
11868 PMMAS=SQRT(VINT(62+JT))
11871 IF(NTRY.LT.20) THEN
11872 MINT(105)=MINT(102+JT)
11873 MINT(109)=MINT(106+JT)
11874 CALL PYSPLI(KFH,21,KFL1,KFL2)
11875 CALL PYKFDI(KFL1,0,KFL3,KF1)
11876 IF(KF1.EQ.0) GOTO 150
11877 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
11878 IF(KF2.EQ.0) GOTO 150
11885 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
11890 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
11891 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
11894 P(N-1,4)=SQRT(PM1**2+PZP**2)
11895 P(N,4)=SQRT(PM2**2+PZP**2)
11896 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
11898 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
11899 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
11901 C...Diffracted particle: valence quark kicked out.
11902 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
11909 MINT(105)=MINT(102+JT)
11910 MINT(109)=MINT(106+JT)
11911 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
11912 P(N-1,5)=PYMASS(K(N-1,2))
11913 P(N,5)=PYMASS(K(N,2))
11914 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
11915 & 4D0*P(N-1,5)**2*P(N,5)**2
11916 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
11917 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
11918 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
11919 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
11920 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11922 C...Diffracted particle: gluon kicked out.
11931 MINT(105)=MINT(102+JT)
11932 MINT(109)=MINT(106+JT)
11933 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
11935 P(N-2,5)=PYMASS(K(N-2,2))
11937 P(N,5)=PYMASS(K(N,2))
11938 C...Energy distribution for particle into two jets.
11940 IF(MOD(KFH/1000,10).NE.0) IMB=2
11941 CHIK=PARP(92+2*IMB)
11942 IF(MSTP(92).LE.1) THEN
11943 IF(IMB.EQ.1) CHI=PYR(0)
11944 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
11945 ELSEIF(MSTP(92).EQ.2) THEN
11946 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
11947 ELSEIF(MSTP(92).EQ.3) THEN
11948 CUT=2D0*0.3D0/VINT(1)
11950 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
11952 ELSEIF(MSTP(92).EQ.4) THEN
11953 CUT=2D0*0.3D0/VINT(1)
11954 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11955 180 CHIR=CUT*CUTR**PYR(0)
11956 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
11957 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
11959 CUT=2D0*0.3D0/VINT(1)
11960 CUTA=CUT**(1D0-PARP(98))
11961 CUTB=(1D0+CUT)**(1D0-PARP(98))
11962 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11963 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
11964 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
11966 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
11967 & VINT(62+JT)) GOTO 160
11968 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
11969 IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 160
11970 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
11971 & (2D0*VINT(62+JT))
11972 PEI=SQRT(PZI**2+SQM)
11973 PQQP=(1D0-CHI)*(PEI+PZI)
11974 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
11975 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
11976 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
11977 P(N-1,3)=P(N-1,4)*(-1)**JT
11978 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
11979 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11982 C...Documentation lines.
11984 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
11985 IF(MINT(16+JT).NE.0) K(I+2,2)=10*(KFH/10)
11987 P(I+2,3)=PZ*(-1)**(JT+1)
11989 P(I+2,5)=SQRT(VINT(62+JT))
11992 C...Rotate outgoing partons/particles using cos(theta).
11993 IF(VINT(23).LT.0.9D0) THEN
11994 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
11996 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
12002 C*********************************************************************
12004 *$ CREATE PYDOCU.FOR
12007 C...Handles the documentation of the process in MSTI and PARI,
12008 C...and also computes cross-sections based on accumulated statistics.
12012 C...Double precision and integer declarations.
12013 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12014 INTEGER PYK,PYCHGE,PYCOMP
12016 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12017 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12018 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12019 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12020 COMMON/PYINT1/MINT(400),VINT(400)
12021 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12022 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
12023 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
12026 C...Calculate Monte Carlo estimates of cross-sections.
12028 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
12029 NGEN(0,3)=NGEN(0,3)+1
12032 IF(I.EQ.96.OR.I.EQ.97) THEN
12034 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
12035 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
12036 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
12037 & DBLE(NGEN(96,2)))
12038 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
12040 ELSEIF(NGEN(I,2).EQ.0) THEN
12041 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
12044 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
12047 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
12050 C...Rescale to known low-pT cross-section for standard QCD processes.
12051 IF(MSUB(95).EQ.1) THEN
12052 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
12053 & XSEC(68,3)+XSEC(95,3)
12054 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
12055 IF(XSECH.GT.1D-10.AND.XSECW.GT.1D-10) THEN
12057 XSEC(11,3)=FAC*XSEC(11,3)
12058 XSEC(12,3)=FAC*XSEC(12,3)
12059 XSEC(13,3)=FAC*XSEC(13,3)
12060 XSEC(28,3)=FAC*XSEC(28,3)
12061 XSEC(53,3)=FAC*XSEC(53,3)
12062 XSEC(68,3)=FAC*XSEC(68,3)
12063 XSEC(95,3)=FAC*XSEC(95,3)
12064 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
12068 C...Save information for gamma-p and gamma-gamma.
12069 IF(MINT(121).GT.1) THEN
12075 C...Reset information on hard interaction.
12081 C...Copy integer valued information from MINT into MSTI.
12085 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
12087 C...Store cross-section variables in PARI.
12089 PARI(2)=XSEC(0,3)/MINT(5)
12092 VINT(98)=VINT(98)+VINT(100)
12093 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
12095 C...Store kinematics variables in PARI.
12098 IF(ISUB.NE.95) THEN
12106 PARI(35)=PARI(33)-PARI(34)
12113 PARI(42)=2D0*VINT(47)/VINT(1)
12116 C...Store information on scattered partons in PARI.
12117 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
12120 PARI(36+IS)=P(I,3)/VINT(1)
12121 PARI(38+IS)=P(I,4)/VINT(1)
12122 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
12123 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12124 & SQRT(PR),1D20)),P(I,3))
12125 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
12126 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12127 & SQRT(PR),1D20)),P(I,3))
12128 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
12129 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
12130 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
12134 C...Store sum up transverse and longitudinal momenta.
12135 PARI(65)=2D0*PARI(17)
12136 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
12137 DO 150 I=MSTP(126)+1,N
12138 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
12139 PT=SQRT(P(I,1)**2+P(I,2)**2)
12140 PARI(69)=PARI(69)+PT
12141 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
12142 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
12154 C...Store various other pieces of information into PARI.
12162 C...Set information for PYTABU.
12163 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12166 ELSEIF(ISET(ISUB).EQ.5) THEN
12177 C*********************************************************************
12179 *$ CREATE PYFRAM.FOR
12182 C...Performs transformations between different coordinate frames.
12184 SUBROUTINE PYFRAM(IFRAME)
12186 C...Double precision and integer declarations.
12187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12188 INTEGER PYK,PYCHGE,PYCOMP
12190 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12191 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12192 COMMON/PYINT1/MINT(400),VINT(400)
12193 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
12195 C...Check that transformation can and should be done.
12196 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
12197 &MINT(91).EQ.1)) THEN
12198 IF(IFRAME.EQ.MINT(6)) RETURN
12200 WRITE(MSTU(11),5000) IFRAME,MINT(6)
12204 IF(MINT(6).EQ.1) THEN
12205 C...Transform from fixed target or user specified frame to
12206 C...overall CM frame.
12207 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
12208 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
12209 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
12210 ELSEIF(MINT(6).EQ.3) THEN
12211 C...Transform from hadronic CM frame in DIS to overall CM frame.
12212 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
12216 IF(IFRAME.EQ.1) THEN
12217 C...Transform from overall CM frame to fixed target or user specified
12219 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
12220 ELSEIF(IFRAME.EQ.3) THEN
12221 C...Transform from overall CM frame to hadronic CM frame in DIS.
12222 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
12223 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
12224 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
12227 C...Set information about new frame.
12231 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
12232 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
12238 C*********************************************************************
12240 *$ CREATE PYWIDT.FOR
12243 C...Calculates full and partial widths of resonances.
12245 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
12247 C...Double precision and integer declarations.
12248 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12249 INTEGER PYK,PYCHGE,PYCOMP
12250 C...Parameter statement to help give large particle numbers.
12251 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
12253 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12254 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12255 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
12256 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12257 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12258 COMMON/PYINT1/MINT(400),VINT(400)
12259 COMMON/PYINT4/MWID(500),WIDS(500,5)
12260 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
12261 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
12263 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
12264 &/PYINT4/,/PYMSSM/,/PYSSMT/
12265 C...Local arrays and saved variables.
12266 DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
12268 SAVE MOFSV,WIDWSV,WID2SV
12269 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
12271 C...Compressed code and sign; mass.
12278 C...Reset width information.
12286 C...Not to be treated as a resonance: return.
12287 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
12296 C...Treatment as a resonance based on tabulated branching ratios.
12297 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
12298 C...Loop over possible decay channels; skip irrelevant ones.
12299 DO 120 I=1,MDCY(KC,3)
12301 IF(MDME(IDC,1).LT.0) GOTO 120
12303 C...Read out decay products and nominal masses.
12306 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
12310 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
12316 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
12320 C...Naive partial width and alternative threshold factors.
12321 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
12322 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
12323 & PM1+PM2+PM3.GE.SHR) THEN
12325 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
12326 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
12327 & 4D0*PM1**2*PM2**2))/SH
12328 ELSEIF(MDME(IDC,2).EQ.52) THEN
12329 PMA=MAX(PM1,PM2,PM3)
12330 PMC=MIN(PM1,PM2,PM3)
12331 PMB=PM1+PM2+PM3-PMA-PMC
12332 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
12337 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
12338 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12339 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12340 & ((SHR-PMA)**2-(PMB+PMC)**2)*
12341 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12342 & ((1D0-PMBCN)*PMBCN*SH)
12343 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
12344 WDTP(I)=WDTP(I)*SQRT(
12345 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
12346 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
12347 ELSEIF(MDME(IDC,2).EQ.53) THEN
12348 PMA=MAX(PM1,PM2,PM3)
12349 PMC=MIN(PM1,PM2,PM3)
12350 PMB=PM1+PM2+PM3-PMA-PMC
12351 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
12356 FACACT=SQRT(MAX(0D0,
12357 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12358 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12359 & ((SHR-PMA)**2-(PMB+PMC)**2)*
12360 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12361 & ((1D0-PMBCN)*PMBCN*SH)
12362 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
12366 PMBCN=PMBC**2/PMR**2
12367 FACNOM=SQRT(MAX(0D0,
12368 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12369 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12370 & ((PMR-PMA)**2-(PMB+PMC)**2)*
12371 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
12372 & ((1D0-PMBCN)*PMBCN*PMR**2)
12373 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
12375 WDTP(0)=WDTP(0)+WDTP(I)
12377 C...Calculate secondary width (at most two identical/opposite).
12378 IF(MDME(IDC,1).GT.0) THEN
12379 IF(KFD2.EQ.KFD1) THEN
12380 IF(KCHG(KFC1,3).EQ.0) THEN
12382 ELSEIF(KFD1.GT.0) THEN
12388 WID2=WID2*WIDS(KFC3,2)
12389 ELSEIF(KFD3.LT.0) THEN
12390 WID2=WID2*WIDS(KFC3,3)
12392 ELSEIF(KFD2.EQ.-KFD1) THEN
12395 WID2=WID2*WIDS(KFC3,2)
12396 ELSEIF(KFD3.LT.0) THEN
12397 WID2=WID2*WIDS(KFC3,3)
12399 ELSEIF(KFD3.EQ.KFD1) THEN
12400 IF(KCHG(KFC1,3).EQ.0) THEN
12402 ELSEIF(KFD1.GT.0) THEN
12408 WID2=WID2*WIDS(KFC2,2)
12409 ELSEIF(KFD2.LT.0) THEN
12410 WID2=WID2*WIDS(KFC2,3)
12412 ELSEIF(KFD3.EQ.-KFD1) THEN
12415 WID2=WID2*WIDS(KFC2,2)
12416 ELSEIF(KFD2.LT.0) THEN
12417 WID2=WID2*WIDS(KFC2,3)
12419 ELSEIF(KFD3.EQ.KFD2) THEN
12420 IF(KCHG(KFC2,3).EQ.0) THEN
12422 ELSEIF(KFD2.GT.0) THEN
12428 WID2=WID2*WIDS(KFC1,2)
12429 ELSEIF(KFD1.LT.0) THEN
12430 WID2=WID2*WIDS(KFC1,3)
12432 ELSEIF(KFD3.EQ.-KFD2) THEN
12435 WID2=WID2*WIDS(KFC1,2)
12436 ELSEIF(KFD1.LT.0) THEN
12437 WID2=WID2*WIDS(KFC1,3)
12446 WID2=WID2*WIDS(KFC2,2)
12448 WID2=WID2*WIDS(KFC2,3)
12451 WID2=WID2*WIDS(KFC3,2)
12452 ELSEIF(KFD3.LT.0) THEN
12453 WID2=WID2*WIDS(KFC3,3)
12457 C...Store effective widths according to case.
12458 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12459 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12460 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12461 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12471 C...Here begins detailed dynamical calculation of resonance widths.
12472 C...Shared treatment of Higgs states.
12475 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12480 C...Common electroweak and strong constants.
12483 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12486 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
12488 RADC=1D0+AS/PARU(1)
12492 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12493 RADCT=1D0-2.5D0*AS/PARU(1)
12494 DO 130 I=1,MDCY(KC,3)
12496 IF(MDME(IDC,1).LT.0) GOTO 130
12497 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12498 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12499 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
12500 IF(I.GE.4.AND.I.LE.7) THEN
12501 C...t -> W + q; including approximate QCD correction factor.
12502 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
12503 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12504 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12507 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12510 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12512 ELSEIF(I.EQ.9) THEN
12514 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12515 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12517 IF(KFLR.LT.0) WID2=WIDS(37,3)
12519 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
12520 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
12523 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
12526 KFC1=PYCOMP(KFDP(IDC,1))
12527 KFC2=PYCOMP(KFDP(IDC,2))
12528 PMNCHI=PMAS(KFC1,1)
12529 PMSTOP=PMAS(KFC2,1)
12530 IF(SHR.GT.PMNCHI+PMSTOP) THEN
12532 AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB)
12533 AR=-ET*ZMIX(IZ,1)*TANW
12534 BL=T3L*(ZMIX(IZ,2)-ZMIX(IZ,1)*TANW)-AR
12536 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
12537 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
12538 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
12539 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
12540 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*((FL**2+FR**2)*
12541 & (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH
12543 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
12545 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
12550 WDTP(0)=WDTP(0)+WDTP(I)
12551 IF(MDME(IDC,1).GT.0) THEN
12552 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12553 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12554 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12555 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12559 ELSEIF(KFLA.EQ.7) THEN
12561 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12562 DO 140 I=1,MDCY(KC,3)
12564 IF(MDME(IDC,1).LT.0) GOTO 140
12565 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12566 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12567 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
12568 IF(I.GE.4.AND.I.LE.7) THEN
12570 WDTP(I)=FAC*VCKM(I-3,4)*
12571 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12572 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12575 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
12576 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
12579 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
12580 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
12583 IF(KFLR.LT.0) WID2=WIDS(24,2)
12584 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12586 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12587 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12590 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
12593 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
12596 WDTP(0)=WDTP(0)+WDTP(I)
12597 IF(MDME(IDC,1).GT.0) THEN
12598 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12599 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12600 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12601 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12605 ELSEIF(KFLA.EQ.8) THEN
12607 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12608 DO 150 I=1,MDCY(KC,3)
12610 IF(MDME(IDC,1).LT.0) GOTO 150
12611 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12612 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12613 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
12614 IF(I.GE.4.AND.I.LE.7) THEN
12616 WDTP(I)=FAC*VCKM(4,I-3)*
12617 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12618 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12621 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12624 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12626 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12628 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12629 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12632 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
12635 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
12638 WDTP(0)=WDTP(0)+WDTP(I)
12639 IF(MDME(IDC,1).GT.0) THEN
12640 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12641 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12642 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12643 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12647 ELSEIF(KFLA.EQ.17) THEN
12649 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12650 DO 160 I=1,MDCY(KC,3)
12652 IF(MDME(IDC,1).LT.0) GOTO 160
12653 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12654 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12655 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
12657 C...tau' -> W + nu'_tau.
12658 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12659 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12662 WID2=WID2*WIDS(18,2)
12665 WID2=WID2*WIDS(18,3)
12667 ELSEIF(I.EQ.5) THEN
12668 C...tau' -> H + nu'_tau.
12669 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12670 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12673 WID2=WID2*WIDS(18,2)
12676 WID2=WID2*WIDS(18,3)
12679 WDTP(0)=WDTP(0)+WDTP(I)
12680 IF(MDME(IDC,1).GT.0) THEN
12681 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12682 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12683 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12684 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12688 ELSEIF(KFLA.EQ.18) THEN
12689 C...nu'_tau neutrino.
12690 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12691 DO 170 I=1,MDCY(KC,3)
12693 IF(MDME(IDC,1).LT.0) GOTO 170
12694 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12695 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12696 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
12698 C...nu'_tau -> W + tau'.
12699 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12700 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12703 WID2=WID2*WIDS(17,2)
12706 WID2=WID2*WIDS(17,3)
12708 ELSEIF(I.EQ.3) THEN
12709 C...nu'_tau -> H + tau'.
12710 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12711 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12714 WID2=WID2*WIDS(17,2)
12717 WID2=WID2*WIDS(17,3)
12720 WDTP(0)=WDTP(0)+WDTP(I)
12721 IF(MDME(IDC,1).GT.0) THEN
12722 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12723 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12724 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12725 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12729 ELSEIF(KFLA.EQ.21) THEN
12731 C***Note that widths are not given in dimensional quantities here.
12732 DO 180 I=1,MDCY(KC,3)
12734 IF(MDME(IDC,1).LT.0) GOTO 180
12735 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12736 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12737 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
12740 C...QCD -> q + qbar
12741 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12742 IF(I.EQ.6) WID2=WIDS(6,1)
12743 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12745 WDTP(0)=WDTP(0)+WDTP(I)
12746 IF(MDME(IDC,1).GT.0) THEN
12747 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12748 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12749 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12750 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12754 ELSEIF(KFLA.EQ.22) THEN
12756 C***Note that widths are not given in dimensional quantities here.
12757 DO 190 I=1,MDCY(KC,3)
12759 IF(MDME(IDC,1).LT.0) GOTO 190
12760 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12761 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12762 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
12765 C...QED -> q + qbar.
12768 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12769 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12770 IF(I.EQ.6) WID2=WIDS(6,1)
12771 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12772 ELSEIF(I.LE.12) THEN
12773 C...QED -> l+ + l-.
12774 EF=KCHG(9+2*(I-8),1)/3D0
12775 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12776 IF(I.EQ.12) WID2=WIDS(17,1)
12778 WDTP(0)=WDTP(0)+WDTP(I)
12779 IF(MDME(IDC,1).GT.0) THEN
12780 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12781 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12782 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12783 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12787 ELSEIF(KFLA.EQ.23) THEN
12790 XWC=1D0/(16D0*XW*XW1)
12791 FAC=(AEM*XWC/3D0)*SHR
12793 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
12798 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12800 IF(KFI.GT.20) KFI=IABS(MINT(16))
12806 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
12807 IF(MSTP(43).EQ.3) VINT(112)=
12808 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
12809 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12810 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
12812 DO 210 I=1,MDCY(KC,3)
12814 IF(MDME(IDC,1).LT.0) GOTO 210
12815 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12816 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12817 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
12822 AF=SIGN(1D0,EF+0.1D0)
12825 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12826 IF(I.EQ.6) WID2=WIDS(6,1)
12827 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12828 ELSEIF(I.LE.16) THEN
12829 C...Z0 -> l+ + l-, nu + nubar
12831 AF=SIGN(1D0,EF+0.1D0)
12834 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
12836 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
12837 IF(ICASE.EQ.1) THEN
12838 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
12840 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12841 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
12842 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
12843 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
12844 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12845 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
12846 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
12847 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
12849 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
12850 IF(MDME(IDC,1).GT.0) THEN
12851 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
12852 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
12853 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12854 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
12855 & WDTE(I,MDME(IDC,1))
12856 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12857 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12859 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12860 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
12861 & VINT(111)+FGGF*WID2
12862 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
12863 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12864 & VINT(114)+FZZF*WID2
12868 IF(MINT(61).GE.1) ICASE=3-ICASE
12869 IF(ICASE.EQ.2) GOTO 200
12871 ELSEIF(KFLA.EQ.24) THEN
12873 FAC=(AEM/(24D0*XW))*SHR
12874 DO 220 I=1,MDCY(KC,3)
12876 IF(MDME(IDC,1).LT.0) GOTO 220
12877 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12878 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12879 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
12882 C...W+/- -> q + qbar'
12883 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
12885 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
12886 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
12887 IF(I.GE.13) WID2=WID2*WIDS(7,3)
12889 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
12890 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
12891 IF(I.GE.13) WID2=WID2*WIDS(7,2)
12893 ELSEIF(I.LE.20) THEN
12894 C...W+/- -> l+/- + nu
12897 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
12899 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
12902 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
12903 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
12904 WDTP(0)=WDTP(0)+WDTP(I)
12905 IF(MDME(IDC,1).GT.0) THEN
12906 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12907 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12908 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12909 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12913 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12914 C...h0 (or H0, or A0):
12915 IF(MSTP(49).EQ.0) THEN
12916 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
12918 FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR
12920 DO 260 I=1,MDCY(KFHIGG,3)
12921 IDC=I+MDCY(KFHIGG,2)-1
12922 IF(MDME(IDC,1).LT.0) GOTO 260
12923 KFC1=PYCOMP(KFDP(IDC,1))
12924 KFC2=PYCOMP(KFDP(IDC,2))
12925 RM1=PMAS(KFC1,1)**2/SH
12926 RM2=PMAS(KFC2,1)**2/SH
12927 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
12933 WDTP(I)=FAC*3D0*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,
12934 & 1D0-4D0*RM1))*RADC
12935 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) WDTP(I)=WDTP(I)*
12936 & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
12937 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
12938 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12939 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
12940 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
12942 IF(I.EQ.6) WID2=WIDS(6,1)
12943 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12945 ELSEIF(I.LE.12) THEN
12947 WDTP(I)=FAC*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12948 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
12949 & PARU(153+10*IHIGG)**2
12950 IF(I.EQ.12) WID2=WIDS(17,1)
12952 ELSEIF(I.EQ.13) THEN
12953 C...h0 -> g + g; quark loop contribution only
12956 DO 230 J=1,2*MSTP(1)
12957 EPS=(2D0*PMAS(J,1))**2/SH
12958 C...Loop integral; function of eps=4m^2/shat; different for A0.
12959 IF(EPS.LE.1D0) THEN
12960 IF(EPS.GT.1.D-4) THEN
12962 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
12964 RLN=LOG(4D0/EPS-2D0)
12966 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
12967 PHIIM=0.5D0*PARU(1)*RLN
12969 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
12972 IF(IHIGG.LE.2) THEN
12973 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
12974 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
12976 ETAREJ=-0.5D0*EPS*PHIRE
12977 ETAIMJ=-0.5D0*EPS*PHIIM
12979 C...Couplings (=1 for standard model Higgs).
12980 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12981 IF(MOD(J,2).EQ.1) THEN
12982 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
12983 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
12985 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
12986 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
12992 ETA2=ETARE**2+ETAIM**2
12993 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
12995 ELSEIF(I.EQ.14) THEN
12996 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
13000 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
13002 IF(J.LE.2*MSTP(1)) THEN
13004 EPS=(2D0*PMAS(J,1))**2/SH
13005 ELSEIF(J.LE.3*MSTP(1)) THEN
13006 JL=2*(J-2*MSTP(1))-1
13007 EJ=KCHG(10+JL,1)/3D0
13008 EPS=(2D0*PMAS(10+JL,1))**2/SH
13009 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13010 EPS=(2D0*PMAS(24,1))**2/SH
13012 EPS=(2D0*PMAS(37,1))**2/SH
13014 C...Loop integral; function of eps=4m^2/shat.
13015 IF(EPS.LE.1D0) THEN
13016 IF(EPS.GT.1.D-4) THEN
13018 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13020 RLN=LOG(4D0/EPS-2D0)
13022 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
13023 PHIIM=0.5D0*PARU(1)*RLN
13025 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
13028 IF(J.LE.3*MSTP(1)) THEN
13029 C...Fermion loops: loop integral different for A0; charges.
13030 IF(IHIGG.LE.2) THEN
13031 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
13032 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
13034 PHIPRE=-0.5D0*EPS*PHIRE
13035 PHIPIM=-0.5D0*EPS*PHIIM
13037 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
13039 EJH=PARU(151+10*IHIGG)
13040 ELSEIF(J.LE.2*MSTP(1)) THEN
13042 EJH=PARU(152+10*IHIGG)
13045 EJH=PARU(153+10*IHIGG)
13047 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13048 ETAREJ=EJC*EJH*PHIPRE
13049 ETAIMJ=EJC*EJH*PHIPIM
13050 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13051 C...W loops: loop integral and charges.
13052 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
13053 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
13054 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13055 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13056 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13059 C...Charged H loops: loop integral and charges.
13060 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
13061 & PARU(158+10*IHIGG+2*(IHIGG/3))
13062 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
13063 ETAIMJ=-EPS**2*PHIIM*FACHHH
13068 ETA2=ETARE**2+ETAIM**2
13069 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
13071 ELSEIF(I.EQ.15) THEN
13072 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
13076 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
13078 IF(J.LE.2*MSTP(1)) THEN
13080 AJ=SIGN(1D0,EJ+0.1D0)
13082 EPS=(2D0*PMAS(J,1))**2/SH
13083 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
13084 ELSEIF(J.LE.3*MSTP(1)) THEN
13085 JL=2*(J-2*MSTP(1))-1
13086 EJ=KCHG(10+JL,1)/3D0
13087 AJ=SIGN(1D0,EJ+0.1D0)
13089 EPS=(2D0*PMAS(10+JL,1))**2/SH
13090 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
13092 EPS=(2D0*PMAS(24,1))**2/SH
13093 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
13095 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
13096 IF(EPS.LE.1D0) THEN
13098 IF(EPS.GT.1.D-4) THEN
13099 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13101 RLN=LOG(4D0/EPS-2D0)
13103 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
13104 PHIIM=0.5D0*PARU(1)*RLN
13105 PSIRE=0.5D0*ROOT*RLN
13106 PSIIM=-0.5D0*ROOT*PARU(1)
13108 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
13110 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
13113 IF(EPSP.LE.1D0) THEN
13114 ROOT=SQRT(1D0-EPSP)
13115 IF(EPSP.GT.1.D-4) THEN
13116 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13118 RLN=LOG(4D0/EPSP-2D0)
13120 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
13121 PHIIMP=0.5D0*PARU(1)*RLN
13122 PSIREP=0.5D0*ROOT*RLN
13123 PSIIMP=-0.5D0*ROOT*PARU(1)
13125 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
13127 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
13130 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
13131 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
13132 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
13133 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
13134 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
13135 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
13136 IF(J.LE.3*MSTP(1)) THEN
13137 C...Fermion loops: loop integral different for A0; charges.
13138 IF(IHIGG.EQ.3) FXYRE=0D0
13139 IF(IHIGG.EQ.3) FXYIM=0D0
13140 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
13142 EJH=PARU(151+10*IHIGG)
13143 ELSEIF(J.LE.2*MSTP(1)) THEN
13145 EJH=PARU(152+10*IHIGG)
13148 EJH=PARU(153+10*IHIGG)
13150 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13151 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
13152 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
13153 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13154 C...W loops: loop integral and charges.
13155 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
13156 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
13157 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
13158 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13159 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13160 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13163 C...Charged H loops: loop integral and charges.
13164 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
13165 & PARU(158+10*IHIGG+2*(IHIGG/3))
13166 ETAREJ=FACHHH*FXYRE
13167 ETAIMJ=FACHHH*FXYIM
13172 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
13173 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
13176 ELSEIF(I.LE.17) THEN
13177 C...h0 -> Z0 + Z0, W+ + W-
13178 PM1=PMAS(IABS(KFDP(IDC,1)),1)
13179 PG1=PMAS(IABS(KFDP(IDC,1)),2)
13180 IF(MINT(62).GE.1) THEN
13181 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
13182 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
13183 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
13184 MOFSV(IHIGG,I-15)=0
13185 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13189 MOFSV(IHIGG,I-15)=1
13190 RMAS=SQRT(MAX(0D0,SH))
13191 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
13193 WIDWSV(IHIGG,I-15)=WIDW
13194 WID2SV(IHIGG,I-15)=WID2
13197 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
13198 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13202 WIDW=WIDWSV(IHIGG,I-15)
13203 WID2=WID2SV(IHIGG,I-15)
13206 WDTP(I)=FAC*WIDW/(2D0*(18-I))
13207 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
13208 & PARU(138+I+10*IHIGG)**2
13209 WID2=WID2*WIDS(7+I,1)
13211 ELSEIF(I.EQ.18.AND.KFLA.EQ.35) THEN
13212 C***H0 -> Z0 + h0 (not yet implemented).
13214 ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN
13216 WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2*
13217 & SQRT(MAX(0D0,1D0-4D0*RM1))
13220 ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN
13222 WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2*
13223 & SQRT(MAX(0D0,1D0-4D0*RM1))
13226 ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN
13228 WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0,
13229 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13230 WID2=WIDS(23,2)*WIDS(25,2)
13234 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13237 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13238 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13239 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13244 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13246 IF(KFC2.EQ.KFC1) THEN
13250 IF(KFDP(IDC,1).LT.0) KSGN1=3
13252 IF(KFDP(IDC,2).LT.0) KSGN2=3
13253 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13256 WDTP(0)=WDTP(0)+WDTP(I)
13257 IF(MDME(IDC,1).GT.0) THEN
13258 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13259 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13260 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13261 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13265 ELSEIF(KFLA.EQ.32) THEN
13268 XWC=1D0/(16D0*XW*XW1)
13269 FAC=(AEM*XWC/3D0)*SHR
13272 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
13280 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13281 KFAI=IABS(MINT(15))
13282 EI=KCHG(KFAI,1)/3D0
13283 AI=SIGN(1D0,EI+0.1D0)
13286 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13287 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13288 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13289 VPI=PARU(119+2*KFAIC)
13290 API=PARU(120+2*KFAIC)
13292 HZ=SHR*FAC*VINT(117)
13293 SQMZP=PMAS(32,1)**2
13294 HZP=SHR*FAC*WDTP(0)
13295 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13296 & MSTP(44).EQ.7) VINT(111)=1D0
13297 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
13298 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
13299 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
13300 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
13301 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13302 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
13303 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
13304 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
13305 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
13306 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13307 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
13309 DO 280 I=1,MDCY(KC,3)
13311 IF(MDME(IDC,1).LT.0) GOTO 280
13312 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13313 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13314 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 280
13318 C...Z'0 -> q + qbar
13320 AF=SIGN(1D0,EF+0.1D0)
13322 VPF=PARU(123-2*MOD(I,2))
13323 APF=PARU(124-2*MOD(I,2))
13325 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
13326 & PYHFTH(SH,SH*RM1,1D0)
13327 IF(I.EQ.6) WID2=WIDS(6,1)
13328 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
13329 ELSEIF(I.LE.16) THEN
13330 C...Z'0 -> l+ + l-, nu + nubar
13332 AF=SIGN(1D0,EF+0.1D0)
13334 VPF=PARU(127-2*MOD(I,2))
13335 APF=PARU(128-2*MOD(I,2))
13337 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
13339 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
13340 IF(ICASE.EQ.1) THEN
13341 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13342 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
13343 & APF**2*(1D0-4D0*RM1))*BE34
13344 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13345 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
13346 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13347 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
13348 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
13349 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
13350 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
13351 ELSEIF(MINT(61).EQ.2) THEN
13352 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
13353 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
13354 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
13355 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13356 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
13358 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
13361 ELSEIF(I.EQ.17) THEN
13363 WDTPZP=PARU(129)**2*XW1**2*
13364 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13365 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13366 IF(ICASE.EQ.1) THEN
13369 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13370 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13371 ELSEIF(MINT(61).EQ.2) THEN
13380 ELSEIF(I.EQ.18) THEN
13382 CZC=2D0*(1D0-2D0*XW)
13383 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
13384 IF(ICASE.EQ.1) THEN
13385 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
13386 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
13387 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13388 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
13389 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
13390 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
13391 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
13392 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
13393 ELSEIF(MINT(61).EQ.2) THEN
13395 FGZF=0.25D0*PARU(142)*CZC*BE34C
13396 FGZPF=0.25D0*PARU(143)*CZC*BE34C
13397 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
13398 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
13399 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
13402 ELSEIF(I.EQ.19) THEN
13403 C...Z'0 -> Z0 + gamma.
13404 ELSEIF(I.EQ.20) THEN
13406 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13407 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
13408 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
13409 IF(ICASE.EQ.1) THEN
13412 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13413 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13414 ELSEIF(MINT(61).EQ.2) THEN
13422 WID2=WIDS(23,2)*WIDS(25,2)
13423 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
13424 C...Z' -> h0 + A0 or H0 + A0.
13425 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13433 IF(ICASE.EQ.1) THEN
13434 WDTPZ=CZAH**2*BE34C
13435 WDTP(I)=FAC*CZPAH**2*BE34C
13436 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13437 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
13438 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
13440 ELSEIF(MINT(61).EQ.2) THEN
13445 FZZPF=CZAH*CZPAH*BE34C
13446 FZPZPF=CZPAH**2*BE34C
13448 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
13449 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
13451 IF(ICASE.EQ.1) THEN
13452 VINT(117)=VINT(117)+WDTPZ
13453 WDTP(0)=WDTP(0)+WDTP(I)
13455 IF(MDME(IDC,1).GT.0) THEN
13456 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
13457 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
13458 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13459 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
13460 & WDTE(I,MDME(IDC,1))
13461 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13462 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13464 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
13465 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13466 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
13467 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
13469 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
13471 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13472 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
13473 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
13475 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13476 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
13480 IF(MINT(61).GE.1) ICASE=3-ICASE
13481 IF(ICASE.EQ.2) GOTO 270
13483 ELSEIF(KFLA.EQ.34) THEN
13485 FAC=(AEM/(24D0*XW))*SHR
13486 DO 290 I=1,MDCY(KC,3)
13488 IF(MDME(IDC,1).LT.0) GOTO 290
13489 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13490 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13491 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 290
13495 C...W'+/- -> q + qbar'
13496 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
13497 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
13499 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
13500 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
13501 IF(I.GE.13) WID2=WID2*WIDS(7,3)
13503 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
13504 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
13505 IF(I.GE.13) WID2=WID2*WIDS(7,2)
13507 ELSEIF(I.LE.20) THEN
13508 C...W'+/- -> l+/- + nu
13509 FCOF=PARU(133)**2+PARU(134)**2
13511 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13513 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13516 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13517 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13518 ELSEIF(I.EQ.21) THEN
13519 C...W'+/- -> W+/- + Z0
13520 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
13521 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13522 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13523 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
13524 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
13525 ELSEIF(I.EQ.23) THEN
13526 C...W'+/- -> W+/- + h0
13527 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13528 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
13529 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13530 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13532 WDTP(0)=WDTP(0)+WDTP(I)
13533 IF(MDME(IDC,1).GT.0) THEN
13534 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13535 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13536 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13537 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13541 ELSEIF(KFLA.EQ.37) THEN
13543 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
13544 DO 300 I=1,MDCY(KC,3)
13546 IF(MDME(IDC,1).LT.0) GOTO 300
13547 KFC1=PYCOMP(KFDP(IDC,1))
13548 KFC2=PYCOMP(KFDP(IDC,2))
13549 RM1=PMAS(KFC1,1)**2/SH
13550 RM2=PMAS(KFC2,1)**2/SH
13551 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
13554 C...H+/- -> q + qbar'
13556 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) RM1R=RM1*
13557 & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
13558 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
13559 WDTP(I)=FAC*3D0*RADC*((RM1R*PARU(141)**2+RM2/PARU(141)**2)*
13560 & (1D0-RM1R-RM2)-4D0*RM1R*RM2)*
13561 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13563 IF(I.EQ.3) WID2=WIDS(6,2)
13564 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
13566 IF(I.EQ.3) WID2=WIDS(6,3)
13567 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
13569 ELSEIF(I.LE.8) THEN
13570 C...H+/- -> l+/- + nu
13571 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
13572 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-
13575 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
13577 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
13579 ELSEIF(I.EQ.9) THEN
13580 C...H+/- -> W+/- + h0.
13581 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
13582 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13583 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13584 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13588 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13591 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13592 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13593 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13598 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13601 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
13603 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
13604 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13606 WDTP(0)=WDTP(0)+WDTP(I)
13607 IF(MDME(IDC,1).GT.0) THEN
13608 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13609 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13610 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13611 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13615 ELSEIF(KFLA.EQ.38) THEN
13617 FAC=(SH/PARP(46)**2)*SHR
13618 DO 310 I=1,MDCY(KC,3)
13620 IF(MDME(IDC,1).LT.0) GOTO 310
13621 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13622 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13623 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
13626 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
13627 IF(I.EQ.2) WID2=WIDS(6,1)
13629 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
13631 WDTP(0)=WDTP(0)+WDTP(I)
13632 IF(MDME(IDC,1).GT.0) THEN
13633 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13634 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13635 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13636 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13640 ELSEIF(KFLA.EQ.39) THEN
13641 C...LQ (leptoquark).
13642 FAC=(AEM/4D0)*PARU(151)*SHR
13643 DO 320 I=1,MDCY(KC,3)
13645 IF(MDME(IDC,1).LT.0) GOTO 320
13646 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13647 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13648 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
13649 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13651 WDTP(0)=WDTP(0)+WDTP(I)
13652 IF(MDME(IDC,1).GT.0) THEN
13653 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13654 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13655 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13656 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13660 ELSEIF(KFLA.EQ.40) THEN
13662 FAC=(AEM/(12D0*XW))*SHR
13663 DO 330 I=1,MDCY(KC,3)
13665 IF(MDME(IDC,1).LT.0) GOTO 330
13666 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13667 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13668 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
13673 ELSEIF(I.LE.9) THEN
13677 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
13678 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13680 IF(I.EQ.4) WID2=WIDS(6,3)
13681 IF(I.EQ.5) WID2=WIDS(7,3)
13682 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
13683 IF(I.EQ.9) WID2=WIDS(17,3)
13685 IF(I.EQ.4) WID2=WIDS(6,2)
13686 IF(I.EQ.5) WID2=WIDS(7,2)
13687 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
13688 IF(I.EQ.9) WID2=WIDS(17,2)
13690 WDTP(0)=WDTP(0)+WDTP(I)
13691 IF(MDME(IDC,1).GT.0) THEN
13692 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13693 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13694 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13695 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13699 ELSEIF(KFLA.EQ.51.OR.KFLA.EQ.52) THEN
13700 C...Techni-pi0 and techni-pi+-:
13701 FAC=(3D0/(32D0*PARU(1)*PARP(142)**2))*SHR
13702 DO 340 I=1,MDCY(KC,3)
13704 IF(MDME(IDC,1).LT.0) GOTO 340
13705 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
13706 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
13709 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
13711 C...pi_tech -> f + f'.
13713 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
13714 WDTP(I)=FAC*FCOF*(PM1+PM2)**2*
13715 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13716 WDTP(0)=WDTP(0)+WDTP(I)
13717 IF(MDME(IDC,1).GT.0) THEN
13718 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13719 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13720 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13721 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13725 ELSEIF(KFLA.EQ.53) THEN
13726 C...Techni-pi'0 not yet implemented.
13728 ELSEIF(KFLA.EQ.54) THEN
13730 ALPRHT=2.91D0*(3D0/PARP(144))
13731 FAC=(ALPRHT/12D0)*SHR
13732 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)
13734 GMMZ=PMAS(23,1)*PMAS(23,2)
13735 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13736 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13737 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13738 DO 350 I=1,MDCY(KC,3)
13740 IF(MDME(IDC,1).LT.0) GOTO 350
13741 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13742 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13743 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 350
13745 C...rho_tech0 -> W+ + W-.
13746 WDTP(I)=FAC*PARP(141)**4*
13747 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13749 ELSEIF(I.EQ.2) THEN
13750 C...rho_tech0 -> W+ + pi_tech-.
13751 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13752 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13753 WID2=WIDS(24,2)*WIDS(52,3)
13754 ELSEIF(I.EQ.3) THEN
13755 C...rho_tech0 -> pi_tech+ + W-.
13756 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13757 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13758 WID2=WIDS(52,2)*WIDS(24,3)
13759 ELSEIF(I.EQ.4) THEN
13760 C...rho_tech0 -> pi_tech+ + pi_tech-.
13761 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13762 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13765 C...rho_tech0 -> f + fbar.
13770 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13774 IF(IA.GE.17) WID2=WIDS(IA,1)
13777 AI=SIGN(1D0,EI+0.1D0)
13781 WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13782 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
13783 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
13785 WDTP(0)=WDTP(0)+WDTP(I)
13786 IF(MDME(IDC,1).GT.0) THEN
13787 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13788 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13789 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13790 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13794 ELSEIF(KFLA.EQ.55) THEN
13796 ALPRHT=2.91D0*(3D0/PARP(144))
13797 FAC=(ALPRHT/12D0)*SHR
13799 GMMW=PMAS(24,1)*PMAS(24,2)
13800 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13801 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
13802 DO 360 I=1,MDCY(KC,3)
13804 IF(MDME(IDC,1).LT.0) GOTO 360
13805 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13806 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13807 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
13809 C...rho_tech+ -> W+ + Z0.
13810 WDTP(I)=FAC*PARP(141)**4*
13811 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13813 WID2=WIDS(24,2)*WIDS(23,2)
13815 WID2=WIDS(24,3)*WIDS(23,2)
13817 ELSEIF(I.EQ.2) THEN
13818 C...rho_tech+ -> W+ + pi_tech0.
13819 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13820 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13822 WID2=WIDS(24,2)*WIDS(51,2)
13824 WID2=WIDS(24,3)*WIDS(51,2)
13826 ELSEIF(I.EQ.3) THEN
13827 C...rho_tech+ -> pi_tech+ + Z0.
13828 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13829 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13831 WID2=WIDS(52,2)*WIDS(23,2)
13833 WID2=WIDS(52,3)*WIDS(23,2)
13835 ELSEIF(I.EQ.4) THEN
13836 C...rho_tech+ -> pi_tech+ + pi_tech0.
13837 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13838 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13840 WID2=WIDS(52,2)*WIDS(51,2)
13842 WID2=WIDS(52,3)*WIDS(51,2)
13845 C...rho_tech+ -> f + fbar'.
13849 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
13851 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
13852 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
13853 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
13855 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
13856 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
13857 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
13862 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13864 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13867 WDTP(I)=FACF*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13868 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13870 WDTP(0)=WDTP(0)+WDTP(I)
13871 IF(MDME(IDC,1).GT.0) THEN
13872 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13873 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13874 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13875 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13879 ELSEIF(KFLA.EQ.56) THEN
13881 ALPRHT=2.91D0*(3D0/PARP(144))
13882 FAC=(AEM/24D0)*(SHR**3/PARP(145)**2)
13883 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13884 & (2D0*PARP(143)-1D0)**2
13886 GMMZ=PMAS(23,1)*PMAS(23,2)
13887 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13888 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13889 DO 370 I=1,MDCY(KC,3)
13891 IF(MDME(IDC,1).LT.0) GOTO 370
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 370
13896 C...omega_tech0 -> gamma + pi_tech0.
13898 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13900 ELSEIF(I.EQ.2) THEN
13901 C...omega_tech0 -> Z0 + pi_tech0 not known.
13903 WID2=WIDS(23,2)*WIDS(51,2)
13905 C...omega_tech0 -> f + fbar.
13910 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13914 IF(IA.GE.17) WID2=WIDS(IA,1)
13917 AI=SIGN(1D0,EI+0.1D0)
13921 WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13922 & ((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
13923 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
13925 WDTP(0)=WDTP(0)+WDTP(I)
13926 IF(MDME(IDC,1).GT.0) THEN
13927 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13928 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13929 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13930 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13934 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
13935 C...d* excited quark.
13936 FAC=(SH/PARU(155)**2)*SHR
13937 DO 380 I=1,MDCY(KC,3)
13939 IF(MDME(IDC,1).LT.0) GOTO 380
13940 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13941 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13942 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
13945 WDTP(I)=FAC*AS*PARU(159)**2/3D0
13947 ELSEIF(I.EQ.2) THEN
13948 C...d* -> gamma + d.
13949 QF=-PARU(157)/2D0+PARU(158)/6D0
13950 WDTP(I)=FAC*AEM*QF**2/4D0
13952 ELSEIF(I.EQ.3) THEN
13954 QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13955 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13956 & (1D0-RM1)**2*(2D0+RM1)
13958 ELSEIF(I.EQ.4) THEN
13960 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13961 & (1D0-RM1)**2*(2D0+RM1)
13962 IF(KFLR.GT.0) WID2=WIDS(24,3)
13963 IF(KFLR.LT.0) WID2=WIDS(24,2)
13965 WDTP(0)=WDTP(0)+WDTP(I)
13966 IF(MDME(IDC,1).GT.0) THEN
13967 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13968 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13969 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13970 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13974 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
13975 C...u* excited quark.
13976 FAC=(SH/PARU(155)**2)*SHR
13977 DO 390 I=1,MDCY(KC,3)
13979 IF(MDME(IDC,1).LT.0) GOTO 390
13980 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13981 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13982 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
13985 WDTP(I)=FAC*AS*PARU(159)**2/3D0
13987 ELSEIF(I.EQ.2) THEN
13988 C...u* -> gamma + u.
13989 QF=PARU(157)/2D0+PARU(158)/6D0
13990 WDTP(I)=FAC*AEM*QF**2/4D0
13992 ELSEIF(I.EQ.3) THEN
13994 QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13995 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13996 & (1D0-RM1)**2*(2D0+RM1)
13998 ELSEIF(I.EQ.4) THEN
14000 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14001 & (1D0-RM1)**2*(2D0+RM1)
14002 IF(KFLR.GT.0) WID2=WIDS(24,2)
14003 IF(KFLR.LT.0) WID2=WIDS(24,3)
14005 WDTP(0)=WDTP(0)+WDTP(I)
14006 IF(MDME(IDC,1).GT.0) THEN
14007 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14008 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14009 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14010 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14014 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
14015 C...e* excited lepton.
14016 FAC=(SH/PARU(155)**2)*SHR
14017 DO 400 I=1,MDCY(KC,3)
14019 IF(MDME(IDC,1).LT.0) GOTO 400
14020 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14021 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14022 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 400
14024 C...e* -> gamma + e.
14025 QF=-PARU(157)/2D0-PARU(158)/2D0
14026 WDTP(I)=FAC*AEM*QF**2/4D0
14028 ELSEIF(I.EQ.2) THEN
14030 QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
14031 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
14032 & (1D0-RM1)**2*(2D0+RM1)
14034 ELSEIF(I.EQ.3) THEN
14036 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14037 & (1D0-RM1)**2*(2D0+RM1)
14038 IF(KFLR.GT.0) WID2=WIDS(24,3)
14039 IF(KFLR.LT.0) WID2=WIDS(24,2)
14041 WDTP(0)=WDTP(0)+WDTP(I)
14042 IF(MDME(IDC,1).GT.0) THEN
14043 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14044 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14045 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14046 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14050 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
14051 C...nu*_e excited neutrino.
14052 FAC=(SH/PARU(155)**2)*SHR
14053 DO 410 I=1,MDCY(KC,3)
14055 IF(MDME(IDC,1).LT.0) GOTO 410
14056 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14057 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14058 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
14060 C...nu*_e -> Z0 + nu*_e.
14061 QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
14062 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
14063 & (1D0-RM1)**2*(2D0+RM1)
14065 ELSEIF(I.EQ.2) THEN
14066 C...nu*_e -> W+ + e.
14067 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14068 & (1D0-RM1)**2*(2D0+RM1)
14069 IF(KFLR.GT.0) WID2=WIDS(24,2)
14070 IF(KFLR.LT.0) WID2=WIDS(24,3)
14072 WDTP(0)=WDTP(0)+WDTP(I)
14073 IF(MDME(IDC,1).GT.0) THEN
14074 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14075 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14076 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14077 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14089 C***********************************************************************
14091 *$ CREATE PYOFSH.FOR
14094 C...Calculates partial width and differential cross-section maxima
14095 C...of channels/processes not allowed on mass-shell, and selects
14096 C...masses in such channels/processes.
14098 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
14100 C...Double precision and integer declarations.
14101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14102 INTEGER PYK,PYCHGE,PYCOMP
14104 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14105 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14106 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
14107 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14108 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14109 COMMON/PYINT1/MINT(400),VINT(400)
14110 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14111 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14112 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
14115 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
14116 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
14117 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:200),
14120 C...Find if particles equal, maximum mass, matrix elements, etc.
14126 IF(KFD(1).EQ.KFD(2)) MEQL=1
14128 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
14129 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
14135 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
14138 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
14139 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
14140 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
14141 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
14142 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
14143 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
14146 C...Find where Breit-Wigners are required, else select discrete masses.
14148 KFCA=PYCOMP(KFD(I))
14150 PMD(I)=PMAS(KFCA,1)
14151 PGD(I)=PMAS(KFCA,2)
14156 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
14159 RMG(I)=(PMG(I)/PMMX)**2
14165 C...Find allowed mass range and Breit-Wigner parameters.
14167 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
14169 PMU(I)=PMMX-PARP(42)
14170 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14171 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14172 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
14174 IF(MLM.EQ.2) ILM=3-I
14175 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
14176 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
14177 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=MIN(PMU(I),
14178 & CKIN(NOFF+2*ILM))
14179 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14180 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14181 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14182 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14183 IF(MBW(I).EQ.1) THEN
14184 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14185 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14186 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14189 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
14191 IF(MLM.EQ.2) ILM=3-I
14192 PML(I)=MAX(CKIN(48+I),PARP(42))
14193 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
14194 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14195 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14196 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14197 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14198 IF(MBW(I).EQ.1) THEN
14199 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14200 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14201 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14206 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
14208 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
14213 C...Calculation of partial width of resonance.
14214 IF(MOFSH.EQ.1) THEN
14216 C..If only one integration, pick that to be the inner.
14217 IF(MBW(1).EQ.0) THEN
14223 ELSEIF(MBW(2).EQ.0) THEN
14227 C...Start outer loop of integration.
14228 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14229 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14230 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14236 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14237 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
14238 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
14242 C...Start inner loop of integration.
14244 PMU1=MIN(PMU(1),PMMX-PM2)
14245 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
14246 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14247 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14248 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
14256 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
14257 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
14260 C...Evaluate function value - inner loop.
14261 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
14262 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
14263 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
14264 & RM2**2+10D0*RM1*RM2)
14265 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
14268 C...Go to next position in inner loop.
14274 ELSEIF(NPT1.LE.8) THEN
14276 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
14278 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14279 INX1(NPT1)=INX1(ISH1)
14282 ELSEIF(NPT1.LT.100) THEN
14285 IF(ISH1.GT.NPT1) ISH1=2
14286 IF(ISH1.EQ.ISN1) GOTO 160
14287 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
14288 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
14290 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14291 INX1(NPT1)=INX1(ISH1)
14296 C...Calculate integral over inner loop.
14299 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
14300 & (XPT1(INX1(IPT1))-XPT1(IPT1))
14302 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
14303 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14304 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
14307 C...Go to next position in outer loop.
14313 ELSEIF(NPT2.LE.8) THEN
14315 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
14317 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14318 INX2(NPT2)=INX2(ISH2)
14321 ELSEIF(NPT2.LT.100) THEN
14324 IF(ISH2.GT.NPT2) ISH2=2
14325 IF(ISH2.EQ.ISN2) GOTO 200
14326 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
14327 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
14329 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14330 INX2(NPT2)=INX2(ISH2)
14335 C...Calculate integral over outer loop.
14338 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
14339 & (XPT2(INX2(IPT2))-XPT2(IPT2))
14341 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
14342 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
14347 C...Save result; second integration for user-selected mass range.
14348 IF(LOOP.EQ.1) WIDW=FSUM2
14350 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
14351 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
14358 C...Select two decay product masses of a resonance.
14359 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
14361 IF(MBW(I).EQ.0) GOTO 230
14362 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
14364 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
14365 RMG(I)=(PMG(I)/PMMX)**2
14367 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14368 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
14370 C...Weight with matrix element (if none known, use beta factor).
14371 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
14373 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
14374 ELSEIF(MMED.EQ.2) THEN
14375 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
14376 & RMG(2)**2+10D0*RMG(1)*RMG(2))
14377 ELSEIF(MMED.EQ.3) THEN
14378 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
14382 IF(WTBE.LT.PYR(0)) GOTO 220
14386 C...Find suitable set of masses for initialization of 2 -> 2 processes.
14387 ELSEIF(MOFSH.EQ.3) THEN
14388 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
14389 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
14391 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
14393 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
14397 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
14398 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
14399 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
14404 C...Evaluate importance of excluded tails of Breit-Wigners.
14405 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14406 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14410 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
14414 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
14415 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
14417 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
14418 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
14419 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
14420 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14422 C...Pick one particle to be the lighter (if improves efficiency).
14423 ELSEIF(MOFSH.EQ.4) THEN
14424 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14425 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14426 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
14428 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
14430 IF(MBW(I).EQ.0) GOTO 270
14432 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14434 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14436 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14437 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
14438 IF(RBR.LT.0.8D0) THEN
14439 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
14440 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
14441 ELSEIF(RBR.LT.0.9D0) THEN
14442 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
14443 ELSEIF(RBR.LT.1.5D0) THEN
14444 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
14446 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
14447 & (PMV**2-PML(I)**2))))
14450 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14451 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
14452 IF(MINT(48).EQ.1) THEN
14453 NGEN(0,1)=NGEN(0,1)+1
14454 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
14464 C...Give weight for selected mass distribution.
14467 IF(MBW(I).EQ.0) GOTO 280
14469 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14471 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14472 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
14473 & (PMD(I)*PGD(I))**2)/PARU(1)
14477 FI0=(ATV-ATL(I))/PARU(1)
14478 FI1=PMV**2-PML(I)**2
14479 FI2=2D0*LOG(PMV/PML(I))
14480 FI3=1D0/PML(I)**2-1D0/PMV**2
14481 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14482 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
14483 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
14486 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
14488 VINT(80)=VINT(80)*FI0
14490 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14496 C***********************************************************************
14498 *$ CREATE PYRECO.FOR
14501 C...Handles the possibility of colour reconnection in W+W- events,
14502 C...Based on the main scenarios of the Sjostrand and Khoze study:
14503 C...I, II, II', intermediate and instantaneous; plus one model
14504 C...along the lines of the Gustafson and Hakkinen: GH.
14506 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
14508 C...Double precision and integer declarations.
14509 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14510 INTEGER PYK,PYCHGE,PYCOMP
14511 C...Parameter value; number of points in MC integration.
14512 PARAMETER (NPT=100)
14514 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14515 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14516 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14517 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14518 COMMON/PYINT1/MINT(400),VINT(400)
14519 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14521 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
14522 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
14523 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
14524 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
14525 &TMC(20),IJOIN(100)
14527 C...Functions to give four-product and to do determinants.
14528 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)
14529 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
14530 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
14531 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
14533 C...Only allow fraction of recoupling for GH, intermediate and
14535 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14536 IF(PYR(0).GT.PARP(120)) RETURN
14539 C...Common part for scenarios I, II, II', and GH.
14540 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
14541 &MSTP(115).EQ.5) THEN
14543 C...Read out frequently-used parameters.
14554 C...Find range of decay products of the W's.
14555 C...Background: the W's are stored in IW1 and IW2.
14556 C...Their direct decay products in NSD1+1 through NSD1+4.
14557 C...Products after shower (if any) in NSD1+5 through NAFT1
14558 C...for first W and in NAFT1+1 through N for the second.
14559 IF(K(IW1,2).GT.0) THEN
14565 IF(NAFT1.GT.NSD1+4) THEN
14572 IF(N.GT.NAFT1) THEN
14580 C...Rearrange parton shower products along strings.
14582 CALL PYPREP(NSD1+1)
14584 C...Find partons pointing back to W+ and W-; store them with quark
14585 C...end of string first.
14591 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
14592 IF(IABS(K(I,2)).GE.22) GOTO 120
14593 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
14594 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
14604 IF(K(I,1).EQ.1) ISGP=0
14605 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
14606 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
14616 IF(K(I,1).EQ.1) ISGM=0
14620 C...Boost to W+W- rest frame (not strictly needed).
14622 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
14624 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14625 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14626 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14628 C...Select decay vertices of W+ and W-.
14629 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
14630 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
14631 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
14632 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
14635 XP(J)=TP*P(IW1,J)/P(IW1,4)
14636 XM(J)=TM*P(IW2,J)/P(IW2,4)
14639 C...Begin scenario I specifics.
14640 IF(MSTP(115).EQ.1) THEN
14642 C...Reconstruct velocity and direction of W+ string pieces.
14644 IF(K(INP(IIP),2).LT.0) GOTO 170
14647 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14648 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14652 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
14653 DIRP(IIP,J)=V1(J)-V2(J)
14655 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
14657 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
14659 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
14663 C...Reconstruct velocity and direction of W- string pieces.
14665 IF(K(INM(IIM),2).LT.0) GOTO 200
14668 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14669 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14673 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
14674 DIRM(IIM,J)=V1(J)-V2(J)
14676 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
14678 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
14680 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
14684 C...Loop over number of space-time points.
14689 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
14690 R=SQRT(-LOG(PYR(0)))
14692 X=BLOWR*RHAD*R*COS(PHI)
14693 Y=BLOWR*RHAD*R*SIN(PHI)
14694 R=SQRT(-LOG(PYR(0)))
14696 Z=BLOWR*RHAD*R*COS(PHI)
14697 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
14699 C...Weight for sample distribution.
14700 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
14701 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
14703 C...Loop over W+ string pieces and find one with largest weight.
14711 IF(K(INP(IIP),2).LT.0) GOTO 220
14712 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
14713 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
14715 XB(J)=XD(J)+BEDG*BETP(IIP,J)
14717 XB(4)=BETP(IIP,4)*(XD(4)-BED)
14718 SR2=XB(1)**2+XB(2)**2+XB(3)**2
14719 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
14720 & DIRP(IIP,3)*XB(3))**2
14721 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14723 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
14724 IF(WTP.GT.WTMAXP) THEN
14730 C...Loop over W- string pieces and find one with largest weight.
14738 IF(K(INM(IIM),2).LT.0) GOTO 240
14739 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
14740 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
14742 XB(J)=XD(J)+BEDG*BETM(IIM,J)
14744 XB(4)=BETM(IIM,4)*(XD(4)-BED)
14745 SR2=XB(1)**2+XB(2)**2+XB(3)**2
14746 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
14747 & DIRM(IIM,3)*XB(3))**2
14748 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14750 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
14751 IF(WTM.GT.WTMAXM) THEN
14757 C...Result of integration.
14759 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
14760 WT=WTMAXP*WTMAXM/WTSMP
14768 RES=BLOWR**3*BLOWT*SUM/NPT
14770 C...Decide whether to reconnect and, if so, where.
14772 PREC=1D0-EXP(-FACT*RES)
14773 IF(PREC.GT.PYR(0)) THEN
14778 IF(RSUM.LE.0D0) GOTO 270
14784 C...Begin scenario II and II' specifics.
14785 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
14787 C...Loop through all string pieces, one from W+ and one from W-.
14791 IF(K(INP(IIP),2).LT.0) GOTO 340
14795 IF(K(INM(IIM),2).LT.0) GOTO 330
14799 C...Find endpoint velocity vectors.
14801 V1P(J)=P(I1P,J)/P(I1P,4)
14802 V2P(J)=P(I2P,J)/P(I2P,4)
14803 V1M(J)=P(I1M,J)/P(I1M,4)
14804 V2M(J)=P(I2M,J)/P(I2M,4)
14807 C...Define q matrix and find t.
14809 Q(1,J)=V2P(J)-V1P(J)
14810 Q(2,J)=-(V2M(J)-V1M(J))
14811 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
14812 Q(4,J)=V1P(J)-V1M(J)
14814 T=-DETER(1,2,3)/DETER(1,2,4)
14816 C...Find alpha and beta; i.e. coordinates of crossing point.
14819 S13=Q(3,1)+Q(4,1)*T
14822 S23=Q(3,2)+Q(4,2)*T
14823 DEN=S11*S22-S12*S21
14824 ALP=(S12*S23-S22*S13)/DEN
14825 BET=(S21*S13-S11*S23)/DEN
14827 C...Check if solution acceptable.
14829 IF(T.LT.GTMAX) IANSW=0
14830 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
14831 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
14833 C...Find point of crossing and check that not inconsistent.
14835 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
14836 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
14838 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
14839 & (XPP(3)-XMM(3))**2
14840 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
14841 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
14842 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
14844 C...Find string eigentimes at crossing.
14845 IF(IANSW.EQ.1) THEN
14846 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
14847 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
14848 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
14849 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
14855 C...Order crossings by time. End loop over crossings.
14856 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
14858 DO 310 I1=NCROSS,1,-1
14859 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
14879 C...Loop over crossings; find first (if any) acceptable one.
14881 IF(NCROSS.GE.1) THEN
14883 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
14884 IF(PNFRAG.GT.PYR(0)) THEN
14885 C...Scenario II: only compare with fragmentation time.
14886 IF(MSTP(115).EQ.2) THEN
14891 C...Scenario II': also require that string length decreases.
14899 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14900 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14901 IF(ELNEW.LT.ELOLD) THEN
14913 C...Begin scenario GH specifics.
14914 ELSEIF(MSTP(115).EQ.5) THEN
14916 C...Loop through all string pieces, one from W+ and one from W-.
14920 IF(K(INP(IIP),2).LT.0) GOTO 380
14924 IF(K(INM(IIM),2).LT.0) GOTO 370
14928 C...Look for largest decrease of (exponent of) Lambda measure.
14929 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14930 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14931 ELDIF=ELNEW/MAX(1D-10,ELOLD)
14932 IF(ELDIF.LT.ELMIN) THEN
14944 C...Common for scenarios I, II, II' and GH: reconnect strings.
14948 DO 390 IS=1,NNP+NNM
14952 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
14954 ELSEIF(IS.LE.IIP+NNM) THEN
14955 I=INM(IS-IIP-NNM+IIM)
14960 IF(K(I,2).LT.0) THEN
14961 CALL PYJOIN(NJOIN,IJOIN)
14966 C...Restore original event record if no reconnection.
14968 DO 400 I=NSD1+1,NOLD
14969 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
14970 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14971 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14980 C...Boost back system.
14981 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14982 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14983 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
14984 & BEWW(1),BEWW(2),BEWW(3))
14986 C...Common part for intermediate and instantaneous scenarios.
14987 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14990 C...Remove old shower products and reset showering ones.
14992 DO 420 I=NSD1+1,NSD1+4
14994 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14995 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14998 C...Identify quark-antiquark pairs.
15002 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
15005 C...Reconnect strings.
15008 CALL PYJOIN(2,IJOIN)
15011 CALL PYJOIN(2,IJOIN)
15013 C...Do new parton showers in intermediate scenario.
15014 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
15017 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
15018 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
15021 C...Do new parton showers in instantaneous scenario.
15022 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
15023 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
15024 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
15025 PPM=SQRT(MAX(0D0,PPM2))
15026 CALL PYSHOW(IQ1,IQ4,PPM)
15027 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
15028 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
15029 PPM=SQRT(MAX(0D0,PPM2))
15030 CALL PYSHOW(IQ3,IQ2,PPM)
15037 C***********************************************************************
15039 *$ CREATE PYKLIM.FOR
15042 C...Checks generated variables against pre-set kinematical limits;
15043 C...also calculates limits on variables used in generation.
15045 SUBROUTINE PYKLIM(ILIM)
15047 C...Double precision and integer declarations.
15048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15049 INTEGER PYK,PYCHGE,PYCOMP
15051 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15052 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15053 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15054 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15055 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15056 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15057 COMMON/PYINT1/MINT(400),VINT(400)
15058 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15059 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15062 C...Common kinematical expressions.
15066 IF(ISUB.EQ.96) GOTO 100
15070 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
15071 CKIN09=MAX(CKIN(9),CKIN(13))
15072 CKIN10=MIN(CKIN(10),CKIN(14))
15073 CKIN11=MAX(CKIN(11),CKIN(15))
15074 CKIN12=MIN(CKIN(12),CKIN(16))
15076 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
15077 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
15078 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
15079 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
15084 RM3=SQM3/(TAU*VINT(2))
15085 RM4=SQM4/(TAU*VINT(2))
15086 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
15089 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
15090 &PTHMIN=MAX(CKIN(3),CKIN(5))
15093 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
15094 C...pre-set kinematical limits.
15099 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
15100 X1=SQRT(TAUE)*EXP(YST)
15101 X2=SQRT(TAUE)*EXP(-YST)
15103 IF(MINT(47).NE.1) THEN
15104 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
15105 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
15106 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
15107 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
15109 IF(MINT(45).NE.1) THEN
15110 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
15112 IF(MINT(46).NE.1) THEN
15113 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
15115 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
15116 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
15117 EXPY3=MAX(1.D-10,(1D0+RM3-RM4+BE34*CTH)/
15118 & MAX(1.D-10,(1D0+RM3-RM4-BE34*CTH)))
15119 EXPY4=MAX(1.D-10,(1D0-RM3+RM4-BE34*CTH)/
15120 & MAX(1.D-10,(1D0-RM3+RM4+BE34*CTH)))
15121 Y3=YST+0.5D0*LOG(EXPY3)
15122 Y4=YST+0.5D0*LOG(EXPY4)
15127 STH=SQRT(MAX(0D0,1D0-CTH**2))
15128 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
15129 & CTH)**2-4D0*RM3))
15130 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
15131 & CTH)**2-4D0*RM4))
15132 IF(STH.GE.1.D-6) THEN
15133 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
15135 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
15137 ETA3=LOG(MIN(1.D10,MAX(1.D-10,EXPET3)))
15138 ETA4=LOG(MIN(1.D10,MAX(1.D-10,EXPET4)))
15139 ETALAR=MAX(ETA3,ETA4)
15140 ETASMA=MIN(ETA3,ETA4)
15142 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
15143 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
15144 CTSLAR=MIN(1D0,MAX(CTS3,CTS4))
15145 CTSSMA=MAX(-1D0,MIN(CTS3,CTS4))
15147 RPTS=4D0*VINT(71)**2/SH
15148 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
15149 RM34=MAX(1D-20,2D0*RM3*RM4)
15150 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15151 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15152 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
15153 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
15154 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
15155 IF(PTH.LT.PTHMIN) MINT(51)=1
15156 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
15157 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
15158 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
15159 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
15160 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
15161 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
15162 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
15163 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
15164 IF(THA.LT.CKIN(35)) MINT(51)=1
15165 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
15166 IF(UHA.LT.CKIN(37)) MINT(51)=1
15167 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
15169 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
15170 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
15171 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
15174 C...Additional cuts on W2 (approximately) in DIS.
15175 IF(ISUB.EQ.10) THEN
15177 IF(IABS(MINT(12)).LT.20) XBJ=X1
15179 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
15180 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
15181 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
15184 ELSEIF(ILIM.EQ.1) THEN
15185 C...Calculate limits on tau
15186 C...0) due to definition
15189 C...1) due to limits on subsystem mass
15190 TAUMN1=CKIN(1)**2/VINT(2)
15192 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
15193 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15194 TM3=SQRT(SQM3+PTHMIN**2)
15195 TM4=SQRT(SQM4+PTHMIN**2)
15197 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
15198 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
15200 C...3) due to limits on pT-hat and cos(theta-hat)
15201 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
15202 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
15204 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
15205 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
15206 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
15208 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
15209 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
15210 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
15211 C...4) due to limits on x1 and x2
15212 TAUMN4=CKIN(21)*CKIN(23)
15213 TAUMX4=CKIN(22)*CKIN(24)
15214 C...5) due to limits on xF
15216 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
15217 C...6) due to limits on that and uhat
15218 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
15220 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
15221 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
15223 C...Net effect of all separate limits.
15224 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
15225 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
15226 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15229 ELSEIF(MINT(47).EQ.5) THEN
15230 VINT(31)=MIN(VINT(31),0.999998D0)
15232 IF(VINT(31).LE.VINT(11)) MINT(51)=1
15234 ELSEIF(ILIM.EQ.2) THEN
15235 C...Calculate limits on y*
15237 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15239 C...0) due to kinematics
15242 C...1) due to explicit limits
15245 C...2) due to limits on x1
15246 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
15247 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
15248 C...3) due to limits on x2
15249 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
15250 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
15251 C...4) due to limits on xF
15252 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
15253 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
15254 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
15255 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
15256 C...5) due to simultaneous limits on y-large and y-small
15257 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
15258 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
15259 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
15260 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
15261 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
15262 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
15263 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15265 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
15266 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
15267 RZMX=BE34*MIN(CKIN(28),CTHLIM)
15268 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
15269 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
15270 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
15271 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
15272 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
15273 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
15275 C...Net effect of all separate limits.
15276 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
15277 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
15278 IF(MINT(47).EQ.1) THEN
15279 VINT(12)=-0.00001D0
15281 ELSEIF(MINT(47).EQ.2) THEN
15282 VINT(12)=0.99999D0*YSTMX0
15283 VINT(32)=1.00001D0*YSTMX0
15284 ELSEIF(MINT(47).EQ.3) THEN
15285 VINT(12)=-1.00001D0*YSTMX0
15286 VINT(32)=-0.99999D0*YSTMX0
15287 ELSEIF(MINT(47).EQ.5) THEN
15288 YSTEE=LOG(0.999999D0/TAURT)
15289 VINT(12)=MAX(VINT(12),-YSTEE)
15290 VINT(32)=MIN(VINT(32),YSTEE)
15292 IF(VINT(32).LE.VINT(12)) MINT(51)=1
15294 ELSEIF(ILIM.EQ.3) THEN
15295 C...Calculate limits on cos(theta-hat)
15297 C...0) due to definition
15302 C...1) due to explicit limits
15303 CTNMN1=MIN(0D0,CKIN(27))
15304 CTNMX1=MIN(0D0,CKIN(28))
15305 CTPMN1=MAX(0D0,CKIN(27))
15306 CTPMX1=MAX(0D0,CKIN(28))
15307 C...2) due to limits on pT-hat
15308 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
15312 IF(CKIN(4).GE.0D0) THEN
15313 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
15314 & (BE34**2*TAU*VINT(2))))
15317 C...3) due to limits on y-large and y-small
15318 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
15319 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
15320 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
15321 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
15322 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
15323 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
15324 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
15325 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
15326 C...4) due to limits on that
15332 IF(CKIN(35).GT.0D0) THEN
15333 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
15334 IF(CTLIM.GT.0D0) THEN
15341 IF(CKIN(36).GT.0D0) THEN
15342 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
15343 IF(CTLIM.LT.0D0) THEN
15350 C...5) due to limits on uhat
15355 IF(CKIN(37).GT.0D0) THEN
15356 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
15357 IF(CTLIM.LT.0D0) THEN
15364 IF(CKIN(38).GT.0D0) THEN
15365 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
15366 IF(CTLIM.GT.0D0) THEN
15374 C...Net effect of all separate limits.
15375 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
15376 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
15377 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
15378 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
15379 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
15381 ELSEIF(ILIM.EQ.4) THEN
15382 C...Calculate limits on tau'
15383 C...0) due to kinematics
15385 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
15386 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
15387 TAPMN0=(SQRT(TAU)+PQRAT)**2
15390 C...1) due to explicit limits
15391 TAPMN1=CKIN(31)**2/VINT(2)
15393 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
15395 C...Net effect of all separate limits.
15396 VINT(16)=MAX(TAPMN0,TAPMN1)
15397 VINT(36)=MIN(TAPMX0,TAPMX1)
15398 IF(MINT(47).EQ.1) THEN
15402 IF(VINT(36).LE.VINT(16)) MINT(51)=1
15407 C...Special case for low-pT and multiple interactions:
15408 C...effective kinematical limits for tau, y*, cos(theta-hat).
15409 100 IF(ILIM.EQ.0) THEN
15410 ELSEIF(ILIM.EQ.1) THEN
15411 IF(MSTP(82).LE.1) VINT(11)=4D0*PARP(81)**2/VINT(2)
15412 IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
15414 ELSEIF(ILIM.EQ.2) THEN
15415 VINT(12)=0.5D0*LOG(VINT(21))
15417 ELSEIF(ILIM.EQ.3) THEN
15418 IF(MSTP(82).LE.1) ST2EFF=4D0*PARP(81)**2/(VINT(21)*VINT(2))
15419 IF(MSTP(82).GE.2) ST2EFF=0.01D0*PARP(82)**2/(VINT(21)*VINT(2))
15420 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
15429 C*********************************************************************
15431 *$ CREATE PYKMAP.FOR
15434 C...Maps a uniform distribution into a distribution of a kinematical
15435 C...variable according to one of the possibilities allowed. It is
15436 C...assumed that kinematical limits have been set by a PYKLIM call.
15438 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
15440 C...Double precision and integer declarations.
15441 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15442 INTEGER PYK,PYCHGE,PYCOMP
15444 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15445 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15446 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15447 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15448 COMMON/PYINT1/MINT(400),VINT(400)
15449 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15450 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
15452 C...Convert VVAR to tau variable.
15458 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
15461 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
15465 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15467 ELSEIF(MVAR.EQ.1) THEN
15468 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
15469 ELSEIF(MVAR.EQ.2) THEN
15470 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
15471 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
15472 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
15473 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
15474 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
15475 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
15476 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
15477 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
15479 AUPP=LOG(MAX(2D-6,1D0-TAUMAX))
15480 ALOW=LOG(MAX(2D-6,1D0-TAUMIN))
15481 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15483 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
15485 C...Convert VVAR to y* variable.
15486 ELSEIF(IVAR.EQ.2) THEN
15490 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15491 IF(MINT(47).EQ.1) THEN
15493 ELSEIF(MINT(47).EQ.2) THEN
15494 YST=-0.5D0*LOG(TAUE)
15495 ELSEIF(MINT(47).EQ.3) THEN
15496 YST=0.5D0*LOG(TAUE)
15497 ELSEIF(MVAR.EQ.1) THEN
15498 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
15499 ELSEIF(MVAR.EQ.2) THEN
15500 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
15501 ELSEIF(MVAR.EQ.3) THEN
15502 AUPP=ATAN(EXP(YSTMAX))
15503 ALOW=ATAN(EXP(YSTMIN))
15504 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
15505 ELSEIF(MVAR.EQ.4) THEN
15506 YST0=-0.5D0*LOG(TAUE)
15507 AUPP=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0))
15508 ALOW=LOG(MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
15509 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
15511 YST0=-0.5D0*LOG(TAUE)
15512 AUPP=LOG(MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
15513 ALOW=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0))
15514 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
15516 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
15518 C...Convert VVAR to cos(theta-hat) variable.
15519 ELSEIF(IVAR.EQ.3) THEN
15520 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
15522 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15523 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15531 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15532 VCTN=VVAR*(ANEG+APOS)/ANEG
15533 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
15535 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15536 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
15538 ELSEIF(MVAR.EQ.2) THEN
15539 RMNMIN=MAX(RM34,RSQM-CTNMIN)
15540 RMNMAX=MAX(RM34,RSQM-CTNMAX)
15541 RMPMIN=MAX(RM34,RSQM-CTPMIN)
15542 RMPMAX=MAX(RM34,RSQM-CTPMAX)
15543 ANEG=LOG(RMNMIN/RMNMAX)
15544 APOS=LOG(RMPMIN/RMPMAX)
15545 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15546 VCTN=VVAR*(ANEG+APOS)/ANEG
15547 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
15549 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15550 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
15552 ELSEIF(MVAR.EQ.3) THEN
15553 RMNMIN=MAX(RM34,RSQM+CTNMIN)
15554 RMNMAX=MAX(RM34,RSQM+CTNMAX)
15555 RMPMIN=MAX(RM34,RSQM+CTPMIN)
15556 RMPMAX=MAX(RM34,RSQM+CTPMAX)
15557 ANEG=LOG(RMNMAX/RMNMIN)
15558 APOS=LOG(RMPMAX/RMPMIN)
15559 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15560 VCTN=VVAR*(ANEG+APOS)/ANEG
15561 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
15563 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15564 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
15566 ELSEIF(MVAR.EQ.4) THEN
15567 RMNMIN=MAX(RM34,RSQM-CTNMIN)
15568 RMNMAX=MAX(RM34,RSQM-CTNMAX)
15569 RMPMIN=MAX(RM34,RSQM-CTPMIN)
15570 RMPMAX=MAX(RM34,RSQM-CTPMAX)
15571 ANEG=1D0/RMNMAX-1D0/RMNMIN
15572 APOS=1D0/RMPMAX-1D0/RMPMIN
15573 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15574 VCTN=VVAR*(ANEG+APOS)/ANEG
15575 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
15577 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15578 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
15580 ELSEIF(MVAR.EQ.5) THEN
15581 RMNMIN=MAX(RM34,RSQM+CTNMIN)
15582 RMNMAX=MAX(RM34,RSQM+CTNMAX)
15583 RMPMIN=MAX(RM34,RSQM+CTPMIN)
15584 RMPMAX=MAX(RM34,RSQM+CTPMAX)
15585 ANEG=1D0/RMNMIN-1D0/RMNMAX
15586 APOS=1D0/RMPMIN-1D0/RMPMAX
15587 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15588 VCTN=VVAR*(ANEG+APOS)/ANEG
15589 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
15591 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15592 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
15595 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
15596 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
15599 C...Convert VVAR to tau' variable.
15600 ELSEIF(IVAR.EQ.4) THEN
15604 IF(MINT(47).EQ.1) THEN
15606 ELSEIF(MVAR.EQ.1) THEN
15607 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
15608 ELSEIF(MVAR.EQ.2) THEN
15609 AUPP=(1D0-TAU/TAUPMX)**4
15610 ALOW=(1D0-TAU/TAUPMN)**4
15611 TAUP=TAU/MAX(1D-7,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
15613 AUPP=LOG(MAX(2D-6,1D0-TAUPMX))
15614 ALOW=LOG(MAX(2D-6,1D0-TAUPMN))
15615 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15617 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
15619 C...Selection of extra variables needed in 2 -> 3 process:
15620 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
15621 C...Since no options are available, the functions of PYKLIM
15622 C...and PYKMAP are joint for these choices.
15623 ELSEIF(IVAR.EQ.5) THEN
15625 C...Read out total energy and particle masses.
15628 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
15629 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179) MPTPK=2
15630 SHP=VINT(26)*VINT(2)
15634 PM3=SQRT(VINT(21))*VINT(1)
15635 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
15642 C...Specify coefficients of pT choice; upper and lower limits.
15643 IF(MPTPK.EQ.1) THEN
15651 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
15653 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
15655 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
15657 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
15660 C...Select transverse momenta according to
15661 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
15664 IF(HMX.LT.1.0001D0*HMN) THEN
15670 IF(RPT.LT.HWT1) THEN
15671 PTS1=PTSMN1+PYR(0)*HDE
15672 ELSEIF(RPT.LT.HWT1+HWT2) THEN
15673 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
15675 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
15677 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
15678 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
15681 IF(HMX.LT.1.0001D0*HMN) THEN
15687 IF(RPT.LT.HWT1) THEN
15688 PTS2=PTSMN2+PYR(0)*HDE
15689 ELSEIF(RPT.LT.HWT1+HWT2) THEN
15690 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
15692 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
15694 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
15695 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
15697 C...Select azimuthal angles and check pT choice.
15698 PHI1=PARU(2)*PYR(0)
15699 PHI2=PARU(2)*PYR(0)
15701 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
15702 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
15703 & CKIN(56)**2)) THEN
15708 C...Calculate transverse masses and check phase space not closed.
15715 PM12=(PMT1+PMT2)**2
15716 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
15721 C...Select rapidity for particle 3 and check phase space not closed.
15722 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
15723 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
15724 IF(Y3MAX.LT.1D-6) THEN
15728 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
15732 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
15735 PMS12=PE12**2-PZ12**2
15736 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
15737 IF(SQL12.LT.1D-6*SHP) THEN
15741 PMM1=PMS12+PMS1-PMS2
15742 PMM2=PMS12+PMS2-PMS1
15743 TFAC=-SHPR/(2D0*PMS12)
15744 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
15745 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
15746 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
15747 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
15749 C...Construct relative mirror weights and make choice.
15750 IF(MPTPK.EQ.1) THEN
15754 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
15755 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
15757 WTP=WTPU/(WTPU+WTNU)
15758 WTN=WTNU/(WTPU+WTNU)
15760 IF(WTN.GT.PYR(0)) EPS=-1D0
15762 C...Store result of variable choice and associated weights.
15772 IF(EPS.GT.0D0) THEN
15781 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
15782 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
15783 VINT(219)=0.5D0*(PMS12-PTS3)
15790 C***********************************************************************
15792 *$ CREATE PYSIGH.FOR
15795 C...Differential matrix elements for all included subprocesses
15796 C...Note that what is coded is (disregarding the COMFAC factor)
15797 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
15798 C...when d(sigma-hat) is given in the zero-width limit, the delta
15799 C...function in tau is replaced by a (modified) Breit-Wigner:
15800 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
15801 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
15802 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
15803 C...i.e., dimensionless quantities
15804 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
15805 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
15806 C...(2pi)^4 delta^4(P - sum p_i)
15807 C...COMFAC contains the factor pi/s (or equivalent) and
15808 C...the conversion factor from GeV^-2 to mb
15810 SUBROUTINE PYSIGH(NCHN,SIGS)
15812 C...Double precision and integer declarations
15813 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15814 INTEGER PYK,PYCHGE,PYCOMP
15815 C...Parameter statement to help give large particle numbers.
15816 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
15818 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15819 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15820 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15821 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15822 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15823 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15824 COMMON/PYINT1/MINT(400),VINT(400)
15825 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15826 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15827 COMMON/PYINT4/MWID(500),WIDS(500,5)
15828 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15829 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15830 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
15832 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15833 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
15835 C...Local arrays and complex variables
15836 DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200),
15837 &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
15838 COMPLEX A004,A204,A114,A00U,A20U,A11U
15839 COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
15840 &COULCK,COULCP,COULCD,COULCR,COULCS
15841 REAL A00L,A11L,A20L,COULXX
15843 C...Reset number of channels and cross-section
15847 C...Convert H or A process into equivalent h one
15852 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
15853 &ISUB.LE.190)) THEN
15855 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
15857 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
15858 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
15859 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
15860 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
15861 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
15862 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
15863 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
15864 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
15865 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
15869 C...Convert almost equivalent SUSY processes into each other
15870 C...Extract differences in flavours and couplings
15871 IF(ISUB.GE.200.AND.ISUB.LE.280) THEN
15873 C...Sleptons and sneutrinos
15874 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
15875 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15878 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
15879 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15882 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
15883 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15885 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
15886 IF(ISUB.EQ.210) THEN
15888 ELSEIF(ISUB.EQ.211) THEN
15890 ELSEIF(ISUB.EQ.212) THEN
15894 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
15895 IF(ISUB.EQ.213) THEN
15896 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15898 ELSEIF(ISUB.EQ.214) THEN
15905 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
15906 IF(ISUB.EQ.216) THEN
15909 ELSEIF(ISUB.EQ.217) THEN
15912 ELSEIF(ISUB.EQ.218) THEN
15915 ELSEIF(ISUB.EQ.219) THEN
15918 ELSEIF(ISUB.EQ.220) THEN
15921 ELSEIF(ISUB.EQ.221) THEN
15924 ELSEIF(ISUB.EQ.222) THEN
15927 ELSEIF(ISUB.EQ.223) THEN
15930 ELSEIF(ISUB.EQ.224) THEN
15933 ELSEIF(ISUB.EQ.225) THEN
15940 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
15941 IF(ISUB.EQ.226) THEN
15944 ELSEIF(ISUB.EQ.227) THEN
15947 ELSEIF(ISUB.EQ.228) THEN
15953 C...Neutralino + chargino
15954 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
15955 IF(ISUB.EQ.229) THEN
15958 ELSEIF(ISUB.EQ.230) THEN
15961 ELSEIF(ISUB.EQ.231) THEN
15964 ELSEIF(ISUB.EQ.232) THEN
15967 ELSEIF(ISUB.EQ.233) THEN
15970 ELSEIF(ISUB.EQ.234) THEN
15973 ELSEIF(ISUB.EQ.235) THEN
15976 ELSEIF(ISUB.EQ.236) THEN
15982 C...Gluino + neutralino
15983 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
15984 IF(ISUB.EQ.237) THEN
15986 ELSEIF(ISUB.EQ.238) THEN
15988 ELSEIF(ISUB.EQ.239) THEN
15990 ELSEIF(ISUB.EQ.240) THEN
15995 C...Gluino + chargino
15996 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
15997 IF(ISUB.EQ.241) THEN
15999 ELSEIF(ISUB.EQ.242) THEN
16004 C...Squark + neutralino
16005 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
16007 IF(MOD(ISUB,2).NE.0) ILR=1
16008 IF(ISUB.LE.247) THEN
16010 ELSEIF(ISUB.LE.249) THEN
16012 ELSEIF(ISUB.LE.251) THEN
16014 ELSEIF(ISUB.LE.253) THEN
16020 C...Squark + chargino
16021 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
16022 IF(ISUB.LE.255) THEN
16024 ELSEIF(ISUB.LE.257) THEN
16027 IF(MOD(ISUB,2).EQ.0) THEN
16035 C...Squark + gluino
16036 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
16041 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
16043 IF(ISUB.EQ.262) ILR=1
16045 ELSEIF(ISUB.EQ.265) THEN
16049 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
16051 IF(ISUB.LE.273) THEN
16052 IF(ISUB.EQ.273) ILR=1
16055 ELSEIF(ISUB.LE.276) THEN
16056 IF(ISUB.EQ.276) ILR=1
16059 ELSEIF(ISUB.LE.278) THEN
16060 IF(ISUB.EQ.278) ILR=1
16064 IF(ISUB.EQ.280) ILR=1
16072 C...Read kinematical variables and limits
16090 C...Derive kinematical quantities
16092 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
16093 X(1)=SQRT(TAUE)*EXP(YST)
16094 X(2)=SQRT(TAUE)*EXP(-YST)
16095 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
16096 IF(X(1).GT.0.9999D0) RETURN
16097 ELSEIF(MINT(45).EQ.3) THEN
16098 X(1)=MIN(0.9999989D0,X(1))
16100 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
16101 IF(X(2).GT.0.9999D0) RETURN
16102 ELSEIF(MINT(46).EQ.3) THEN
16103 X(2)=MIN(0.9999989D0,X(2))
16110 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
16111 RPTS=4D0*VINT(71)**2/SH
16112 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
16113 RM34=MAX(1D-20,2D0*RM3*RM4)
16115 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) RM34=MAX(RM34,
16116 &2D0*VINT(71)**2/(VINT(21)*VINT(2)))
16117 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
16118 IF(ISTSB.EQ.0) THEN
16120 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16121 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
16123 TH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
16124 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16125 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
16132 C...Choice of Q2 scale: hard, parton distributions, parton showers
16133 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
16135 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
16136 IF(MSTP(32).EQ.1) THEN
16137 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
16138 ELSEIF(MSTP(32).EQ.2) THEN
16139 Q2=SQPTH+0.5D0*(SQM3+SQM4)
16140 ELSEIF(MSTP(32).EQ.3) THEN
16142 ELSEIF(MSTP(32).EQ.4) THEN
16144 ELSEIF(MSTP(32).EQ.5) THEN
16147 IF(ISTSB.EQ.9) Q2=SQPTH
16148 IF((ISTSB.EQ.9.AND.MSTP(82).GE.2).OR.(ISTSB.NE.9.AND.
16149 & MSTP(85).EQ.1)) Q2=Q2+PARP(82)**2
16152 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16154 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124)
16155 & Q2SF=PMAS(24,1)**2
16156 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
16157 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
16158 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
16159 IF(MSTP(39).EQ.3) Q2SF=SH
16160 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
16165 IF(MSTP(68).GE.2.AND.MINT(47).EQ.5) Q2SF=VINT(2)
16166 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
16167 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
16169 IF(MINT(43).EQ.3) XBJ=X(1)
16170 IF(MSTP(22).EQ.1) THEN
16172 ELSEIF(MSTP(22).EQ.2) THEN
16173 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
16174 ELSEIF(MSTP(22).EQ.3) THEN
16175 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
16177 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
16180 IF(MSTP(68).GE.1.AND.MINT(47).EQ.5) Q2PS=VINT(2)
16182 C...Store derived kinematical quantities
16190 VINT(47)=SQRT(SQPTH)
16191 VINT(50)=TAUP*VINT(2)
16192 VINT(49)=SQRT(MAX(0D0,VINT(50)))
16196 VINT(53)=SQRT(Q2SF)
16198 VINT(55)=SQRT(Q2PS)
16200 C...Calculate parton distributions
16201 IF(ISTSB.LE.0) GOTO 170
16202 IF(MINT(47).GE.2) THEN
16203 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
16205 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
16206 MINT(105)=MINT(102+I)
16207 MINT(109)=MINT(106+I)
16208 IF(MSTP(57).LE.1) THEN
16209 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
16211 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
16214 XSFX(I,KFL)=XPQ(KFL)
16219 C...Calculate alpha_em, alpha_strong and K-factor
16222 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
16223 &1D0-(PMAS(24,1)/PMAS(23,1))**2
16225 XWC=1D0/(16D0*XW*XW1)
16227 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16228 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
16231 IF(MSTP(33).EQ.1) THEN
16233 ELSEIF(MSTP(33).EQ.2) THEN
16235 FACA=PARP(32)/PARP(31)
16236 ELSEIF(MSTP(33).EQ.3) THEN
16238 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
16239 & PARU(112)*PARP(82)
16246 C...Set flags for allowed reacting partons/leptons
16251 IF(MINT(44+I).EQ.1) THEN
16252 KFAC(I,MINT(10+I))=1
16253 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
16254 KFAC(I,MINT(10+I))=1
16260 KFAC(I,J)=KFIN(I,J)
16261 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
16262 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
16267 C...Lower and upper limit for fermion flavour loops
16273 IF(KFAC(1,-J).EQ.1) MMIN1=-J
16274 IF(KFAC(1,J).EQ.1) MMAX1=J
16275 IF(KFAC(2,-J).EQ.1) MMIN2=-J
16276 IF(KFAC(2,J).EQ.1) MMAX2=J
16278 MMINA=MIN(MMIN1,MMIN2)
16279 MMAXA=MAX(MMAX1,MMAX2)
16281 C...Common resonance mass and width combinations
16284 SQMH=PMAS(KFHIGG,1)**2
16285 GMMZ=PMAS(23,1)*PMAS(23,2)
16286 GMMW=PMAS(24,1)*PMAS(24,2)
16287 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
16294 C...Phase space integral in tau
16295 COMFAC=PARU(1)*PARU(5)/VINT(2)
16296 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
16297 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
16299 ATAU1=LOG(TAUMAX/TAUMIN)
16300 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
16301 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
16302 IF(MINT(72).GE.1) THEN
16305 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
16307 IF(ATAUD.GT.1D-6) H1=H1+
16308 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
16309 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
16311 IF(ATAUD.GT.1D-6) H1=H1+
16312 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
16314 IF(MINT(72).EQ.2) THEN
16317 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
16319 IF(ATAUD.GT.1D-6) H1=H1+
16320 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
16321 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
16323 IF(ATAUD.GT.1D-6) H1=H1+
16324 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
16326 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
16327 ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
16328 IF(ATAU7.GT.1D-6) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
16329 & MAX(2D-6,1D0-TAU)
16331 COMFAC=COMFAC*ATAU1/(TAU*H1)
16334 C...Phase space integral in y*
16335 IF(MINT(47).GE.4.AND.ISTSB.NE.9) THEN
16336 AYST0=YSTMAX-YSTMIN
16337 IF(AYST0.LT.1D-6) THEN
16340 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16342 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16343 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16344 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16345 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16346 IF(MINT(45).EQ.3) THEN
16347 YST0=-0.5D0*LOG(TAUE)
16348 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
16349 & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
16350 IF(AYST4.GT.1D-6) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
16351 & MAX(1D-6,1D0-EXP(YST-YST0))
16353 IF(MINT(46).EQ.3) THEN
16354 YST0=-0.5D0*LOG(TAUE)
16355 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
16356 & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
16357 IF(AYST5.GT.1D-6) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
16358 & MAX(1D-6,1D0-EXP(-YST-YST0))
16360 COMFAC=COMFAC*AYST0/H2
16364 C...2 -> 1 processes: reduction in angular part of phase space integral
16365 C...for case of decaying resonance
16366 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
16367 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
16368 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
16369 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
16370 & KFPR(ISUB,1).EQ.39) THEN
16371 COMFAC=COMFAC*0.5D0*ACTH0
16373 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
16374 & CTPMAX**3-CTPMIN**3)
16378 C...2 -> 2 processes: angular part of phase space integral
16379 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
16380 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
16381 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
16382 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
16383 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
16384 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
16385 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
16386 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
16387 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
16388 H3=COEF(ISUBSV,13)+
16389 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
16390 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
16391 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
16392 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
16393 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
16395 C...2 -> 2 processes: take into account final state Breit-Wigners
16396 COMFAC=COMFAC*VINT(80)
16399 C...2 -> 3, 4 processes: phace space integral in tau'
16400 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16401 ATAUP1=LOG(TAUPMX/TAUPMN)
16402 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
16403 H4=COEF(ISUBSV,18)+
16404 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
16405 IF(MINT(47).EQ.5) THEN
16406 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
16407 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-6,1D0-TAUP)
16409 COMFAC=COMFAC*ATAUP1/H4
16412 C...2 -> 3, 4 processes: effective W/Z parton distributions
16413 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
16414 IF(1D0-TAU/TAUP.GT.1.D-4) THEN
16415 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
16417 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
16422 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
16423 IF(ISTSB.EQ.5) THEN
16424 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
16425 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
16428 C...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2
16429 IF(MSTP(85).EQ.1.AND.MOD(ISTSB,2).EQ.0) COMFAC=COMFAC*
16430 &SQPTH**2/(PARP(82)**2+SQPTH)**2
16432 C...gamma + gamma: include factor 2 when different nature
16433 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4)
16436 C...Phase space integral for low-pT and multiple interactions
16437 IF(ISTSB.EQ.9) THEN
16438 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
16439 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
16440 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
16441 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
16442 COMFAC=COMFAC*ATAU1/H1
16443 AYST0=YSTMAX-YSTMIN
16444 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16445 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16446 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16447 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16448 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16449 COMFAC=COMFAC*AYST0/H2
16450 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
16451 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16452 C...introduced to make cross-section finite for xT2 -> 0
16453 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
16457 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
16458 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
16459 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
16460 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
16461 IF(MSTP(46).LE.4) THEN
16462 HDTLH=LOG(PMAS(25,1)/PARP(44))
16463 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
16464 HDTNR=-1D0/18D0+HDTLH/6D0
16466 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
16467 HDTLQ=LOG(PARP(45)/PARP(44))
16468 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
16469 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
16472 C...Calculate lowest and next-to-lowest order partial wave amplitudes
16473 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
16477 HDTLS=LOG(SH/PARP(44)**2)
16478 A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16479 & CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
16480 & (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1)))
16481 A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16482 & CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
16483 & (20D0/9D0)*HDTLS),SNGL(PARU(1)))
16484 A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))*
16485 & CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0))
16487 C...Unitarize partial wave amplitudes with Pade or K-matrix method
16488 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
16489 A00U=A00L/(1.-A004/A00L)
16490 A20U=A20L/(1.-A204/A20L)
16491 A11U=A11L/(1.-A114/A11L)
16493 A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004)))
16494 A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204)))
16495 A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114)))
16499 C...Supersymmetric processes - all of type 2 -> 2 :
16500 C...correct final-state Breit-Wigners from fixed to running width.
16501 IF(ISUB.GE.200.AND.ISUB.LE.280.AND.MSTP(42).GT.0) THEN
16503 KFLW=KFPR(ISUBSV,I)
16505 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160
16506 IF(I.EQ.1) SQMI=SQM3
16507 IF(I.EQ.2) SQMI=SQM4
16508 SQMS=PMAS(KCW,1)**2
16509 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
16510 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
16511 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
16512 GMMI=SQRT(SQMI)*WDTP(0)
16513 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
16514 COMFAC=COMFAC*(HBWI/HBWS)
16518 C...A: 2 -> 1, tree diagrams
16520 170 IF(ISUB.LE.10) THEN
16522 C...f + fbar -> gamma*/Z0
16524 CALL PYWIDT(23,SH,WDTP,WDTE)
16526 FACZ=4D0*COMFAC*3D0
16529 DO 180 I=MMINA,MMAXA
16530 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
16531 EI=KCHG(IABS(I),1)/3D0
16535 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
16537 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
16542 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
16543 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
16544 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
16545 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
16548 ELSEIF(ISUB.EQ.2) THEN
16549 C...f + fbar' -> W+/-
16550 CALL PYWIDT(24,SH,WDTP,WDTE)
16552 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
16553 HP=AEM/(24D0*XW)*SH
16554 DO 200 I=MMIN1,MMAX1
16555 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
16557 DO 190 J=MMIN2,MMAX2
16558 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
16560 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
16561 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
16563 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16565 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
16570 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
16571 SIGH(NCHN)=HI*FACBW*HF
16575 ELSEIF(ISUB.EQ.3) THEN
16576 C...f + fbar -> h0 (or H0, or A0)
16577 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
16579 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16580 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
16582 HP=AEM/(8D0*XW)*SH/SQMW*SH
16583 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16584 DO 210 I=MMINA,MMAXA
16585 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
16587 RMQ=PMAS(IA,1)**2/SH
16589 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
16590 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) HI=HI*
16591 & (LOG(MAX(4D0,PARP(37)**2*RMQ*SH/PARU(117)**2))/
16592 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
16593 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16595 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
16596 IF(IA.GT.10) IKFI=3
16597 HI=HI*PARU(150+10*IHIGG+IKFI)**2
16603 SIGH(NCHN)=HI*FACBW*HF
16606 ELSEIF(ISUB.EQ.4) THEN
16607 C...gamma + W+/- -> W+/-
16609 ELSEIF(ISUB.EQ.5) THEN
16611 CALL PYWIDT(25,SH,WDTP,WDTE)
16613 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16614 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16615 HP=AEM/(8D0*XW)*SH/SQMW*SH
16616 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16618 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
16619 DO 230 I=MMIN1,MMAX1
16620 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230
16621 DO 220 J=MMIN2,MMAX2
16622 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220
16623 EI=KCHG(IABS(I),1)/3D0
16626 EJ=KCHG(IABS(J),1)/3D0
16633 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
16637 ELSEIF(ISUB.EQ.6) THEN
16638 C...Z0 + W+/- -> W+/-
16640 ELSEIF(ISUB.EQ.7) THEN
16643 ELSEIF(ISUB.EQ.8) THEN
16645 CALL PYWIDT(25,SH,WDTP,WDTE)
16647 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16648 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16649 HP=AEM/(8D0*XW)*SH/SQMW*SH
16650 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16652 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
16653 DO 250 I=MMIN1,MMAX1
16654 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250
16655 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
16656 DO 240 J=MMIN2,MMAX2
16657 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240
16658 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
16659 IF(EI*EJ.GT.0D0) GOTO 240
16664 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
16668 C...B: 2 -> 2, tree diagrams
16670 ELSEIF(ISUB.EQ.10) THEN
16671 C...f + f' -> f + f' (gamma/Z/W exchange)
16672 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
16673 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
16674 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
16675 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
16676 DO 270 I=MMIN1,MMAX1
16677 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
16679 DO 260 J=MMIN2,MMAX2
16680 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
16682 C...Electroweak couplings
16683 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
16684 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
16686 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
16687 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
16690 C...gamma/Z exchange, only gamma exchange, or only Z exchange
16691 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
16692 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
16693 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
16694 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
16695 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
16696 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16697 ELSEIF(MSTP(21).EQ.2) THEN
16698 FACNCF=FACGGF*EI**2*EJ**2
16700 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
16701 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16710 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
16711 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
16712 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
16713 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
16714 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
16725 ELSEIF(ISUB.LE.20) THEN
16726 IF(ISUB.EQ.11) THEN
16727 C...f + f' -> f + f' (g exchange)
16728 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
16729 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
16730 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
16731 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
16732 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
16733 IF(MSTP(5).GE.1) THEN
16734 C...Modifications from contact interactions (compositeness)
16735 FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
16736 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16737 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
16738 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16739 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
16740 FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
16742 DO 290 I=MMIN1,MMAX1
16744 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290
16745 DO 280 J=MMIN2,MMAX2
16747 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280
16752 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
16755 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
16758 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
16759 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
16762 SIGH(NCHN)=0.5D0*SIGH(NCHN)
16767 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
16768 SIGH(NCHN)=0.5D0*FACQQ2
16770 SIGH(NCHN)=0.5D0*FACCI2
16776 ELSEIF(ISUB.EQ.12) THEN
16777 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
16778 CALL PYWIDT(21,SH,WDTP,WDTE)
16779 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
16780 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16781 IF(MSTP(5).EQ.1) THEN
16782 C...Modifications from contact interactions (compositeness)
16785 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
16786 & WDTE(I,2)+WDTE(I,4))
16788 ELSEIF(MSTP(5).GE.2) THEN
16789 FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
16790 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16792 DO 310 I=MMINA,MMAXA
16793 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16794 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
16799 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
16806 ELSEIF(ISUB.EQ.13) THEN
16807 C...f + fbar -> g + g (q + qbar -> g + g only)
16808 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
16810 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
16812 DO 320 I=MMINA,MMAXA
16813 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16814 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
16819 SIGH(NCHN)=0.5D0*FACGG1
16824 SIGH(NCHN)=0.5D0*FACGG2
16827 ELSEIF(ISUB.EQ.14) THEN
16828 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
16829 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
16830 DO 330 I=MMINA,MMAXA
16831 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16832 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
16833 EI=KCHG(IABS(I),1)/3D0
16838 SIGH(NCHN)=FACGG*EI**2
16841 ELSEIF(ISUB.EQ.15) THEN
16842 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
16843 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16844 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16848 RADC4=1D0+PYALPS(SQM4)/PARU(1)
16849 DO 340 I=1,MIN(16,MDCY(23,3))
16851 IF(MDME(IDC,1).LT.0) GOTO 340
16853 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16857 AF=SIGN(1D0,EF+0.1D0)
16859 ELSEIF(I.LE.16) THEN
16861 AF=SIGN(1D0,EF+0.1D0)
16864 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16865 IF(4D0*RM1.LT.1D0) THEN
16867 IF(I.LE.8) FCOF=3D0*RADC4
16868 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16870 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16871 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16872 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16873 & AF**2*(1D0-4D0*RM1))*BE34
16877 C...Propagators: as simulated in PYOFSH and as desired
16878 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16881 CALL PYWIDT(23,SQM4,WDTP,WDTE)
16882 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16883 HFGG=HFGG*HFAEM*VINT(111)/SQM4
16884 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16885 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16886 C...Loop over flavours; consider full gamma/Z structure
16887 DO 350 I=MMINA,MMAXA
16888 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16889 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
16890 EI=KCHG(IABS(I),1)/3D0
16897 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
16898 & (VI**2+AI**2)*HFZZ)/HBW4
16901 ELSEIF(ISUB.EQ.16) THEN
16902 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
16903 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16904 C...Propagators: as simulated in PYOFSH and as desired
16905 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
16906 CALL PYWIDT(24,SQM4,WDTP,WDTE)
16907 GMMWC=SQRT(SQM4)*WDTP(0)
16908 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
16909 FACWG=FACWG*HBW4C/HBW4
16910 DO 370 I=MMIN1,MMAX1
16912 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370
16913 DO 360 J=MMIN2,MMAX2
16915 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360
16916 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
16917 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16918 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
16919 FCKM=VCKM((IA+1)/2,(JA+1)/2)
16924 SIGH(NCHN)=FACWG*FCKM*WIDSC
16928 ELSEIF(ISUB.EQ.17) THEN
16929 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
16931 ELSEIF(ISUB.EQ.18) THEN
16932 C...f + fbar -> gamma + gamma
16933 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
16934 DO 380 I=MMINA,MMAXA
16935 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
16936 EI=KCHG(IABS(I),1)/3D0
16938 IF(IABS(I).LE.10) FCOI=FACA/3D0
16943 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
16946 ELSEIF(ISUB.EQ.19) THEN
16947 C...f + fbar -> gamma + (gamma*/Z0)
16948 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16949 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16953 RADC4=1D0+PYALPS(SQM4)/PARU(1)
16954 DO 390 I=1,MIN(16,MDCY(23,3))
16956 IF(MDME(IDC,1).LT.0) GOTO 390
16958 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16962 AF=SIGN(1D0,EF+0.1D0)
16964 ELSEIF(I.LE.16) THEN
16966 AF=SIGN(1D0,EF+0.1D0)
16969 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16970 IF(4D0*RM1.LT.1D0) THEN
16972 IF(I.LE.8) FCOF=3D0*RADC4
16973 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16975 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16976 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16977 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16978 & AF**2*(1D0-4D0*RM1))*BE34
16982 C...Propagators: as simulated in PYOFSH and as desired
16983 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16986 CALL PYWIDT(23,SQM4,WDTP,WDTE)
16987 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16988 HFGG=HFGG*HFAEM*VINT(111)/SQM4
16989 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16990 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16991 C...Loop over flavours; consider full gamma/Z structure
16992 DO 400 I=MMINA,MMAXA
16993 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
16994 EI=KCHG(IABS(I),1)/3D0
16998 IF(IABS(I).LE.10) FCOI=FACA/3D0
17003 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
17004 & (VI**2+AI**2)*HFZZ)/HBW4
17007 ELSEIF(ISUB.EQ.20) THEN
17008 C...f + fbar' -> gamma + W+/-
17009 FACGW=COMFAC*0.5D0*AEM**2/XW
17010 C...Propagators: as simulated in PYOFSH and as desired
17011 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17012 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17013 GMMWC=SQRT(SQM4)*WDTP(0)
17014 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17015 FACGW=FACGW*HBW4C/HBW4
17016 C...Anomalous couplings
17017 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
17020 IF(MSTP(5).GE.1) THEN
17021 TERM2=PARU(153)*(TH-UH)/(TH+UH)
17022 TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
17023 & (4D0*SQMW))/(TH+UH)**2
17025 DO 420 I=MMIN1,MMAX1
17027 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420
17028 DO 410 J=MMIN2,MMAX2
17030 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410
17031 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
17032 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17034 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17035 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17037 FACWR=UH/(TH+UH)-1D0/3D0
17038 FCKM=VCKM((IA+1)/2,(JA+1)/2)
17045 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
17050 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
17055 ELSEIF(ISUB.LE.30) THEN
17056 IF(ISUB.EQ.21) THEN
17057 C...f + fbar -> gamma + h0
17059 ELSEIF(ISUB.EQ.22) THEN
17060 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
17061 C...Kinematics dependence
17062 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
17063 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
17064 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17070 RADC3=1D0+PYALPS(SQM3)/PARU(1)
17071 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17072 DO 450 I=1,MIN(16,MDCY(23,3))
17074 IF(MDME(IDC,1).LT.0) GOTO 450
17076 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
17077 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
17080 AF=SIGN(1D0,EF+0.1D0)
17082 ELSEIF(I.LE.16) THEN
17084 AF=SIGN(1D0,EF+0.1D0)
17087 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
17088 IF(4D0*RM1.LT.1D0) THEN
17090 IF(I.LE.8) FCOF=3D0*RADC3
17091 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17093 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17094 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17095 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17096 & AF**2*(1D0-4D0*RM1))*BE34
17099 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17100 IF(4D0*RM1.LT.1D0) THEN
17102 IF(I.LE.8) FCOF=3D0*RADC4
17103 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17105 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17106 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17107 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17108 & AF**2*(1D0-4D0*RM1))*BE34
17112 C...Propagators: as simulated in PYOFSH and as desired
17113 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
17114 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17117 CALL PYWIDT(23,SQM3,WDTP,WDTE)
17118 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17120 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
17121 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
17122 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
17125 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17126 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17128 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
17129 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
17130 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
17132 C...Loop over flavours; separate left- and right-handed couplings
17133 DO 490 I=MMINA,MMAXA
17134 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
17135 EI=KCHG(IABS(I),1)/3D0
17141 IF(IABS(I).LE.10) FCOI=FACA/3D0
17143 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
17144 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
17145 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
17146 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
17148 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
17149 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
17150 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
17151 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
17156 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
17159 ELSEIF(ISUB.EQ.23) THEN
17160 C...f + fbar' -> Z0 + W+/-
17161 FACZW=COMFAC*0.5D0*(AEM/XW)**2
17162 FACZW=FACZW*WIDS(23,2)
17163 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17164 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17165 DO 510 I=MMIN1,MMAX1
17167 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510
17168 DO 500 J=MMIN2,MMAX2
17170 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500
17171 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500
17172 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17174 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17176 AI=SIGN(1D0,EI+0.1D0)
17179 AJ=SIGN(1D0,EJ+0.1D0)
17181 IF(VI+AI.GT.0) THEN
17190 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17192 IF(IA.LE.10) FCOI=FACA/3D0
17197 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
17198 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
17199 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
17200 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
17201 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
17202 & WIDS(24,(5-KCHW)/2)
17206 ELSEIF(ISUB.EQ.24) THEN
17207 C...f + fbar -> Z0 + h0 (or H0, or A0)
17208 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17209 FACHZ=COMFAC*8D0*(AEM*XWC)**2*
17210 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
17211 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
17212 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
17213 & PARU(154+10*IHIGG)**2
17214 DO 520 I=MMINA,MMAXA
17215 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
17216 EI=KCHG(IABS(I),1)/3D0
17220 IF(IABS(I).LE.10) FCOI=FACA/3D0
17225 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
17228 ELSEIF(ISUB.EQ.25) THEN
17229 C...f + fbar -> W+ + W-
17230 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
17231 CALL PYWIDT(23,SH,WDTP,WDTE)
17233 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
17234 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
17235 CALL PYWIDT(24,SQM3,WDTP,WDTE)
17236 GMMW3=SQRT(SQM3)*WDTP(0)
17237 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
17238 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17239 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17240 GMMW4=SQRT(SQM4)*WDTP(0)
17241 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
17242 C...Kinematical functions
17243 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17244 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
17245 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
17246 GT=THUH34+4D0*THUH/TH2
17247 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
17248 GU=THUH34+4D0*THUH/UH2
17249 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
17250 C...Common factors and couplings
17251 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
17252 FACWW=FACWW*WIDS(24,1)
17254 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
17255 CZZ=AEM**2/(32D0*XW**2)*HBWZC
17256 CNG=AEM**2/(4D0*XW)
17257 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
17258 CNN=AEM**2/(16D0*XW**2)
17259 C...Coulomb factor for W+W- pair
17260 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
17261 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
17262 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
17263 IF(COULE.LT.100D0*PMAS(24,2)) THEN
17264 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17265 & PMAS(24,2)**2)-COULE))
17267 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
17269 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
17270 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17271 & PMAS(24,2)**2)+COULE))
17273 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
17276 IF(MSTP(40).EQ.1) THEN
17277 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
17278 & MAX(1D-10,2D0*COULP*COULP1))
17279 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17280 ELSEIF(MSTP(40).EQ.2) THEN
17281 COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2))
17282 COULCP=CMPLX(0.,SNGL(COULP))
17283 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
17284 COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD)
17285 COULCS=CMPLX(0.,0.)
17288 COULXX=(ISTP-0.5)/NSTP
17289 COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/
17290 & (1.+COULXX/COULCD))
17292 COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)*
17294 FACCOU=ABS(COULCR)**2
17295 ELSEIF(MSTP(40).EQ.3) THEN
17296 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
17297 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
17298 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17300 ELSEIF(MSTP(40).EQ.4) THEN
17301 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
17307 C...Loop over allowed flavours
17308 DO 540 I=MMINA,MMAXA
17309 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
17310 EI=KCHG(IABS(I),1)/3D0
17311 AI=SIGN(1D0,EI+0.1D0)
17314 IF(IABS(I).LE.10) FCOI=FACA/3D0
17316 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
17317 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
17319 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
17320 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
17326 SIGH(NCHN)=FACWW*FCOI*DSIGWW
17329 ELSEIF(ISUB.EQ.26) THEN
17330 C...f + fbar' -> W+/- + h0 (or H0, or A0)
17331 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17332 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
17333 & ((SH-SQMW)**2+GMMW**2)
17334 FACHW=FACHW*WIDS(KFHIGG,2)
17335 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
17336 & PARU(155+10*IHIGG)**2
17337 DO 560 I=MMIN1,MMAX1
17339 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560
17340 DO 550 J=MMIN2,MMAX2
17342 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550
17343 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550
17344 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17346 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17348 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17350 IF(IA.LE.10) FCOI=FACA/3D0
17355 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
17359 ELSEIF(ISUB.EQ.27) THEN
17360 C...f + fbar -> h0 + h0
17362 ELSEIF(ISUB.EQ.28) THEN
17363 C...f + g -> f + g (q + g -> q + g only)
17364 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
17366 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
17368 DO 580 I=MMINA,MMAXA
17369 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580
17371 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570
17372 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570
17375 ISIG(NCHN,3-ISDE)=21
17380 ISIG(NCHN,3-ISDE)=21
17386 ELSEIF(ISUB.EQ.29) THEN
17387 C...f + g -> f + gamma (q + g -> q + gamma only)
17388 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
17389 DO 600 I=MMINA,MMAXA
17390 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600
17391 EI=KCHG(IABS(I),1)/3D0
17394 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590
17395 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590
17398 ISIG(NCHN,3-ISDE)=21
17404 ELSEIF(ISUB.EQ.30) THEN
17405 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
17406 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
17408 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17412 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17413 DO 610 I=1,MIN(16,MDCY(23,3))
17415 IF(MDME(IDC,1).LT.0) GOTO 610
17417 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17421 AF=SIGN(1D0,EF+0.1D0)
17423 ELSEIF(I.LE.16) THEN
17425 AF=SIGN(1D0,EF+0.1D0)
17428 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17429 IF(4D0*RM1.LT.1D0) THEN
17431 IF(I.LE.8) FCOF=3D0*RADC4
17432 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17434 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17435 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17436 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17437 & AF**2*(1D0-4D0*RM1))*BE34
17441 C...Propagators: as simulated in PYOFSH and as desired
17442 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17445 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17446 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17447 HFGG=HFGG*HFAEM*VINT(111)/SQM4
17448 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17449 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17450 C...Loop over flavours; consider full gamma/Z structure
17451 DO 630 I=MMINA,MMAXA
17452 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630
17453 EI=KCHG(IABS(I),1)/3D0
17456 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
17457 & (VI**2+AI**2)*HFZZ)/HBW4
17459 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620
17460 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620
17463 ISIG(NCHN,3-ISDE)=21
17470 ELSEIF(ISUB.LE.40) THEN
17471 IF(ISUB.EQ.31) THEN
17472 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
17473 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
17474 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
17475 C...Propagators: as simulated in PYOFSH and as desired
17476 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17477 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17478 GMMWC=SQRT(SQM4)*WDTP(0)
17479 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17480 FACWQ=FACWQ*HBW4C/HBW4
17481 DO 650 I=MMINA,MMAXA
17482 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650
17484 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17485 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17487 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640
17488 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640
17491 ISIG(NCHN,3-ISDE)=21
17493 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17497 ELSEIF(ISUB.EQ.32) THEN
17498 C...f + g -> f + h0 (q + g -> q + h0 only)
17500 ELSEIF(ISUB.EQ.33) THEN
17501 C...f + gamma -> f + g (q + gamma -> q + g only)
17502 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
17503 DO 670 I=MMINA,MMAXA
17504 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670
17505 EI=KCHG(IABS(I),1)/3D0
17508 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660
17509 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660
17512 ISIG(NCHN,3-ISDE)=22
17518 ELSEIF(ISUB.EQ.34) THEN
17519 C...f + gamma -> f + gamma
17520 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
17521 DO 690 I=MMINA,MMAXA
17522 IF(I.EQ.0) GOTO 690
17523 EI=KCHG(IABS(I),1)/3D0
17526 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680
17527 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680
17530 ISIG(NCHN,3-ISDE)=22
17536 ELSEIF(ISUB.EQ.35) THEN
17537 C...f + gamma -> f + (gamma*/Z0)
17538 FZQN=COMFAC*2D0*AEM**2*(SH2+UH2+2D0*SQM4*TH)
17539 FZQD=SQPTH*SQM4-SH*UH
17540 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17544 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17545 DO 700 I=1,MIN(16,MDCY(23,3))
17547 IF(MDME(IDC,1).LT.0) GOTO 700
17549 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17553 AF=SIGN(1D0,EF+0.1D0)
17555 ELSEIF(I.LE.16) THEN
17557 AF=SIGN(1D0,EF+0.1D0)
17560 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17561 IF(4D0*RM1.LT.1D0) THEN
17563 IF(I.LE.8) FCOF=3D0*RADC4
17564 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17566 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17567 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17568 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17569 & AF**2*(1D0-4D0*RM1))*BE34
17573 C...Propagators: as simulated in PYOFSH and as desired
17574 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17577 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17578 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17579 HFGG=HFGG*HFAEM*VINT(111)/SQM4
17580 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17581 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17582 C...Loop over flavours; consider full gamma/Z structure
17583 DO 720 I=MMINA,MMAXA
17584 IF(I.EQ.0) GOTO 720
17585 EI=KCHG(IABS(I),1)/3D0
17588 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
17589 & (VI**2+AI**2)*HFZZ)/HBW4
17591 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710
17592 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710
17595 ISIG(NCHN,3-ISDE)=22
17597 SIGH(NCHN)=FACZQ*FZQN/MAX(PMAS(IABS(I),1)**2*SQM4,FZQD)
17601 ELSEIF(ISUB.EQ.36) THEN
17602 C...f + gamma -> f' + W+/-
17603 FWQ=COMFAC*AEM**2/(2D0*XW)*
17604 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
17605 C...Propagators: as simulated in PYOFSH and as desired
17606 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17607 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17608 GMMWC=SQRT(SQM4)*WDTP(0)
17609 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17611 DO 740 I=MMINA,MMAXA
17612 IF(I.EQ.0) GOTO 740
17614 EIA=ABS(KCHG(IABS(I),1)/3D0)
17615 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
17616 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17617 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17619 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730
17620 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730
17623 ISIG(NCHN,3-ISDE)=22
17625 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17629 ELSEIF(ISUB.EQ.37) THEN
17630 C...f + gamma -> f + h0
17632 ELSEIF(ISUB.EQ.38) THEN
17633 C...f + Z0 -> f + g (q + Z0 -> q + g only)
17635 ELSEIF(ISUB.EQ.39) THEN
17636 C...f + Z0 -> f + gamma
17638 ELSEIF(ISUB.EQ.40) THEN
17639 C...f + Z0 -> f + Z0
17642 ELSEIF(ISUB.LE.50) THEN
17643 IF(ISUB.EQ.41) THEN
17644 C...f + Z0 -> f' + W+/-
17646 ELSEIF(ISUB.EQ.42) THEN
17647 C...f + Z0 -> f + h0
17649 ELSEIF(ISUB.EQ.43) THEN
17650 C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
17652 ELSEIF(ISUB.EQ.44) THEN
17653 C...f + W+/- -> f' + gamma
17655 ELSEIF(ISUB.EQ.45) THEN
17656 C...f + W+/- -> f' + Z0
17658 ELSEIF(ISUB.EQ.46) THEN
17659 C...f + W+/- -> f' + W+/-
17661 ELSEIF(ISUB.EQ.47) THEN
17662 C...f + W+/- -> f' + h0
17664 ELSEIF(ISUB.EQ.48) THEN
17665 C...f + h0 -> f + g (q + h0 -> q + g only)
17667 ELSEIF(ISUB.EQ.49) THEN
17668 C...f + h0 -> f + gamma
17670 ELSEIF(ISUB.EQ.50) THEN
17671 C...f + h0 -> f + Z0
17674 ELSEIF(ISUB.LE.60) THEN
17675 IF(ISUB.EQ.51) THEN
17676 C...f + h0 -> f' + W+/-
17678 ELSEIF(ISUB.EQ.52) THEN
17679 C...f + h0 -> f + h0
17681 ELSEIF(ISUB.EQ.53) THEN
17682 C...g + g -> f + fbar (g + g -> q + qbar only)
17683 CALL PYWIDT(21,SH,WDTP,WDTE)
17684 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
17685 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17686 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
17687 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17688 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750
17701 ELSEIF(ISUB.EQ.54) THEN
17702 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
17703 CALL PYWIDT(21,SH,WDTP,WDTE)
17705 DO 760 I=1,MIN(8,MDCY(21,3))
17707 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17710 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
17711 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
17718 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
17726 ELSEIF(ISUB.EQ.55) THEN
17727 C...g + Z -> f + fbar (g + Z -> q + qbar only)
17729 ELSEIF(ISUB.EQ.56) THEN
17730 C...g + W -> f + f'bar (g + W -> q + q'bar only)
17732 ELSEIF(ISUB.EQ.57) THEN
17733 C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
17735 ELSEIF(ISUB.EQ.58) THEN
17736 C...gamma + gamma -> f + fbar
17737 CALL PYWIDT(22,SH,WDTP,WDTE)
17739 DO 770 I=1,MIN(12,MDCY(22,3))
17740 IF(I.LE.8) EF= KCHG(I,1)/3D0
17741 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
17742 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17745 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
17746 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
17754 ELSEIF(ISUB.EQ.59) THEN
17755 C...gamma + Z0 -> f + fbar
17757 ELSEIF(ISUB.EQ.60) THEN
17758 C...gamma + W+/- -> f + fbar'
17761 ELSEIF(ISUB.LE.70) THEN
17762 IF(ISUB.EQ.61) THEN
17763 C...gamma + h0 -> f + fbar
17765 ELSEIF(ISUB.EQ.62) THEN
17766 C...Z0 + Z0 -> f + fbar
17768 ELSEIF(ISUB.EQ.63) THEN
17769 C...Z0 + W+/- -> f + fbar'
17771 ELSEIF(ISUB.EQ.64) THEN
17772 C...Z0 + h0 -> f + fbar
17774 ELSEIF(ISUB.EQ.65) THEN
17775 C...W+ + W- -> f + fbar
17777 ELSEIF(ISUB.EQ.66) THEN
17778 C...W+/- + h0 -> f + fbar'
17780 ELSEIF(ISUB.EQ.67) THEN
17781 C...h0 + h0 -> f + fbar
17783 ELSEIF(ISUB.EQ.68) THEN
17785 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
17787 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
17789 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
17791 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780
17796 SIGH(NCHN)=0.5D0*FACGG1
17801 SIGH(NCHN)=0.5D0*FACGG2
17806 SIGH(NCHN)=0.5D0*FACGG3
17809 ELSEIF(ISUB.EQ.69) THEN
17810 C...gamma + gamma -> W+ + W-
17811 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17812 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
17813 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
17814 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
17815 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790
17823 ELSEIF(ISUB.EQ.70) THEN
17824 C...gamma + W+/- -> Z0 + W+/-
17825 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17826 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
17827 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
17828 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
17829 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
17830 DO 810 KCHW=1,-1,-2
17832 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800
17835 ISIG(NCHN,3-ISDE)=24*KCHW
17837 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
17842 ELSEIF(ISUB.LE.80) THEN
17843 IF(ISUB.EQ.71) THEN
17844 C...Z0 + Z0 -> Z0 + Z0
17845 IF(SH.LE.4.01D0*SQMZ) GOTO 840
17847 IF(MSTP(46).LE.2) THEN
17848 C...Exact scattering ME:s for on-mass-shell gauge bosons
17849 BE2=1D0-4D0*SQMZ/SH
17850 TH=-0.5D0*SH*BE2*(1D0-CTH)
17851 UH=-0.5D0*SH*BE2*(1D0+CTH)
17852 IF(MAX(TH,UH).GT.-1D0) GOTO 840
17853 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
17854 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17855 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17856 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
17857 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17858 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17859 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
17860 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
17861 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
17862 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17863 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17864 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
17865 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
17866 & (ASHIM+ATHIM+AUHIM)**2)
17867 IF(MSTP(46).EQ.2) FACZZ=0D0
17870 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17871 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17872 & ABS(A00U+2.*A20U)**2
17874 FACZZ=FACZZ*WIDS(23,1)
17876 DO 830 I=MMIN1,MMAX1
17877 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830
17878 EI=KCHG(IABS(I),1)/3D0
17882 DO 820 J=MMIN2,MMAX2
17883 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820
17884 EJ=KCHG(IABS(J),1)/3D0
17892 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
17897 ELSEIF(ISUB.EQ.72) THEN
17898 C...Z0 + Z0 -> W+ + W-
17899 IF(SH.LE.4.01D0*SQMZ) GOTO 870
17901 IF(MSTP(46).LE.2) THEN
17902 C...Exact scattering ME:s for on-mass-shell gauge bosons
17903 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
17905 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
17906 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
17907 IF(MAX(TH,UH).GT.-1D0) GOTO 870
17908 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
17909 & (1D0-2D0*SQMZ/SH)
17910 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17911 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17912 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
17913 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17914 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17915 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
17916 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17918 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
17919 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17920 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17921 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
17922 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17924 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
17926 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17927 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17928 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
17929 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
17930 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
17931 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
17932 & (ATWIM+AUWIM+A4IM)**2)
17935 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17936 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17937 & ABS(A00U-A20U)**2
17939 FACWW=FACWW*WIDS(24,1)
17941 DO 860 I=MMIN1,MMAX1
17942 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
17943 EI=KCHG(IABS(I),1)/3D0
17947 DO 850 J=MMIN2,MMAX2
17948 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
17949 EJ=KCHG(IABS(J),1)/3D0
17957 SIGH(NCHN)=FACWW*AVI*AVJ
17962 ELSEIF(ISUB.EQ.73) THEN
17963 C...Z0 + W+/- -> Z0 + W+/-
17964 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900
17966 IF(MSTP(46).LE.2) THEN
17967 C...Exact scattering ME:s for on-mass-shell gauge bosons
17968 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
17969 EP1=1D0-(SQMZ-SQMW)/SH
17970 EP2=1D0+(SQMZ-SQMW)/SH
17971 TH=-0.5D0*SH*BE2*(1D0-CTH)
17972 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
17973 IF(MAX(TH,UH).GT.-1D0) GOTO 900
17974 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
17975 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17976 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17977 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
17978 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
17979 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
17980 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
17982 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
17983 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
17984 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
17985 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
17986 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
17987 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
17988 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
17989 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
17990 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
17991 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
17992 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
17993 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
17995 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
17996 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
17998 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
17999 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
18000 IF(MSTP(46).LE.0) FACZW=0D0
18001 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
18002 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
18003 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
18004 & (ASWIM+AUWIM+A4IM)**2)
18007 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18008 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
18009 & ABS(A20U+3.*A11U*SNGL(CTH))**2
18011 FACZW=FACZW*WIDS(23,2)
18013 DO 890 I=MMIN1,MMAX1
18014 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890
18015 EI=KCHG(IABS(I),1)/3D0
18019 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
18020 DO 880 J=MMIN2,MMAX2
18021 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880
18022 EJ=KCHG(IABS(J),1)/3D0
18026 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
18031 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
18036 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
18041 ELSEIF(ISUB.EQ.75) THEN
18042 C...W+ + W- -> gamma + gamma
18044 ELSEIF(ISUB.EQ.76) THEN
18045 C...W+ + W- -> Z0 + Z0
18046 IF(SH.LE.4.01D0*SQMZ) GOTO 930
18048 IF(MSTP(46).LE.2) THEN
18049 C...Exact scattering ME:s for on-mass-shell gauge bosons
18050 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
18052 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
18053 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
18054 IF(MAX(TH,UH).GT.-1D0) GOTO 930
18055 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
18056 & (1D0-2D0*SQMZ/SH)
18057 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18058 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18059 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
18060 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18061 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18062 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
18063 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18065 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
18066 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18067 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18068 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
18069 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18071 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
18073 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18075 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
18076 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
18077 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
18078 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
18079 & (ATWIM+AUWIM+A4IM)**2)
18082 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18083 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18084 & ABS(A00U-A20U)**2
18086 FACZZ=FACZZ*WIDS(23,1)
18088 DO 920 I=MMIN1,MMAX1
18089 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920
18090 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18091 DO 910 J=MMIN2,MMAX2
18092 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910
18093 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18094 IF(EI*EJ.GT.0D0) GOTO 910
18099 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
18104 ELSEIF(ISUB.EQ.77) THEN
18105 C...W+/- + W+/- -> W+/- + W+/-
18106 IF(SH.LE.4.01D0*SQMW) GOTO 960
18108 IF(MSTP(46).LE.2) THEN
18109 C...Exact scattering ME:s for on-mass-shell gauge bosons
18110 BE2=1D0-4D0*SQMW/SH
18114 TH=-0.5D0*SH*BE2*(1D0-CTH)
18115 UH=-0.5D0*SH*BE2*(1D0+CTH)
18116 IF(MAX(TH,UH).GT.-1D0) GOTO 960
18118 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18119 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18121 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
18122 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
18124 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
18125 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
18126 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
18129 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
18131 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
18132 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
18133 ATGRE=0.5D0*XW*SH/TH*TGZANG
18135 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
18137 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
18138 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
18139 AUGRE=0.5D0*XW*SH/UH*UGZANG
18141 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
18143 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
18145 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
18147 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18149 IF(MSTP(46).LE.0) THEN
18154 ELSEIF(MSTP(46).EQ.1) THEN
18155 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18156 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18157 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18158 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18160 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18161 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18162 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18163 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18165 AWWA2=AWWARE**2+AWWAIM**2
18166 AWWS2=AWWSRE**2+AWWSIM**2
18169 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18170 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18171 & ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2
18172 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
18175 DO 950 I=MMIN1,MMAX1
18176 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950
18177 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18178 DO 940 J=MMIN2,MMAX2
18179 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940
18180 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18181 IF(EI*EJ.LT.0D0) THEN
18183 IF(MSTP(45).EQ.1) GOTO 940
18184 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
18185 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
18188 IF(MSTP(45).EQ.2) GOTO 940
18189 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
18190 IF(MSTP(46).GE.3) FACWW=FWWS
18191 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
18192 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
18198 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
18199 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
18204 ELSEIF(ISUB.EQ.78) THEN
18205 C...W+/- + h0 -> W+/- + h0
18207 ELSEIF(ISUB.EQ.79) THEN
18208 C...h0 + h0 -> h0 + h0
18210 ELSEIF(ISUB.EQ.80) THEN
18211 C...q + gamma -> q' + pi+/-
18212 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
18213 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
18214 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
18215 DELSH=UH*SQRT(ASSH*Q2FPSH)
18216 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
18217 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
18218 DELUH=SH*SQRT(ASUH*Q2FPUH)
18219 DO 980 I=MAX(-2,MMINA),MIN(2,MMAXA)
18220 IF(I.EQ.0) GOTO 980
18221 EI=KCHG(IABS(I),1)/3D0
18222 EJ=SIGN(1D0-ABS(EI),EI)
18224 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970
18225 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970
18228 ISIG(NCHN,3-ISDE)=22
18230 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
18236 C...C: 2 -> 2, tree diagrams with masses
18238 ELSEIF(ISUB.LE.90) THEN
18239 IF(ISUB.EQ.81) THEN
18240 C...q + qbar -> Q + Qbar
18241 FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQM3)**2+
18242 & (UH-SQM3)**2)/SH2+2D0*SQM3/SH)
18243 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQM3,0D0)
18245 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18246 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18248 DO 990 I=MMINA,MMAXA
18249 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18250 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990
18258 ELSEIF(ISUB.EQ.82) THEN
18259 C...g + g -> Q + Qbar
18260 IF(MSTP(34).EQ.0) THEN
18261 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18262 & 2D0*(UH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18264 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18265 & 2D0*(TH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18268 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18269 & 2.25D0*(UH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18270 & (TH-SQM3)**2+0.5D0*SQM3*TH/(TH-SQM3)**2-SQM3**2/
18272 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18273 & 2.25D0*(TH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18274 & (UH-SQM3)**2+0.5D0*SQM3*UH/(UH-SQM3)**2-SQM3**2/
18277 IF(MSTP(35).GE.1) THEN
18278 FATRE=PYHFTH(SH,SQM3,2D0/7D0)
18279 FACQQ1=FACQQ1*FATRE
18280 FACQQ2=FACQQ2*FATRE
18283 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18284 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18287 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1000
18300 ELSEIF(ISUB.EQ.83) THEN
18301 C...f + q -> f' + Q
18302 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
18303 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
18304 DO 1020 I=MMIN1,MMAX1
18305 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
18306 DO 1010 J=MMIN2,MMAX2
18307 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
18308 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010
18309 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010
18310 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
18316 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18317 & (IABS(I)+1)/2)*VINT(180+J)
18318 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
18319 & (MINT(55)+1)/2)*VINT(180+J)
18322 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18323 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18326 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18327 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18330 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18331 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18333 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
18339 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18340 & (IABS(J)+1)/2)*VINT(180+I)
18341 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
18342 & (MINT(55)+1)/2)*VINT(180+I)
18344 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18345 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18348 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18349 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18352 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18353 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18358 ELSEIF(ISUB.EQ.84) THEN
18359 C...g + gamma -> Q + Qbar
18360 FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18361 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
18362 & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18363 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQM3,0D0)
18365 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18366 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18368 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18375 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18383 ELSEIF(ISUB.EQ.85) THEN
18384 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
18385 FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18386 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
18387 & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18388 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
18389 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
18390 & FACFF=FACFF*PYHFTH(SH,SQM3,1D0)
18392 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
18393 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
18394 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
18396 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18404 ELSEIF(ISUB.EQ.86) THEN
18405 C...g + g -> J/Psi + g
18406 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
18407 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18408 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18409 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18417 ELSEIF(ISUB.EQ.87) THEN
18418 C...g + g -> chi_0c + g
18419 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18420 QGTW=(SH*TH*UH)/SH**3
18422 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18423 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18424 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
18425 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
18426 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
18427 & (QGTW*(QGTW-RGTW*PGTW)**4)
18428 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18436 ELSEIF(ISUB.EQ.88) THEN
18437 C...g + g -> chi_1c + g
18438 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18439 QGTW=(SH*TH*UH)/SH**3
18441 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18442 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
18443 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
18444 & (QGTW-RGTW*PGTW)**4
18445 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18453 ELSEIF(ISUB.EQ.89) THEN
18454 C...g + g -> chi_2c + g
18455 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18456 QGTW=(SH*TH*UH)/SH**3
18458 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18459 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18460 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
18461 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
18462 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
18463 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
18464 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18473 C...D: Mimimum bias processes
18475 ELSEIF(ISUB.LE.100) THEN
18476 IF(ISUB.EQ.91) THEN
18477 C...Elastic scattering
18480 ELSEIF(ISUB.EQ.92) THEN
18481 C...Single diffractive scattering (first side, i.e. XB)
18484 ELSEIF(ISUB.EQ.93) THEN
18485 C...Single diffractive scattering (second side, i.e. AX)
18488 ELSEIF(ISUB.EQ.94) THEN
18489 C...Double diffractive scattering
18492 ELSEIF(ISUB.EQ.95) THEN
18493 C...Low-pT scattering
18496 ELSEIF(ISUB.EQ.96) THEN
18497 C...Multiple interactions: sum of QCD processes
18498 CALL PYWIDT(21,SH,WDTP,WDTE)
18500 C...q + q' -> q + q'
18501 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
18502 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
18503 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
18504 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
18505 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
18507 IF(I.EQ.0) GOTO 1040
18509 IF(J.EQ.0) GOTO 1030
18515 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
18517 SIGH(NCHN)=0.5D0*SIGH(NCHN)
18522 SIGH(NCHN)=0.5D0*FACQQ2
18527 C...q + qbar -> q' + qbar' or g + g
18528 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
18529 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
18530 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18532 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18535 IF(I.EQ.0) GOTO 1050
18545 SIGH(NCHN)=0.5D0*FACGG1
18550 SIGH(NCHN)=0.5D0*FACGG2
18554 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
18556 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
18559 IF(I.EQ.0) GOTO 1070
18563 ISIG(NCHN,3-ISDE)=21
18568 ISIG(NCHN,3-ISDE)=21
18574 C...g + g -> q + qbar or g + g
18575 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18576 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18577 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18578 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18579 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
18580 & 2D0*TH/SH+TH2/SH2)*FACA
18581 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
18582 & 2D0*SH/UH+SH2/UH2)*FACA
18583 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
18584 & 2D0*UH/TH+UH2/TH2)
18599 SIGH(NCHN)=0.5D0*FACGG1
18604 SIGH(NCHN)=0.5D0*FACGG2
18609 SIGH(NCHN)=0.5D0*FACGG3
18612 C...E: 2 -> 1, loop diagrams
18614 ELSEIF(ISUB.LE.110) THEN
18615 IF(ISUB.EQ.101) THEN
18616 C...g + g -> gamma*/Z0
18618 ELSEIF(ISUB.EQ.102) THEN
18619 C...g + g -> h0 (or H0, or A0)
18620 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18622 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18623 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18624 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18626 HI=SHR*WDTP(13)/32D0
18627 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080
18632 SIGH(NCHN)=HI*FACBW*HF
18635 ELSEIF(ISUB.EQ.103) THEN
18636 C...gamma + gamma -> h0 (or H0, or A0)
18637 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18639 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18640 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18641 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18643 HI=SHR*WDTP(14)*2D0
18644 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090
18649 SIGH(NCHN)=HI*FACBW*HF
18652 C...Continuation C: 2 -> 2, tree diagrams with masses.
18654 ELSEIF(ISUB.EQ.106) THEN
18655 C...g + g -> J/Psi + gamma.
18657 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
18658 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18659 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18660 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18668 ELSEIF(ISUB.EQ.107) THEN
18669 C...g + gamma -> J/Psi + g.
18671 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
18672 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18673 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18674 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18681 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18689 ELSEIF(ISUB.EQ.108) THEN
18690 C...gamma + gamma -> J/Psi + gamma.
18692 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
18693 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18694 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18695 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18703 C...F: 2 -> 2, box diagrams
18705 ELSEIF(ISUB.EQ.110) THEN
18706 C...f + fbar -> gamma + h0
18707 THUH=MAX(TH*UH,SH*CKIN(3)**2)
18708 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
18709 FACHG=FACHG*WIDS(KFHIGG,2)
18710 C...Calculate loop contributions for intermediate gamma* and Z0
18711 CIGTOT=CMPLX(0.,0.)
18712 CIZTOT=CMPLX(0.,0.)
18715 IF(J.LE.2*MSTP(1)) THEN
18718 AJ=SIGN(1D0,EJ+0.1D0)
18720 BALP=SQM4/(2D0*PMAS(J,1))**2
18721 BBET=SH/(2D0*PMAS(J,1))**2
18722 ELSEIF(J.LE.3*MSTP(1)) THEN
18724 JL=2*(J-2*MSTP(1))-1
18725 EJ=KCHG(10+JL,1)/3D0
18726 AJ=SIGN(1D0,EJ+0.1D0)
18728 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
18729 BBET=SH/(2D0*PMAS(10+JL,1))**2
18731 BALP=SQM4/(2D0*PMAS(24,1))**2
18732 BBET=SH/(2D0*PMAS(24,1))**2
18734 BABI=1D0/(BALP-BBET)
18735 IF(BALP.LT.1D0) THEN
18736 F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.)
18739 F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
18740 & -SNGL(0.5D0*PARU(1)))
18743 F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
18744 IF(BBET.LT.1D0) THEN
18745 F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.)
18748 F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
18749 & -SNGL(0.5D0*PARU(1)))
18752 F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET
18753 IF(J.LE.3*MSTP(1)) THEN
18754 FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+
18755 & BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP))
18756 CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF
18757 CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF
18760 CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)*
18761 & (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
18762 & SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
18763 CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP*
18764 & (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+
18765 & SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
18769 CIGTOT=CIGTOT/SNGL(SH)
18770 CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ))
18771 C...Loop over initial flavours
18772 DO 1110 I=MMINA,MMAXA
18773 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110
18774 EI=KCHG(IABS(I),1)/3D0
18778 IF(IABS(I).LE.10) FCOI=FACA/3D0
18783 SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)*
18784 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
18789 ELSEIF(ISUB.LE.120) THEN
18790 IF(ISUB.EQ.111) THEN
18791 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
18794 DO 1120 I=1,2*MSTP(1)
18798 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18799 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18800 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18801 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18802 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
18803 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
18804 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
18805 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
18807 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18808 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
18809 FACGH=FACGH*WIDS(25,2)
18810 DO 1130 I=MMINA,MMAXA
18811 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18812 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130
18820 ELSEIF(ISUB.EQ.112) THEN
18821 C...f + g -> f + h0 (q + g -> q + h0 only)
18824 DO 1140 I=1,2*MSTP(1)
18828 CALL PYWAUX(1,EPST,W1TR,W1TI)
18829 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18830 CALL PYWAUX(2,EPST,W2TR,W2TI)
18831 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18832 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
18833 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
18834 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
18835 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
18837 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18838 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
18839 FACQH=FACQH*WIDS(25,2)
18840 DO 1160 I=MMINA,MMAXA
18841 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160
18843 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150
18844 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150
18847 ISIG(NCHN,3-ISDE)=21
18853 ELSEIF(ISUB.EQ.113) THEN
18854 C...g + g -> g + h0
18863 DO 1170 I=1,2*MSTP(1)
18869 IF(EPSH.LT.1.D-6) GOTO 1170
18870 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18871 CALL PYWAUX(1,EPST,W1TR,W1TI)
18872 CALL PYWAUX(1,EPSU,W1UR,W1UI)
18873 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18874 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18875 CALL PYWAUX(2,EPST,W2TR,W2TI)
18876 CALL PYWAUX(2,EPSU,W2UR,W2UI)
18877 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18878 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
18879 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
18880 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
18881 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
18882 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
18883 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
18884 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
18885 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
18886 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
18887 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
18888 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
18889 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
18890 W3STUR=YHSTUR-Y3STUR-Y3UTSR
18891 W3STUI=YHSTUI-Y3STUI-Y3UTSI
18892 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
18893 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
18894 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
18895 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
18896 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
18897 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
18898 W3USTR=YHUSTR-Y3USTR-Y3TSUR
18899 W3USTI=YHUSTI-Y3USTI-Y3TSUI
18900 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
18901 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
18902 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
18903 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
18904 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
18905 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
18906 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
18907 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
18908 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
18909 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
18910 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
18911 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
18912 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
18913 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
18914 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
18915 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
18916 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
18917 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
18918 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
18919 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
18920 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
18921 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
18922 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
18923 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
18924 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
18925 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
18926 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
18927 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
18928 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
18929 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
18930 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
18931 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
18932 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
18933 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
18934 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
18935 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
18936 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
18937 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
18938 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
18939 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
18940 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
18941 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
18942 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
18943 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
18944 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
18945 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
18946 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
18947 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
18948 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
18949 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
18950 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
18951 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
18952 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
18953 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
18954 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
18955 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
18956 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
18957 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
18958 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
18959 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
18960 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
18961 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
18962 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18963 & (W2SR-W2HR+W3STUR))
18964 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
18965 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18966 & (W2TR-W2HR+W3TUSR))
18967 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
18968 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18969 & (W2UR-W2HR+W3USTR))
18970 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
18971 A2STUR=A2STUR+B2STUR+B2SUTR
18972 A2STUI=A2STUI+B2STUI+B2SUTI
18973 A2USTR=A2USTR+B2USTR+B2UTSR
18974 A2USTI=A2USTI+B2USTI+B2UTSI
18975 A2TUSR=A2TUSR+B2TUSR+B2TSUR
18976 A2TUSI=A2TUSI+B2TUSI+B2TSUI
18977 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
18978 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
18980 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
18981 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
18982 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
18983 FACGH=FACGH*WIDS(25,2)
18984 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180
18992 ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
18993 C...g + g -> gamma + gamma or g + g -> g + gamma
19008 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
19010 EI=KCHG(IABS(I),1)/3D0
19012 IF(ISUB.EQ.115) EIWT=EI
19017 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1.D-4) THEN
19018 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
19021 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
19022 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
19023 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
19024 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
19030 CALL PYWAUX(1,EPSS,W1SR,W1SI)
19031 CALL PYWAUX(1,EPST,W1TR,W1TI)
19032 CALL PYWAUX(1,EPSU,W1UR,W1UI)
19033 CALL PYWAUX(2,EPSS,W2SR,W2SI)
19034 CALL PYWAUX(2,EPST,W2TR,W2TI)
19035 CALL PYWAUX(2,EPSU,W2UR,W2UI)
19036 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
19037 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
19038 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
19039 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
19040 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
19041 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
19042 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
19043 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
19044 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
19045 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
19046 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
19047 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
19048 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
19049 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
19050 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
19051 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
19052 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
19053 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
19054 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
19055 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
19056 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
19057 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
19058 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19059 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
19060 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
19061 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
19062 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
19063 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
19064 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19065 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
19066 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
19067 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
19068 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
19069 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
19070 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19071 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
19072 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
19073 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
19074 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
19075 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
19076 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19077 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
19078 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
19079 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
19080 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
19081 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
19082 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
19083 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
19084 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
19085 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
19086 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
19087 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
19088 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
19089 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
19090 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
19091 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
19093 A0STUR=A0STUR+EIWT*B0STUR
19094 A0STUI=A0STUI+EIWT*B0STUI
19095 A0TSUR=A0TSUR+EIWT*B0TSUR
19096 A0TSUI=A0TSUI+EIWT*B0TSUI
19097 A0UTSR=A0UTSR+EIWT*B0UTSR
19098 A0UTSI=A0UTSI+EIWT*B0UTSI
19099 A1STUR=A1STUR+EIWT*B1STUR
19100 A1STUI=A1STUI+EIWT*B1STUI
19101 A2STUR=A2STUR+EIWT*B2STUR
19102 A2STUI=A2STUI+EIWT*B2STUI
19104 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
19105 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
19106 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
19107 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
19108 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1200
19113 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
19114 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
19117 ELSEIF(ISUB.EQ.116) THEN
19118 C...g + g -> gamma + Z0
19120 ELSEIF(ISUB.EQ.117) THEN
19121 C...g + g -> Z0 + Z0
19123 ELSEIF(ISUB.EQ.118) THEN
19124 C...g + g -> W+ + W-
19128 C...G: 2 -> 3, tree diagrams
19130 ELSEIF(ISUB.LE.140) THEN
19131 IF(ISUB.EQ.121) THEN
19132 C...g + g -> Q + Qbar + h0
19133 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210
19136 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19137 & (0.5D0*PMF/PMAS(24,1))**2
19138 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19139 & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19140 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19142 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19144 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19146 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19147 IF(IA.GT.10) IKFI=3
19148 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19150 CALL PYQQBH(WTQQBH)
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))
19161 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19164 ELSEIF(ISUB.EQ.122) THEN
19165 C...q + qbar -> Q + Qbar + h0
19168 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19169 & (0.5D0*PMF/PMAS(24,1))**2
19170 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19171 & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19172 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19174 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19176 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19178 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19179 IF(IA.GT.10) IKFI=3
19180 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19182 CALL PYQQBH(WTQQBH)
19183 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19185 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19186 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19187 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19189 DO 1220 I=MMINA,MMAXA
19190 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19191 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220
19196 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19199 ELSEIF(ISUB.EQ.123) THEN
19200 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
19202 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
19203 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19204 & PARU(154+10*IHIGG)**2
19205 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19206 & (VINT(216)-VINT(209)**2))**2
19207 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19208 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
19209 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19211 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19212 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19213 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19215 DO 1240 I=MMIN1,MMAX1
19216 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240
19218 DO 1230 J=MMIN2,MMAX2
19219 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230
19221 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
19222 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
19224 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
19225 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
19227 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
19228 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
19233 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
19237 ELSEIF(ISUB.EQ.124) THEN
19238 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
19240 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
19241 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19242 & PARU(155+10*IHIGG)**2
19243 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19244 & (VINT(216)-VINT(209)**2))**2
19245 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19246 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19248 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19249 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19250 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19252 DO 1260 I=MMIN1,MMAX1
19253 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260
19254 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
19255 DO 1250 J=MMIN2,MMAX2
19256 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250
19257 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
19258 IF(EI*EJ.GT.0D0) GOTO 1250
19259 FACLR=VINT(180+I)*VINT(180+J)
19264 SIGH(NCHN)=FACLR*FACWW*FACBW
19268 ELSEIF(ISUB.EQ.131) THEN
19269 C...g + g -> Z0 + q + qbar
19273 C...H: 2 -> 1, tree diagrams, non-standard model processes
19275 ELSEIF(ISUB.LE.160) THEN
19276 IF(ISUB.EQ.141) THEN
19277 C...f + fbar -> gamma*/Z0/Z'0
19278 SQMZP=PMAS(32,1)**2
19280 CALL PYWIDT(32,SH,WDTP,WDTE)
19286 FACZP=4D0*COMFAC*3D0
19287 DO 1270 I=MMINA,MMAXA
19288 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1270
19289 EI=KCHG(IABS(I),1)/3D0
19292 IF(IABS(I).LT.10) THEN
19293 VPI=PARU(123-2*MOD(IABS(I),2))
19294 API=PARU(124-2*MOD(IABS(I),2))
19296 VPI=PARU(127-2*MOD(IABS(I),2))
19297 API=PARU(128-2*MOD(IABS(I),2))
19300 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
19302 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
19304 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
19309 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
19310 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
19311 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
19312 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
19313 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
19314 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
19315 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
19316 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
19319 ELSEIF(ISUB.EQ.142) THEN
19320 C...f + fbar' -> W'+/-
19321 SQMWP=PMAS(34,1)**2
19322 CALL PYWIDT(34,SH,WDTP,WDTE)
19324 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
19325 HP=AEM/(24D0*XW)*SH
19326 DO 1290 I=MMIN1,MMAX1
19327 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1290
19329 DO 1280 J=MMIN2,MMAX2
19330 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1280
19332 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1280
19333 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19335 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19336 HI=HP*(PARU(133)**2+PARU(134)**2)
19337 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
19338 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19343 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
19344 SIGH(NCHN)=HI*FACBW*HF
19348 ELSEIF(ISUB.EQ.143) THEN
19349 C...f + fbar' -> H+/-
19350 SQMHC=PMAS(37,1)**2
19351 CALL PYWIDT(37,SH,WDTP,WDTE)
19353 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
19354 HP=AEM/(8D0*XW)*SH/SQMW*SH
19355 DO 1310 I=MMIN1,MMAX1
19356 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1310
19358 IM=(MOD(IA,10)+1)/2
19359 DO 1300 J=MMIN2,MMAX2
19360 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1300
19362 JM=(MOD(JA,10)+1)/2
19363 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1300
19364 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19366 IF(MOD(IA,2).EQ.0) THEN
19373 RML=PMAS(IL,1)**2/SH
19374 RMU=PMAS(IU,1)**2/SH
19375 IF(IL.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) RML=
19376 & RML*(LOG(MAX(4D0,PARP(37)**2*RML*SH/PARU(117)**2))/
19377 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-
19379 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
19380 IF(IA.LE.10) HI=HI*FACA/3D0
19381 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19382 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
19387 SIGH(NCHN)=HI*FACBW*HF
19391 ELSEIF(ISUB.EQ.144) THEN
19394 CALL PYWIDT(40,SH,WDTP,WDTE)
19396 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
19397 HP=AEM/(12D0*XW)*SH
19398 DO 1330 I=MMIN1,MMAX1
19399 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1330
19401 DO 1320 J=MMIN2,MMAX2
19402 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1320
19404 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1320
19406 IF(IA.LE.10) HI=HI*FACA/3D0
19407 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
19412 SIGH(NCHN)=HI*FACBW*HF
19416 ELSEIF(ISUB.EQ.145) THEN
19417 C...q + l -> LQ (leptoquark)
19418 SQMLQ=PMAS(39,1)**2
19419 CALL PYWIDT(39,SH,WDTP,WDTE)
19421 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
19422 IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0
19424 KFLQQ=KFDP(MDCY(39,2),1)
19425 KFLQL=KFDP(MDCY(39,2),2)
19426 DO 1350 I=MMIN1,MMAX1
19427 IF(KFAC(1,I).EQ.0) GOTO 1350
19429 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1350
19430 DO 1340 J=MMIN2,MMAX2
19431 IF(KFAC(2,J).EQ.0) GOTO 1340
19433 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1340
19434 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1340
19435 IF(JA.EQ.IA) GOTO 1340
19436 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
19437 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
19439 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
19444 SIGH(NCHN)=HI*FACBW*HF
19448 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
19449 C...d + g -> d* and u + g -> u* (excited quarks)
19450 KFQSTR=KFPR(ISUB,1)
19451 KCQSTR=PYCOMP(KFQSTR)
19452 KFQEXC=MOD(KFQSTR,KEXCIT)
19453 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
19455 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
19456 FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
19457 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
19460 DO 1370 I=-KFQEXC,KFQEXC,2*KFQEXC
19462 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
19463 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
19465 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19466 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
19469 ISIG(NCHN,3-ISDE)=21
19471 SIGH(NCHN)=HI*FACBW*HF
19475 ELSEIF(ISUB.EQ.149) THEN
19476 C...g + g -> eta_techni
19477 CALL PYWIDT(38,SH,WDTP,WDTE)
19479 FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2)
19480 IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0
19482 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1380
19484 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19489 SIGH(NCHN)=HI*FACBW*HF
19494 C...I: 2 -> 2, tree diagrams, non-standard model processes
19496 ELSEIF(ISUB.LE.200) THEN
19497 IF(ISUB.EQ.161) THEN
19498 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
19499 C...(choice of only b and t to avoid kinematics problems)
19500 SQMHC=PMAS(37,1)**2
19501 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
19502 DO 1400 I=MMINA,MMAXA
19504 IF(IA.NE.5) GOTO 1400
19506 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
19507 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
19508 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19510 SQMQ=PMAS(IUA,1)**2
19511 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
19512 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
19513 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
19514 & (SQMHC-SQMQ-SH)/SH)
19515 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
19517 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1390
19518 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1390
19521 ISIG(NCHN,3-ISDE)=21
19523 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
19527 ELSEIF(ISUB.EQ.162) THEN
19528 C...q + g -> LQ + lbar; LQ=leptoquark
19529 SQMLQ=PMAS(39,1)**2
19530 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
19531 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
19532 KFLQQ=KFDP(MDCY(39,2),1)
19533 DO 1420 I=MMINA,MMAXA
19534 IF(IABS(I).NE.KFLQQ) GOTO 1420
19537 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1410
19538 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1410
19541 ISIG(NCHN,3-ISDE)=21
19543 SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
19547 ELSEIF(ISUB.EQ.163) THEN
19548 C...g + g -> LQ + LQbar; LQ=leptoquark
19549 SQMLQ=PMAS(39,1)**2
19550 FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)*
19551 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
19552 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
19553 & ((TH-SQMLQ)*(UH-SQMLQ)))
19554 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1430
19558 C...Since don't know proper colour flow, randomize between alternatives
19559 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
19563 ELSEIF(ISUB.EQ.164) THEN
19564 C...q + qbar -> LQ + LQbar; LQ=leptoquark
19565 SQMLQ=PMAS(39,1)**2
19566 FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)*
19567 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
19568 FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)*
19569 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
19570 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
19571 KFLQQ=KFDP(MDCY(39,2),1)
19572 DO 1440 I=MMINA,MMAXA
19573 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19574 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1440
19580 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
19583 ELSEIF(ISUB.EQ.165) THEN
19584 C...q + qbar -> l+ + l- (including contact term for compositeness)
19585 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19586 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19587 KFF=IABS(KFPR(ISUB,1))
19589 AF=SIGN(1D0,EF+0.1D0)
19594 IF(KFF.LE.10) FCOF=3D0
19596 IF(KFF.EQ.6) WID2=WIDS(6,1)
19597 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
19598 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19599 DO 1450 I=MMINA,MMAXA
19600 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1450
19601 EI=KCHG(IABS(I),1)/3D0
19602 AI=SIGN(1D0,EI+0.1D0)
19607 IF(IABS(I).LE.10) FCOI=FACA/3D0
19608 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
19609 FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
19610 & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
19611 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19613 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
19614 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19616 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
19617 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
19618 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
19619 IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
19620 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
19625 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
19628 ELSEIF(ISUB.EQ.166) THEN
19629 C...q + q'bar -> l + nu_l (including contact term for compositeness)
19630 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
19631 WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
19632 KFF=IABS(KFPR(ISUB,1))
19634 IF(KFF.LE.10) FCOF=3D0
19635 DO 1470 I=MMIN1,MMAX1
19636 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
19638 DO 1460 J=MMIN2,MMAX2
19639 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
19641 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1460
19642 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19645 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19647 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
19648 & MOD(J,2).EQ.0)) THEN
19649 IF(KFF.EQ.5) WID2=WIDS(6,2)
19650 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
19651 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
19653 IF(KFF.EQ.5) WID2=WIDS(6,3)
19654 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
19655 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
19661 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
19662 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
19663 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
19667 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
19668 C...d + g -> d* and u + g -> u* (excited quarks)
19669 KFQSTR=KFPR(ISUB,2)
19670 KCQSTR=PYCOMP(KFQSTR)
19671 KFQEXC=MOD(KFQSTR,KEXCIT)
19672 FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
19673 FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
19674 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
19675 C...Propagators: as simulated in PYOFSH and as desired
19676 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
19677 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
19678 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
19679 GMMQC=SQRT(SQM4)*WDTP(0)
19680 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
19681 FACQSA=FACQSA*HBW4C/HBW4
19682 FACQSB=FACQSB*HBW4C/HBW4
19683 DO 1490 I=MMIN1,MMAX1
19685 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1490
19686 DO 1480 J=MMIN2,MMAX2
19688 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1480
19689 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
19694 SIGH(NCHN)=(4D0/3D0)*FACQSA
19699 SIGH(NCHN)=(4D0/3D0)*FACQSA
19700 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
19705 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19707 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
19712 SIGH(NCHN)=(8D0/3D0)*FACQSB
19717 SIGH(NCHN)=(8D0/3D0)*FACQSB
19718 ELSEIF(I.EQ.-J) THEN
19729 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
19734 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19740 ELSEIF(ISUB.EQ.191) THEN
19741 C...q + qbar -> rho_tech0.
19742 SQMRHT=PMAS(54,1)**2
19743 CALL PYWIDT(54,SH,WDTP,WDTE)
19745 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19746 IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0
19747 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19748 ALPRHT=2.91D0*(3D0/PARP(144))
19749 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
19750 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19751 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19752 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19753 DO 1500 I=MMINA,MMAXA
19754 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
19756 EI=KCHG(IABS(I),1)/3D0
19757 AI=SIGN(1D0,EI+0.1D0)
19761 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
19762 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
19763 IF(IA.LE.10) HI=HI*FACA/3D0
19768 SIGH(NCHN)=HI*FACBW*HF
19771 ELSEIF(ISUB.EQ.192) THEN
19772 C...q + qbar' -> rho_tech+/-.
19773 SQMRHT=PMAS(55,1)**2
19774 CALL PYWIDT(55,SH,WDTP,WDTE)
19776 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19777 IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0
19778 ALPRHT=2.91D0*(3D0/PARP(144))
19779 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
19780 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
19781 DO 1520 I=MMIN1,MMAX1
19782 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1520
19784 DO 1510 J=MMIN2,MMAX2
19785 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1510
19787 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1510
19788 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19790 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19791 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
19793 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19798 SIGH(NCHN)=HI*FACBW*HF
19802 ELSEIF(ISUB.EQ.193) THEN
19803 C...q + qbar -> omega_tech0.
19804 SQMOMT=PMAS(56,1)**2
19805 CALL PYWIDT(56,SH,WDTP,WDTE)
19807 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
19808 IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0
19809 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19810 ALPRHT=2.91D0*(3D0/PARP(144))
19811 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
19812 & (2D0*PARP(143)-1D0)**2
19813 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19814 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19815 DO 1530 I=MMINA,MMAXA
19816 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1530
19818 EI=KCHG(IABS(I),1)/3D0
19819 AI=SIGN(1D0,EI+0.1D0)
19823 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
19824 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
19825 IF(IA.LE.10) HI=HI*FACA/3D0
19830 SIGH(NCHN)=HI*FACBW*HF
19833 ELSEIF(ISUB.EQ.194) THEN
19834 C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
19835 SQMRHT=PMAS(54,1)**2
19836 CALL PYWIDT(54,SH,WDTP,WDTE)
19838 BWRHTR=SQMRHT**2*(SH-SQMRHT)/((SH-SQMRHT)**2+HSRHT**2)
19839 BWRHTI=SQMRHT**2*HSRHT/((SH-SQMRHT)**2+HSRHT**2)
19840 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19841 SQMOMT=PMAS(56,1)**2
19842 CALL PYWIDT(56,SH,WDTP,WDTE)
19844 BWOMTR=SQMOMT**2*(SH-SQMOMT)/((SH-SQMOMT)**2+HSOMT**2)
19845 BWOMTI=SQMOMT**2*HSOMT/((SH-SQMOMT)**2+HSOMT**2)
19846 XWOMT=0.5D0/(1D0-XW)
19847 KFF=IABS(KFPR(ISUB,1))
19849 AF=SIGN(1D0,EF+0.1D0)
19854 IF(KFF.LE.10) FCOF=3D0
19856 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
19857 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19858 ALPRHT=2.91D0*(3D0/PARP(144))
19859 FACTC=COMFAC*(AEM**2/(ALPRHT*SH2))**2*FCOF*WID2
19861 ALEFTF=EF+VALF*XWRHT*BWZ
19862 ARIGHF=EF+VARF*XWRHT*BWZ
19863 BLEFTF=(EF-VALF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19864 BRIGHF=(EF-VARF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19865 DO 1540 I=MMINA,MMAXA
19866 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
19867 EI=KCHG(IABS(I),1)/3D0
19868 AI=SIGN(1D0,EI+0.1D0)
19873 IF(IABS(I).LE.10) FCOI=FACA/3D0
19874 ALEFTI=EI+VALI*XWRHT*BWZ
19875 ARIGHI=EI+VARI*XWRHT*BWZ
19876 BLEFTI=(EI-VALI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19877 BRIGHI=(EI-VARI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19878 DIFLL=(ALEFTI*ALEFTF*BWRHTR+BLEFTI*BLEFTF*BWOMTR)**2+
19879 & (ALEFTI*ALEFTF*BWRHTI+BLEFTI*BLEFTF*BWOMTI)**2
19880 DIFRR=(ARIGHI*ARIGHF*BWRHTR+BRIGHI*BRIGHF*BWOMTR)**2+
19881 & (ARIGHI*ARIGHF*BWRHTI+BRIGHI*BRIGHF*BWOMTI)**2
19882 DIFLR=(ALEFTI*ARIGHF*BWRHTR+BLEFTI*BRIGHF*BWOMTR)**2+
19883 & (ALEFTI*ARIGHF*BWRHTI+BLEFTI*BRIGHF*BWOMTI)**2
19884 DIFRL=(ARIGHI*ALEFTF*BWRHTR+BRIGHI*BLEFTF*BWOMTR)**2+
19885 & (ARIGHI*ALEFTF*BWRHTI+BRIGHI*BLEFTF*BWOMTI)**2
19886 FACSIG=(DIFLL+DIFRR)*UH2+(DIFLR+DIFRL)*TH2
19891 SIGH(NCHN)=FACTC*FCOI*FACSIG
19897 C...J: 2 -> 2, tree diagrams, SUSY processes
19899 ELSEIF(ISUB.LE.210) THEN
19900 IF(ISUB.EQ.201) THEN
19901 C...f + fbar -> e_L + e_Lbar
19902 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
19903 DO 1570 I=MMIN1,MMAX1
19905 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1570
19907 TT3I=SIGN(1D0,EI+1D-6)/2D0
19911 C...Color factor for e+ e-
19912 IF(IA.GE.11) FCOL=3D0
19914 A1=SFMIX(KFID,3)**2
19915 A2=SFMIX(KFID,4)**2
19916 ELSEIF(ILR.EQ.0) THEN
19917 A1=SFMIX(KFID,1)**2
19918 A2=SFMIX(KFID,2)**2
19920 XLQ=(TT3J-EJ*XW)*A1
19925 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
19926 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
19927 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
19928 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
19932 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19938 DK=1D0/(TH-SMZ(II)**2)
19939 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
19941 FREK=FAC2*TANW*EI*ZMIX(II,1)
19942 TNN1=TNN1+FLEK**2*DK
19943 TNN2=TNN2+FREK**2*DK
19945 DL=1D0/(TH-SMZ(JJ)**2)
19946 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
19948 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
19949 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
19952 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
19953 TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
19954 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
19955 & (TNN1*XLF*A1+TNN2*XRF*A2)
19956 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
19959 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
19961 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
19962 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
19963 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
19968 SIGH(NCHN)=FACQQ1+FACQQ2
19971 ELSEIF(ISUB.EQ.203) THEN
19972 C...f + fbar -> e_L + e_Rbar
19973 DO 1600 I=MMIN1,MMAX1
19975 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
19976 EI=KCHG(IABS(I),1)/3D0
19977 TT3I=SIGN(1D0,EI)/2D0
19981 C...Color factor for e+ e-
19982 IF(IA.GE.11) FCOL=3D0
19983 A1=SFMIX(KFID,1)**2
19984 A2=SFMIX(KFID,2)**2
19989 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
19990 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
19993 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19999 DK=1D0/(TH-SMZ(II)**2)
20000 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
20002 FREK=FAC2*TANW*EI*ZMIX(II,1)
20003 TNN1=TNN1+FLEK**2*DK
20004 TNN2=TNN2+FREK**2*DK
20006 DL=1D0/(TH-SMZ(JJ)**2)
20007 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
20009 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
20010 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
20013 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
20014 TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
20015 TZN=(UH*TH-SQM3*SQM4)*A1*A2
20016 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
20017 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
20020 FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
20021 FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
20022 FACQQ=(FACQQ1+FACQQ2)
20027 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20028 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
20033 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20034 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20037 ELSEIF(ISUB.EQ.210) THEN
20038 C...q + qbar' -> W*- > ~l_L + ~nu_L
20039 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
20040 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
20041 DO 1620 I=MMIN1,MMAX1
20043 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1620
20044 DO 1610 J=MMIN2,MMAX2
20046 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1610
20047 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1610
20049 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20050 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20052 IF(KCHSUM.LT.0) KCHW=3
20057 SIGH(NCHN)=FAC0*FAC1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),
20058 & 5-KCHW)*WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20063 ELSEIF(ISUB.LE.220) THEN
20064 IF(ISUB.EQ.213) THEN
20065 C...f + fbar -> ~nu_L + ~nu_Lbar
20066 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20067 PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
20070 DO 1630 I=MMIN1,MMAX1
20072 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
20075 C...Color factor for e+ e-
20076 IF(IA.GE.11) FCOL=3D0
20077 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20081 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
20082 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
20085 TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
20087 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
20093 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
20094 & *AEM**2*FCOL/3D0/XW**2
20097 ELSEIF(ISUB.EQ.216) THEN
20098 C...q + qbar -> ~chi0_1 + ~chi0_1
20099 IF(IZID1.EQ.IZID2) THEN
20100 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20102 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20103 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20105 FACGG1=COMFAC*AEM**2/3D0/XW**2
20106 IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0
20110 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20111 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20112 XS2 = SMZ(IZID1)*SMZ(IZID2)/SH
20113 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20114 REPRPZ = (SH-SQMZ)/PROPZ2
20115 OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+
20116 & ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0
20117 DO 1640 I=MMINA,MMAXA
20118 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1640
20119 EI=KCHG(IABS(I),1)/3D0
20121 IF(ABS(I).GE.11) FCOL=3D0
20122 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20126 C...Factored out sqrt(2)
20127 FR1=TANW*EI*ZMIX(IZID1,1)
20128 FR2=TANW*EI*ZMIX(IZID2,1)
20129 FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW*
20130 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0
20131 FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW*
20132 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0
20137 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
20138 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
20139 FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2)
20140 FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2-
20141 & 2D0*XS2*SH2/(TH-XML2)/(UH-XML2))
20142 FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2-
20143 & 2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2))
20144 FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/
20145 & (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) )
20146 FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/
20147 & (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) )
20152 SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU)
20156 ELSEIF(ISUB.LE.230) THEN
20157 IF(ISUB.EQ.226) THEN
20158 C...f + fbar -> ~chi+_1 + ~chi-_1
20159 FACGG1=COMFAC*AEM**2/3D0/XW**2
20162 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20163 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20164 WS2 = SMW(IZID1)*SMW(IZID2)/SH
20165 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20166 REPRPZ = (SH-SQMZ)/PROPZ2
20168 IF(IZID1.EQ.IZID2) DIFF=1D0
20169 DO 1650 I=MMINA,MMAXA
20170 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1650
20171 EI=KCHG(IABS(I),1)/3D0
20173 IF(IABS(I).GE.11) FCOL=3D0
20174 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20180 OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)-
20181 & VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF
20182 ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)-
20183 & UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF
20186 C...u-type quark - d-type squark
20187 IF(MOD(I,2).EQ.0) THEN
20188 FACT0 = UMIX(IZID1,1)*UMIX(IZID2,1)
20189 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
20190 C...d-type quark - u-type squark
20192 FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1)
20193 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
20195 FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2
20196 FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+
20197 & 4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)*
20198 & (WU2-WT2))*SH2/PROPZ2
20199 FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2
20200 FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+
20201 & WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI)
20202 FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI)
20203 FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2
20204 FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL
20209 IF(IZID1.EQ.IZID2) THEN
20210 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20212 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20213 & WIDS(PYCOMP(KFPR(ISUBSV,1)),2)
20218 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20219 & WIDS(PYCOMP(KFPR(ISUBSV,1)),3)
20223 ELSEIF(ISUB.EQ.229) THEN
20224 C...q + qbar' -> ~chi0_1 + ~chi+-_1
20225 FACGG1=COMFAC*AEM**2/6D0/XW**2
20228 ZMU2 = PMAS(PYCOMP(KSUSY1+2),1)**2
20229 ZMD2 = PMAS(PYCOMP(KSUSY1+1),1)**2
20230 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20231 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20232 WS2 = SMW(IZID1)*SMZ(IZID2)/SH
20233 RT2I = 1D0/SQRT(2D0)
20234 PROPW = ((SH-SQMW)**2+WWID**2*SQMW)
20235 OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+
20236 & ZMIX(IZID2,2)*VMIX(IZID1,1)
20237 OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+
20238 & ZMIX(IZID2,2)*UMIX(IZID1,1)
20242 FACST0=UMIX(IZID1,1)
20243 FACSU0=VMIX(IZID1,1)
20244 FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20245 FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20248 FACTU0=FACSU0*FACST0
20249 FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR
20250 & + SH2*WS2*OL)*FACST0
20251 FACSU = 2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL
20252 & + SH2*WS2*OR)*FACSU0
20253 FACT = WT2*SH2/(TH-ZMD2)**2*FACT0
20254 FACU = WU2*SH2/(UH-ZMU2)**2*FACU0
20255 FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0
20256 FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2
20257 FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST)
20258 DO 1670 I=MMIN1,MMAX1
20260 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1670
20261 DO 1660 J=MMIN2,MMAX2
20263 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1660
20264 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1660
20266 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20267 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20269 IF(KCHSUM.LT.0) KCHW=3
20274 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20275 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20280 ELSEIF(ISUB.LE.240) THEN
20281 IF(ISUB.EQ.237) THEN
20282 C...q + qbar -> gluino + ~chi0_1
20283 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20284 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20285 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
20288 DO 1680 I=MMINA,MMAXA
20289 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1680
20290 EI=KCHG(IABS(I),1)/3D0
20292 XLQC = -TANW*EI*ZMIX(IZID,1)
20293 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20294 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20297 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
20298 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
20299 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
20300 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
20301 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
20302 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20303 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
20304 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
20305 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
20306 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20311 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
20315 ELSEIF(ISUB.LE.250) THEN
20316 IF(ISUB.EQ.241) THEN
20317 C...q + qbar' -> ~chi+-_1 + gluino
20318 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
20321 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
20322 FAC0=UMIX(IZID,1)**2
20323 FAC1=VMIX(IZID,1)**2
20324 DO 1700 I=MMIN1,MMAX1
20326 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1700
20327 DO 1690 J=MMIN2,MMAX2
20329 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1690
20330 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1690
20332 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20333 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20335 IF(KCHSUM.LT.0) KCHW=3
20336 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
20337 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
20338 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
20339 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
20340 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
20341 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
20342 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
20343 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
20344 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
20345 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
20346 & SH/(TH-XMU2)/(UH-XMD2))/2D0
20351 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
20352 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20353 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20357 ELSEIF(ISUB.EQ.243) THEN
20358 C...q + qbar -> gluino + gluino
20359 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20362 DO 1710 I=MMINA,MMAXA
20363 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
20364 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
20366 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
20367 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
20368 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20369 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20370 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20371 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20372 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
20373 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
20374 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20375 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20376 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20377 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20381 C...1/2 for identical particles
20382 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
20385 ELSEIF(ISUB.EQ.244) THEN
20386 C...g + g -> gluino + gluino
20387 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20390 FACQQ1=COMFAC*AS**2*9D0/4D0*(
20391 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
20392 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
20393 FACQQ2=COMFAC*AS**2*9D0/4D0*(
20394 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
20395 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
20396 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
20397 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
20398 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
20403 SIGH(NCHN)=FACQQ1/2D0
20408 SIGH(NCHN)=FACQQ2/2D0
20413 SIGH(NCHN)=FACQQ3/2D0
20416 ELSEIF(ISUB.EQ.246) THEN
20417 C...g + q_j -> ~chi0_1 + ~q_j
20418 FAC0=COMFAC*AS*AEM/6D0/XW
20421 FACZQ0=FAC0*( (ZM2-TH)/SH +
20422 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20423 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20424 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20425 DO 1740 I=-KFNSQ,KFNSQ,2*KFNSQ
20426 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1740
20427 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
20428 EI=KCHG(IABS(I),1)/3D0
20430 XRQZ = -TANW*EI*ZMIX(IZID,1)
20431 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20432 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20434 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
20436 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
20442 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1730
20443 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1730
20446 ISIG(NCHN,3-ISDE)=21
20448 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20449 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20454 ELSEIF(ISUB.LE.260) THEN
20455 IF(ISUB.EQ.254) THEN
20456 C...g + q_j -> ~chi1_1 + ~q_i
20457 FAC0=COMFAC*AS*AEM/12D0/XW
20462 FACZQ0=FAC0*( (ZM2-TH)/SH +
20463 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20464 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20465 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
20466 IF(MOD(KFNSQ1,2).EQ.0) THEN
20473 DO 1760 I=-KFNSQ,KFNSQ,2*KFNSQ
20474 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1760
20475 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1760
20477 IF(MOD(IA,2).EQ.0) THEN
20482 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
20486 IF(I.LT.0) KCHWQ=5-KCHW
20488 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1750
20489 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1750
20492 ISIG(NCHN,3-ISDE)=21
20494 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20495 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
20499 ELSEIF(ISUB.EQ.258) THEN
20500 C...g + q_j -> gluino + ~q_i
20507 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
20508 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
20509 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
20510 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
20511 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
20513 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
20514 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
20515 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
20516 FACQG1=COMFAC*AS**2*FACQG1/2D0
20517 FACQG2=COMFAC*AS**2*FACQG2/2D0
20518 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20519 DO 1780 I=-KFNSQ,KFNSQ,2*KFNSQ
20520 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1780
20521 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1780
20524 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20525 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20527 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1770
20528 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1770
20531 ISIG(NCHN,3-ISDE)=21
20533 SIGH(NCHN)=FACQG1*FACSEL
20536 ISIG(NCHN,3-ISDE)=21
20538 SIGH(NCHN)=FACQG2*FACSEL
20543 ELSEIF(ISUB.LE.270) THEN
20544 IF(ISUB.EQ.261) THEN
20545 C...q_i + q_ibar -> ~t_1 + ~t_1bar
20546 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
20547 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20548 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20550 DO 1790 I=MMIN1,MMAX1
20552 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1790
20553 IF(IA.GE.11.AND.IA.LE.18) THEN
20555 EJ=KCHG(KFNSQ,1)/3D0
20556 T3I=SIGN(1D0,EI)/2D0
20557 T3J=SIGN(1D0,EJ)/2D0
20558 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
20559 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
20560 XLF=2D0*(T3I-EI*XW)
20562 TAA=0.5D0*(EI*EJ)**2
20563 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20564 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20565 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20566 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20567 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20573 SIGH(NCHN)=FACQQ1*FAC0
20576 ELSEIF(ISUB.EQ.263) THEN
20577 C...f + fbar -> ~t1 + ~t2bar
20578 DO 1800 I=MMIN1,MMAX1
20580 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
20581 EI=KCHG(IABS(I),1)/3D0
20582 TT3I=SIGN(1D0,EI)/2D0
20586 C...Color factor for e+ e-
20587 IF(IA.GE.11) FCOL=3D0
20588 XLQ=2D0*(TT3J-EJ*XW)
20590 XLF=2D0*(TT3I-EI*XW)
20592 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
20593 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
20594 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20595 C...Factor of 2 for t1 t2bar + t2 t1bar
20596 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
20597 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
20602 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20603 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
20608 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20609 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20612 ELSEIF(ISUB.EQ.264) THEN
20613 C...g + g -> ~t_1 + ~t_1bar
20616 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
20617 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20618 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20619 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20620 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1810
20634 ELSEIF(ISUB.LE.280) THEN
20635 IF(ISUB.EQ.271) THEN
20636 C...q + q' -> ~q + ~q' (~g exchange)
20637 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20645 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
20646 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
20649 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
20650 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
20651 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
20654 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20655 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20656 DO 1830 I=-KFNSQI,KFNSQI,2*KFNSQI
20657 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1830
20659 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1830
20662 DO 1820 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20663 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1820
20665 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1820
20666 IF(I*J.LT.0) GOTO 1820
20671 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20672 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20674 IF(ISUBSV.LE.272) THEN
20675 SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20676 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20678 SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20679 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20680 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20686 IF(ISUBSV.LE.272) THEN
20687 SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20688 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20690 SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20691 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20692 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20698 ELSEIF(ISUB.EQ.274) THEN
20699 C...q + qbar -> ~q' + ~qbar'
20700 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20704 FACQQ1=COMFAC*AS**2*4D0/9D0*(
20705 & (UH*TH-SQM3*SQM4)/XMT**2 )
20706 FACQQB=COMFAC*AS**2*4D0/9D0*(
20707 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT**2))
20708 FACQQB=FACQQB+FACQQ1
20710 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
20713 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20714 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20715 DO 1850 I=-KFNSQI,KFNSQI,2*KFNSQI
20716 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1850
20718 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1850
20721 DO 1840 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20722 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1840
20724 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1840
20725 IF(I*J.GT.0) GOTO 1840
20730 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20731 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
20732 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
20733 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20737 ELSEIF(ISUB.EQ.277) THEN
20738 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
20739 C...if i .eq. j covered in 274
20740 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
20741 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20743 DO 1860 I=MMIN1,MMAX1
20745 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
20746 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
20747 IF(IA.EQ.KFNSQ) GOTO 1860
20748 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
20750 EJ=KCHG(KFNSQ,1)/3D0
20752 T3I=SIGN(1D0,EI)/2D0
20754 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
20755 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
20757 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
20758 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
20760 XLF=2D0*(T3I-EI*XW)
20767 TAA=0.5D0*(EI*EJ)**2
20768 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20769 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20770 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20771 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20772 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20773 ELSEIF(IA.LE.6) THEN
20774 FAC0=AS**2*8D0/9D0/2D0
20780 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20783 ELSEIF(ISUB.EQ.279) THEN
20784 C...g + g -> ~q_j + ~q_jbar
20787 C...5=RKF because ~t ~tbar treated separately
20788 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
20789 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20790 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20791 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870
20796 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20801 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20808 C...Multiply with parton distributions
20809 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20810 DO 1880 ICHN=1,NCHN
20811 IF(MINT(45).GE.2) THEN
20813 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20815 IF(MINT(46).GE.2) THEN
20817 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20819 SIGS=SIGS+SIGH(ICHN)
20826 C*********************************************************************
20828 *$ CREATE PYPDFU.FOR
20831 C...Gives electron, photon, pi+, neutron, proton and hyperon
20832 C...parton distributions according to a few different parametrizations.
20833 C...Note that what is coded is x times the probability distribution,
20834 C...i.e. xq(x,Q2) etc.
20836 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
20838 C...Double precision and integer declarations.
20839 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20840 INTEGER PYK,PYCHGE,PYCOMP
20842 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20843 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20844 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20845 COMMON/PYINT1/MINT(400),VINT(400)
20846 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
20848 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
20850 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
20851 &XPPI(-6:6),XPPR(-6:6)
20853 C...Interface to PDFLIB.
20854 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
20856 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
20857 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
20858 CHARACTER*20 PARM(20)
20859 DATA VALUE/20*0D0/,PARM/20*' '/
20861 C...Data related to Schuler-Sjostrand photon distributions.
20862 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
20864 C...Reset parton distributions.
20870 C...Check x and particle species.
20871 IF(X.LE.0D0.OR.X.GE.1D0) THEN
20872 WRITE(MSTU(11),5000) X
20876 IF(KFA.NE.11.AND.KFA.NE.22.AND.KFA.NE.211.AND.KFA.NE.2112.AND.
20877 &KFA.NE.2212.AND.KFA.NE.3122.AND.KFA.NE.3112.AND.KFA.NE.3212
20878 &.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.KFA.NE.3322.AND.
20879 &KFA.NE.3334.AND.KFA.NE.111) THEN
20880 WRITE(MSTU(11),5100) KF
20884 C...Electron parton distribution call.
20886 CALL PYPDEL(X,Q2,XPEL)
20891 C...Photon parton distribution call (VDM+anomalous).
20892 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
20893 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
20894 CALL PYPDGA(X,Q2,XPGA)
20898 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
20901 IF(MSTP(55).GE.7) P2MX=4.0D0
20902 IF(MSTP(57).EQ.0) Q2MX=P2MX
20903 CALL PYGGAM(MSTP(55)-4,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20908 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
20911 IF(MSTP(55).GE.11) P2MX=4.0D0
20912 IF(MSTP(57).EQ.0) Q2MX=P2MX
20913 CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20915 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
20918 ELSEIF(MSTP(56).EQ.2) THEN
20919 C...Call PDFLIB parton distributions.
20923 VALUE(2)=MSTP(55)/1000
20925 VALUE(3)=MOD(MSTP(55),1000)
20926 IF(MINT(93).NE.3000000+MSTP(55)) THEN
20927 CALL PDFSET(PARM,VALUE)
20928 MINT(93)=3000000+MSTP(55)
20931 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20932 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20933 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20949 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
20952 C...Pion/gammaVDM parton distribution call.
20953 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND.
20954 & MINT(109).EQ.2)) THEN
20955 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
20956 & MSTP(55).LE.12) THEN
20957 ISET=1+MOD(MSTP(55)-1,4)
20960 IF(ISET.GE.3) P2MX=4.0D0
20961 IF(MSTP(57).EQ.0) Q2MX=P2MX
20962 CALL PYGVMD(ISET,2,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20967 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
20968 CALL PYPDPI(X,Q2,XPPI)
20972 ELSEIF(MSTP(54).EQ.2) THEN
20973 C...Call PDFLIB parton distributions.
20977 VALUE(2)=MSTP(53)/1000
20979 VALUE(3)=MOD(MSTP(53),1000)
20980 IF(MINT(93).NE.2000000+MSTP(53)) THEN
20981 CALL PDFSET(PARM,VALUE)
20982 MINT(93)=2000000+MSTP(53)
20985 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20986 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20987 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21003 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
21006 C...Anomalous photon parton distribution call.
21007 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
21010 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
21011 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
21012 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
21013 IF(MSTP(57).EQ.0) Q2MX=P2MX
21014 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
21019 ELSEIF(MSTP(56).EQ.1) THEN
21020 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
21021 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
21022 IF(MSTP(57).EQ.0) Q2MX=P2MX
21023 CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GM,XPGA)
21025 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
21028 ELSEIF(MSTP(56).EQ.2) THEN
21029 IF(MSTP(57).EQ.0) Q2MX=P2MX
21030 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
21035 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
21036 IF(MSTP(57).EQ.0) Q2MX=P2MX
21037 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
21043 210 RKF=11D0*PYR(0)
21045 IF(RKF.GT.1D0) KFR=2
21046 IF(RKF.GT.5D0) KFR=3
21047 IF(RKF.GT.6D0) KFR=4
21048 IF(RKF.GT.10D0) KFR=5
21049 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
21050 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
21051 IF(MSTP(57).EQ.0) Q2MX=P2MX
21052 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
21059 C...Proton parton distribution call.
21061 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.11) THEN
21062 CALL PYPDPR(X,Q2,XPPR)
21066 ELSEIF(MSTP(52).EQ.2) THEN
21067 C...Call PDFLIB parton distributions.
21071 VALUE(2)=MSTP(51)/1000
21073 VALUE(3)=MOD(MSTP(51),1000)
21074 IF(MINT(93).NE.1000000+MSTP(51)) THEN
21075 CALL PDFSET(PARM,VALUE)
21076 MINT(93)=1000000+MSTP(51)
21079 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21080 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21081 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21097 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
21101 C...Isospin average for pi0/gammaVDM.
21102 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
21103 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
21108 XPS=0.5D0*(XPQ(1)+XPQ(-2))
21109 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
21113 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
21114 XPQ(1)=XPQ(1)+0.2D0*XPV
21115 XPQ(-1)=XPQ(-1)+0.2D0*XPV
21116 XPQ(2)=XPQ(2)+0.8D0*XPV
21117 XPQ(-2)=XPQ(-2)+0.8D0*XPV
21118 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
21120 XPQ(-3)=XPQ(-3)+XPV
21121 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
21123 XPQ(-4)=XPQ(-4)+XPV
21124 IF(MSTP(55).GE.9) THEN
21130 XPQ(1)=XPQ(1)+0.5D0*XPV
21131 XPQ(-1)=XPQ(-1)+0.5D0*XPV
21132 XPQ(2)=XPQ(2)+0.5D0*XPV
21133 XPQ(-2)=XPQ(-2)+0.5D0*XPV
21136 C...Rescale for gammaVDM by effective gamma -> rho coupling.
21137 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
21139 XPQ(KFL)=VINT(281)*XPQ(KFL)
21141 VINT(232)=VINT(281)*XPV
21144 C...Isospin conjugation for neutron.
21145 ELSEIF(KFA.EQ.2112) THEN
21153 C...Simple recipes for hyperon (average valence parton distribution).
21154 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
21155 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
21156 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
21157 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
21162 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
21163 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
21164 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
21167 C...Charge conjugation for antiparticle.
21170 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
21177 C...Allow gluon also in position 21.
21180 C...Check positivity and reset above maximum allowed flavour.
21182 XPQ(KFL)=MAX(0D0,XPQ(KFL))
21183 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
21186 C...Formats for error printouts.
21187 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21188 5100 FORMAT(' Error: illegal particle code for parton distribution;',
21190 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
21196 C*********************************************************************
21198 *$ CREATE PYPDFL.FOR
21201 C...Gives proton parton distribution at small x and/or Q^2 according to
21202 C...correct limiting behaviour.
21204 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
21206 C...Double precision and integer declarations.
21207 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21208 INTEGER PYK,PYCHGE,PYCOMP
21210 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21211 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21212 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21213 COMMON/PYINT1/MINT(400),VINT(400)
21214 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21216 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
21217 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
21219 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
21223 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
21224 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
21225 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
21227 CALL PYPDFU(KF,X,Q2,XPQ)
21231 C...Reset. Check x.
21235 IF(X.LE.0D0.OR.X.GE.1D0) THEN
21236 WRITE(MSTU(11),5000) X
21240 C...Define valence content.
21244 IF(KF.EQ.2212) THEN
21247 ELSEIF(KF.EQ.-2212) THEN
21250 ELSEIF(KF.EQ.2112) THEN
21253 ELSEIF(KF.EQ.-2112) THEN
21256 ELSEIF(KF.EQ.211) THEN
21260 ELSEIF(KF.EQ.-211) THEN
21264 ELSEIF(MINT(105).LE.223) THEN
21269 ELSEIF(MINT(105).EQ.333) THEN
21274 ELSEIF(MINT(105).EQ.443) THEN
21281 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
21282 CALL PYPDFU(KFC,X,Q2,XPA)
21283 Q2MN=MAX(3D0,VINT(231))
21284 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
21285 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
21287 C...Large Q2 and large x: naive call is enough.
21288 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
21294 C...Small Q2 and large x: dampen boundary value.
21295 ELSEIF(X.GT.XMN) THEN
21297 C...Evaluate at boundary and define dampening factors.
21298 CALL PYPDFU(KFC,X,Q2MN,XPA)
21299 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
21300 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
21302 C...Separate valence and sea parts of parton distribution.
21304 XFV1=XPA(KFV1)-XPA(-KFV1)
21305 XPA(KFV1)=XPA(-KFV1)
21306 XFV2=XPA(KFV2)-XPA(-KFV2)
21307 XPA(KFV2)=XPA(-KFV2)
21309 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21310 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21311 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21312 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21315 C...Dampen valence and sea separately. Put back together.
21317 XPQ(KFL)=FS*XPA(KFL)
21320 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
21321 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
21323 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
21324 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
21325 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
21326 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
21330 C...Large Q2 and small x: interpolate behaviour.
21331 ELSEIF(Q2.GT.Q2MN) THEN
21333 C...Evaluate at extremes and define coefficients for interpolation.
21334 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21336 CALL PYPDFU(KFC,X,Q2B,XPB)
21338 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
21339 FVA=(X/XMN)**0.45D0*FLA
21340 FSA=(X/XMN)**(-0.08D0)*FLA
21343 C...Separate valence and sea parts of parton distribution.
21345 XFVA1=XPA(KFV1)-XPA(-KFV1)
21346 XPA(KFV1)=XPA(-KFV1)
21347 XFVA2=XPA(KFV2)-XPA(-KFV2)
21348 XPA(KFV2)=XPA(-KFV2)
21349 XFVB1=XPB(KFV1)-XPB(-KFV1)
21350 XPB(KFV1)=XPB(-KFV1)
21351 XFVB2=XPB(KFV2)-XPB(-KFV2)
21352 XPB(KFV2)=XPB(-KFV2)
21354 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
21355 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
21356 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
21357 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
21358 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
21359 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
21360 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
21361 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
21364 C...Interpolate for valence and sea. Put back together.
21366 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
21369 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
21370 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
21372 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21373 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21374 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21375 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21379 C...Small Q2 and small x: dampen boundary value and add term.
21382 C...Evaluate at boundary and define dampening factors.
21383 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21384 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
21386 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
21387 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
21388 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
21389 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
21390 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
21391 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
21393 C...Separate valence and sea parts of parton distribution.
21395 XFV1=XPA(KFV1)-XPA(-KFV1)
21396 XPA(KFV1)=XPA(-KFV1)
21397 XFV2=XPA(KFV2)-XPA(-KFV2)
21398 XPA(KFV2)=XPA(-KFV2)
21400 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21401 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21402 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21403 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21406 C...Dampen valence and sea separately. Add constant terms.
21407 C...Put back together.
21409 XPQ(KFL)=FSA*XPA(KFL)
21413 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
21415 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
21416 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
21419 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
21421 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21422 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21423 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21424 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21430 C...Format for error printout.
21431 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21436 C*********************************************************************
21438 *$ CREATE PYPDEL.FOR
21441 C...Gives electron parton distribution.
21443 SUBROUTINE PYPDEL(X,Q2,XPEL)
21445 C...Double precision and integer declarations.
21446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21447 INTEGER PYK,PYCHGE,PYCOMP
21449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21450 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21451 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21452 COMMON/PYINT1/MINT(400),VINT(400)
21453 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21455 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
21457 C...Interface to PDFLIB.
21458 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
21460 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
21461 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
21462 CHARACTER*20 PARM(20)
21463 DATA VALUE/20*0D0/,PARM/20*' '/
21465 C...Some common constants.
21471 XL=LOG(MAX(1D-10,X))
21472 X1L=LOG(MAX(1D-10,1D0-X))
21473 HLE=LOG(MAX(3D0,Q2/PME**2))
21474 HBE2=(AEM/PARU(1))*(HLE-1D0)
21476 C...Electron inside electron, see R. Kleiss et al., in Z physics at
21477 C...LEP 1, CERN 89-08, p. 34
21478 IF(MSTP(59).LE.1) THEN
21479 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
21480 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
21481 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
21482 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
21483 & 4D0*XL/(1D0-X)-5D0-X)
21485 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
21486 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
21487 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
21489 IF(X.GT.0.9999D0.AND.X.LE.0.999999D0) THEN
21490 HEE=HEE*100D0**HBE2/(100D0**HBE2-1D0)
21491 ELSEIF(X.GT.0.999999D0) THEN
21496 C...Photon and (transverse) W- inside electron.
21497 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
21498 IF(MSTP(13).LE.1) THEN
21501 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
21503 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
21504 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
21505 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
21507 C...Electron or positron inside photon inside electron.
21508 IF(MSTP(12).EQ.1) THEN
21509 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
21510 & 2D0*X*(1D0+X)*XL)
21511 XPEL(11)=XPEL(11)+XFSEA
21514 C...Initialize PDFLIB photon parton distributions.
21515 IF(MSTP(56).EQ.2) THEN
21519 VALUE(2)=MSTP(55)/1000
21521 VALUE(3)=MOD(MSTP(55),1000)
21522 IF(MINT(93).NE.3000000+MSTP(55)) THEN
21523 CALL PDFSET(PARM,VALUE)
21524 MINT(93)=3000000+MSTP(55)
21528 C...Quarks and gluons inside photon inside electron:
21529 C...numerical convolution required.
21538 IF(ITER.EQ.0) NSTP=2
21540 SXP(KFL)=0.5D0*SXP(KFL)
21543 IF(ITER.EQ.0) WTSTP=0.5D0
21544 C...Pick grid of x_{gamma} values logarithmically even.
21549 XLE=XL*(ISTP-0.5D0)/NSTP
21551 XE=MIN(0.999999D0,EXP(XLE))
21552 XG=MIN(0.999999D0,X/XE)
21553 C...Evaluate photon inside electron parton distribution for convolution.
21554 XPGP=1D0+(1D0-XE)**2
21555 IF(MSTP(13).LE.1) THEN
21558 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
21560 C...Evaluate photon parton distributions for convolution.
21561 IF(MSTP(56).EQ.1) THEN
21562 CALL PYPDGA(XG,Q2,XPGA)
21564 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
21566 ELSEIF(MSTP(56).EQ.2) THEN
21567 C...Call PDFLIB parton distributions.
21569 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21570 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21571 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21572 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
21573 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
21574 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
21575 SXP(3)=SXP(3)+WTSTP*XPGP*STR
21576 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
21577 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
21578 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
21581 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
21582 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
21583 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
21585 C...Put convolution into output arrays.
21587 XPEL(0)=FCONV*SXP(0)
21589 XPEL(KFL)=FCONV*SXP(KFL)
21590 XPEL(-KFL)=XPEL(KFL)
21597 C*********************************************************************
21599 *$ CREATE PYPDGA.FOR
21602 C...Gives photon parton distribution.
21604 SUBROUTINE PYPDGA(X,Q2,XPGA)
21606 C...Double precision and integer declarations.
21607 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21608 INTEGER PYK,PYCHGE,PYCOMP
21610 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21611 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21612 COMMON/PYINT1/MINT(400),VINT(400)
21613 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
21615 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
21616 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
21617 &DGCS(4,3),DGDS(4,3),DGES(4,3)
21619 C...The following data lines are coefficients needed in the
21620 C...Drees and Grassie photon parton distribution parametrization.
21621 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
21622 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
21623 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
21624 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
21625 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
21626 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
21627 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
21628 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
21629 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
21630 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
21631 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
21632 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
21633 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
21634 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
21635 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
21636 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
21637 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
21638 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
21639 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
21640 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
21641 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
21642 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
21643 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
21644 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
21645 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
21646 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
21648 C...Photon parton distribution from Drees and Grassie.
21649 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
21654 IF(MSTP(57).LE.0) THEN
21657 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
21661 IF(Q2.GT.25D0) NF=4
21662 IF(Q2.GT.300D0) NF=5
21666 C...Evaluate gluon content.
21667 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
21668 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
21669 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
21670 XPGL=DGA*X**DGB*X1**DGC
21672 C...Evaluate up- and down-type quark content.
21673 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
21674 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
21675 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
21676 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
21677 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
21678 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21679 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
21680 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
21681 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
21682 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
21683 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
21685 IF(NF.EQ.4) DGF=10D0
21686 IF(NF.EQ.5) DGF=55D0/6D0
21687 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21689 XPQU=(XPQS+9D0*XPQN)/6D0
21690 XPQD=(XPQS-4.5D0*XPQN)/6D0
21691 ELSEIF(NF.EQ.4) THEN
21692 XPQU=(XPQS+6D0*XPQN)/8D0
21693 XPQD=(XPQS-6D0*XPQN)/8D0
21695 XPQU=(XPQS+7.5D0*XPQN)/10D0
21696 XPQD=(XPQS-5D0*XPQN)/10D0
21699 C...Put into output arrays.
21704 IF(NF.GE.4) XPGA(4)=AEM*XPQU
21705 IF(NF.GE.5) XPGA(5)=AEM*XPQD
21707 XPGA(-KFL)=XPGA(KFL)
21713 C*********************************************************************
21715 *$ CREATE PYGGAM.FOR
21718 C...Constructs the F2 and parton distributions of the photon
21719 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
21720 C...For F2, c and b are included by the Bethe-Heitler formula;
21721 C...in the 'MSbar' scheme additionally a Cgamma term is added.
21722 C...Contains the SaS sets 1D, 1M, 2D and 2M.
21723 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21725 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
21727 C...Double precision and integer declarations.
21728 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21729 INTEGER PYK,PYCHGE,PYCOMP
21731 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
21733 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
21734 SAVE /PYINT8/,/PYINT9/
21736 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
21737 C...Charm and bottom masses (low to compensate for J/psi etc.).
21738 DATA PMC/1.3D0/, PMB/4.6D0/
21739 C...alpha_em and alpha_em/(2*pi).
21740 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
21741 C...Lambda value for 4 flavours.
21743 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
21745 C...VMD couplings f_V**2/(4*pi).
21746 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
21747 C...Masses for rho (=omega) and phi.
21748 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
21749 C...Number of points in integration for IP2=1.
21767 C...Set Q0 cut-off parameter as function of set used.
21775 C...Scale choice for off-shell photon; common factors.
21780 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21781 FACNOR=LOG(Q2/Q02)/NSTEP
21782 ELSEIF(IP2.EQ.2) THEN
21784 ELSEIF(IP2.EQ.3) THEN
21786 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21787 ELSEIF(IP2.EQ.4) THEN
21788 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21789 & ((Q2+P2)*(Q02+P2)))
21790 ELSEIF(IP2.EQ.5) THEN
21791 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21792 & ((Q2+P2)*(Q02+P2)))
21793 P2MX=Q0*SQRT(P2MXA)
21794 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
21795 ELSEIF(IP2.EQ.6) THEN
21796 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21797 & ((Q2+P2)*(Q02+P2)))
21798 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21800 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21801 & ((Q2+P2)*(Q02+P2)))
21802 P2MX=Q0*SQRT(P2MXA)
21804 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21805 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
21806 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
21809 C...Call VMD parametrization for d quark and use to give rho, omega,
21810 C...phi. Note dipole dampening for off-shell photon.
21811 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21815 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
21816 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
21818 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
21820 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
21821 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
21822 XPVMD(3)=XPVMD(3)+FACS*XFVAL
21823 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
21824 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
21825 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
21826 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
21827 VXPVMD(2)=FRACU*FACUD*XFVAL
21828 VXPVMD(3)=FACS*XFVAL
21829 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
21830 VXPVMD(-2)=FRACU*FACUD*XFVAL
21831 VXPVMD(-3)=FACS*XFVAL
21834 C...Anomalous parametrizations for different strategies
21835 C...for off-shell photons; except full integration.
21837 C...Call anomalous parametrization for d + u + s.
21838 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21840 XPANL(KFL)=FACNOR*XPGA(KFL)
21841 VXPANL(KFL)=FACNOR*VXPGA(KFL)
21844 C...Call anomalous parametrization for c and b.
21845 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21847 XPANH(KFL)=FACNOR*XPGA(KFL)
21848 VXPANH(KFL)=FACNOR*VXPGA(KFL)
21850 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21852 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
21853 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
21857 C...Special option: loop over flavours and integrate over k2.
21859 DO 160 ISTEP=1,NSTEP
21860 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
21861 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
21862 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
21863 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
21864 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
21865 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
21866 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
21868 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
21869 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
21870 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
21871 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
21877 C...Call Bethe-Heitler term expression for charm and bottom.
21878 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
21881 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
21885 C...For MSbar subtraction call C^gamma term expression for d, u, s.
21886 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
21887 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
21889 XPDIR(KFL)=XPGA(KFL)
21893 C...Store result in output array.
21896 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
21897 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
21898 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
21899 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
21900 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
21906 C*********************************************************************
21908 *$ CREATE PYGVMD.FOR
21911 C...Evaluates the VMD parton distributions of a photon,
21912 C...evolved homogeneously from an initial scale P2 to Q2.
21913 C...Does not include dipole suppression factor.
21914 C...ISET is parton distribution set, see above;
21915 C...additionally ISET=0 is used for the evolution of an anomalous photon
21916 C...which branched at a scale P2 and then evolved homogeneously to Q2.
21917 C...ALAM is the 4-flavour Lambda, which is automatically converted
21918 C...to 3- and 5-flavour equivalents as needed.
21919 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21921 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
21923 C...Double precision and integer declarations.
21924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21925 INTEGER PYK,PYCHGE,PYCOMP
21926 C...Local arrays and data.
21927 DIMENSION XPGA(-6:6), VXPGA(-6:6)
21928 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
21937 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
21938 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
21939 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
21940 P2EFF=MAX(P2,1.2D0*ALAM3**2)
21941 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
21942 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
21943 Q2EFF=MAX(Q2,P2EFF)
21945 C...Find number of flavours at lower and upper scale.
21947 IF(P2EFF.LT.PMC**2) NFP=3
21948 IF(P2EFF.GT.PMB**2) NFP=5
21950 IF(Q2EFF.LT.PMC**2) NFQ=3
21951 IF(Q2EFF.GT.PMB**2) NFQ=5
21953 C...Find s as sum of 3-, 4- and 5-flavour parts.
21957 IF(NFQ.EQ.3) Q2DIV=Q2EFF
21958 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
21960 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
21962 IF(NFP.EQ.3) P2DIV=PMC**2
21964 IF(NFQ.EQ.5) Q2DIV=PMB**2
21965 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
21969 IF(NFP.EQ.5) P2DIV=P2EFF
21970 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
21973 C...Calculate frequent combinations of x and s.
21980 C...Evaluate homogeneous anomalous parton distributions below or
21981 C...above threshold.
21983 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21984 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21985 XVAL = X * 1.5D0 * (X**2+X1**2)
21989 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
21990 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
21991 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
21992 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
21993 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
21994 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
21995 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
21996 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
21997 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
21998 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
21999 & (2D0*X-1D0)*X*XL**2)
22002 C...Evaluate set 1D parton distributions below or above threshold.
22003 ELSEIF(ISET.EQ.1) THEN
22004 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22005 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22006 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
22007 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
22008 XSEA = 0.100D0 * X1**3.76D0
22010 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
22011 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
22012 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
22013 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
22014 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
22015 & X**0.40D0 * X1**(1.76D0+3D0*S)
22016 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
22017 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
22018 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
22019 XSEA0 = 0.100D0 * X1**3.76D0
22022 C...Evaluate set 1M parton distributions below or above threshold.
22023 ELSEIF(ISET.EQ.2) THEN
22024 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22025 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22026 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
22027 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
22030 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
22031 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
22032 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
22033 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
22034 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
22035 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
22036 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
22037 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
22042 C...Evaluate set 2D parton distributions below or above threshold.
22043 ELSEIF(ISET.EQ.3) THEN
22044 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22045 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22046 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
22047 XGLU = 1.925D0 * X1**2
22048 XSEA = 0.242D0 * X1**4
22050 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
22051 & X**(0.46D0+0.25D0*S) *
22052 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
22053 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
22054 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
22055 & EXP(-18.67D0*S) *
22056 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
22057 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
22058 & XL**(9.3D0*S/(1D0+1.7D0*S))
22059 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
22060 & (1D0-0.607D0*S+21.95D0*S2) *
22061 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
22062 XSEA0 = 0.242D0 * X1**4
22065 C...Evaluate set 2M parton distributions below or above threshold.
22066 ELSEIF(ISET.EQ.4) THEN
22067 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22068 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22069 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
22070 XGLU = 1.808D0 * X1**2
22071 XSEA = 0.209D0 * X1**4
22073 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
22074 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
22075 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
22076 & XL**(5.15D0*S/(1D0+2D0*S)) +
22077 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
22078 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
22079 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
22080 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
22081 & XL**(10.9D0*S/(1D0+2.5D0*S))
22082 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
22083 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
22084 & X1**(4D0+S) * XL**(0.45D0*S)
22085 XSEA0 = 0.209D0 * X1**4
22089 C...Threshold factors for c and b sea.
22090 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22092 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22093 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22095 XCHM=XSEA*(1D0-(SCH/SLL)**2)
22097 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
22101 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22102 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22104 XBOT=XSEA*(1D0-(SBT/SLL)**2)
22106 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
22110 C...Fill parton distributions.
22117 XPGA(KFA)=XPGA(KFA)+XVAL
22119 XPGA(-KFL)=XPGA(KFL)
22127 C*********************************************************************
22129 *$ CREATE PYGANO.FOR
22132 C...Evaluates the parton distributions of the anomalous photon,
22133 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
22134 C...KF=0 gives the sum over (up to) 5 flavours,
22135 C...KF<0 limits to flavours up to abs(KF),
22136 C...KF>0 is for flavour KF only.
22137 C...ALAM is the 4-flavour Lambda, which is automatically converted
22138 C...to 3- and 5-flavour equivalents as needed.
22139 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22141 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
22143 C...Double precision and integer declarations.
22144 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22145 INTEGER PYK,PYCHGE,PYCOMP
22146 C...Local arrays and data.
22147 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
22148 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
22155 IF(Q2.LE.P2) RETURN
22158 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
22159 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
22161 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
22162 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
22163 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
22164 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
22165 Q2EFF=MAX(Q2,P2EFF)
22168 C...Find number of flavours at lower and upper scale.
22170 IF(P2EFF.LT.PMC**2) NFP=3
22171 IF(P2EFF.GT.PMB**2) NFP=5
22173 IF(Q2EFF.LT.PMC**2) NFQ=3
22174 IF(Q2EFF.GT.PMB**2) NFQ=5
22176 C...Define range of flavour loop.
22180 ELSEIF(KF.LT.0) THEN
22188 C...Loop over flavours the photon can branch into.
22189 DO 110 KFL=KFLMN,KFLMX
22191 C...Light flavours: calculate t range and (approximate) s range.
22192 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
22193 TDIFF=LOG(Q2EFF/P2EFF)
22194 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22195 & LOG(P2EFF/ALAMSQ(NFQ)))
22196 IF(NFQ.GT.NFP) THEN
22198 IF(NFQ.EQ.4) Q2DIV=PMC**2
22199 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22200 & LOG(P2EFF/ALAMSQ(NFQ)))
22201 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22202 & LOG(P2EFF/ALAMSQ(NFQ-1)))
22203 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22205 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
22207 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
22208 & LOG(P2EFF/ALAMSQ(4)))
22209 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
22210 & LOG(P2EFF/ALAMSQ(3)))
22211 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
22214 C...u and s quark do not need a separate treatment when d has been done.
22215 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
22217 C...Charm: as above, but only include range above c threshold.
22218 ELSEIF(KFL.EQ.4) THEN
22219 IF(Q2.LE.PMC**2) GOTO 110
22220 P2EFF=MAX(P2EFF,PMC**2)
22221 Q2EFF=MAX(Q2EFF,P2EFF)
22222 TDIFF=LOG(Q2EFF/P2EFF)
22223 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22224 & LOG(P2EFF/ALAMSQ(NFQ)))
22225 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
22227 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22228 & LOG(P2EFF/ALAMSQ(NFQ)))
22229 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22230 & LOG(P2EFF/ALAMSQ(NFQ-1)))
22231 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22234 C...Bottom: as above, but only include range above b threshold.
22235 ELSEIF(KFL.EQ.5) THEN
22236 IF(Q2.LE.PMB**2) GOTO 110
22237 P2EFF=MAX(P2EFF,PMB**2)
22238 Q2EFF=MAX(Q2,P2EFF)
22239 TDIFF=LOG(Q2EFF/P2EFF)
22240 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22241 & LOG(P2EFF/ALAMSQ(NFQ)))
22244 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
22246 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
22247 FAC=AEM2PI*2D0*CHSQ*TDIFF
22249 C...Evaluate parton distributions (normalized to unit momentum sum).
22250 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
22251 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
22252 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
22253 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
22254 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
22255 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
22256 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
22257 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
22258 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
22259 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
22260 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
22261 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
22263 C...Threshold factors for c and b sea.
22264 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22266 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22267 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22268 XCHM=XSEA*(1D0-(SCH/SLL)**3)
22271 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22272 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22273 XBOT=XSEA*(1D0-(SBT/SLL)**3)
22277 C...Add contribution of each valence flavour.
22278 XPGA(0)=XPGA(0)+FAC*XGLU
22279 XPGA(1)=XPGA(1)+FAC*XSEA
22280 XPGA(2)=XPGA(2)+FAC*XSEA
22281 XPGA(3)=XPGA(3)+FAC*XSEA
22282 XPGA(4)=XPGA(4)+FAC*XCHM
22283 XPGA(5)=XPGA(5)+FAC*XBOT
22284 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
22285 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
22288 XPGA(-KFL)=XPGA(KFL)
22289 VXPGA(-KFL)=VXPGA(KFL)
22295 C*********************************************************************
22297 *$ CREATE PYGBEH.FOR
22300 C...Evaluates the Bethe-Heitler cross section for heavy flavour
22302 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22304 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
22305 C...Double precision and integer declarations.
22306 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22307 INTEGER PYK,PYCHGE,PYCOMP
22310 DATA AEM2PI/0.0011614D0/
22316 C...Check kinematics limits.
22317 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
22319 BETA2=1D0-4D0*PM2/W2
22320 IF(BETA2.LT.1D-10) RETURN
22324 C...Simple case: P2 = 0.
22325 IF(P2.LT.1D-4) THEN
22326 IF(BETA.LT.0.99D0) THEN
22327 XBL=LOG((1D0+BETA)/(1D0-BETA))
22329 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
22331 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
22332 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
22334 C...Complicated case: P2 > 0, based on approximation of
22335 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
22337 RPQ=1D0-4D0*X**2*P2/Q2
22338 IF(RPQ.GT.1D-10) THEN
22339 RPBE=SQRT(RPQ*BETA2)
22340 IF(RPBE.LT.0.99D0) THEN
22341 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
22342 XBI=2D0*RPBE/(1D0-RPBE**2)
22344 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
22345 XBL=LOG((1D0+RPBE)**2/RPBESN)
22346 XBI=2D0*RPBE/RPBESN
22348 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
22349 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
22350 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
22354 C...Multiply by charge-squared etc. to get parton distribution.
22356 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
22357 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
22362 C*********************************************************************
22364 *$ CREATE PYGDIR.FOR
22367 C...Evaluates the direct contribution, i.e. the C^gamma term,
22368 C...as needed in MSbar parametrizations.
22369 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22371 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
22373 C...Double precision and integer declarations.
22374 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22375 INTEGER PYK,PYCHGE,PYCOMP
22376 C...Local array and data.
22377 DIMENSION XPGA(-6:6)
22378 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
22385 C...Evaluate common x-dependent expression.
22386 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
22387 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
22389 C...d, u, s part by simple charge factor.
22390 XPGA(1)=(1D0/9D0)*CGAM
22391 XPGA(2)=(4D0/9D0)*CGAM
22392 XPGA(3)=(1D0/9D0)*CGAM
22394 C...Also fill for antiquarks.
22402 C*********************************************************************
22404 *$ CREATE PYPDPI.FOR
22407 C...Gives pi+ parton distribution according to two different
22408 C...parametrizations.
22410 SUBROUTINE PYPDPI(X,Q2,XPPI)
22412 C...Double precision and integer declarations.
22413 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22414 INTEGER PYK,PYCHGE,PYCOMP
22416 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22417 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22418 COMMON/PYINT1/MINT(400),VINT(400)
22419 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
22421 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
22423 C...The following data lines are coefficients needed in the
22424 C...Owens pion parton distribution parametrizations, see below.
22425 C...Expansion coefficients for up and down valence quark distributions.
22426 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
22427 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22428 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22429 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
22430 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
22431 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22432 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22433 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
22434 C...Expansion coefficients for gluon distribution.
22435 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
22436 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
22437 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
22438 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
22439 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
22440 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
22441 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
22442 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
22443 C...Expansion coefficients for (up+down+strange) quark sea distribution.
22444 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
22445 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
22446 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
22447 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
22448 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
22449 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
22450 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
22451 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
22452 C...Expansion coefficients for charm quark sea distribution.
22453 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
22454 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
22455 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
22456 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
22457 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
22458 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
22459 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
22460 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
22462 C...Euler's beta function, requires ordinary Gamma function
22463 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
22465 C...Reset output array.
22470 IF(MSTP(53).LE.2) THEN
22471 C...Pion parton distributions from Owens.
22472 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
22474 C...Determine set, Lambda and s expansion variable.
22476 IF(NSET.EQ.1) ALAM=0.2D0
22477 IF(NSET.EQ.2) ALAM=0.4D0
22479 IF(MSTP(57).LE.0) THEN
22482 Q2IN=MIN(2D3,MAX(4D0,Q2))
22483 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
22486 C...Calculate parton distributions.
22489 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
22490 & COW(3,IS,KFL,NSET)*SD**2
22493 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
22495 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
22500 C...Put into output array.
22503 XPPI(2)=XQ(1)+XQ(3)/6D0
22506 XPPI(-1)=XQ(1)+XQ(3)/6D0
22511 C...Leading order pion parton distributions from Gluck, Reya and Vogt.
22512 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
22516 C...Determine s expansion variable and some x expressions.
22518 IF(MSTP(57).LE.0) THEN
22521 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
22522 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
22528 C...Evaluate valence, gluon and sea distributions.
22529 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
22530 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
22531 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
22533 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
22534 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
22536 & (1D0-X)**(0.390D0+1.053D0*SD)
22537 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
22539 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
22541 & XL**(2.538D0-0.763D0*SD)
22542 IF(SD.LE.0.888D0) THEN
22545 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
22547 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
22550 IF(SD.LE.1.351D0) THEN
22553 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
22554 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
22558 C...Put into output array.
22566 XPPI(-KFL)=XPPI(KFL)
22568 XPPI(2)=XPPI(2)+XFVAL
22569 XPPI(-1)=XPPI(-1)+XFVAL
22575 C*********************************************************************
22577 *$ CREATE PYPDPR.FOR
22580 C...Gives proton parton distributions according to a few different
22581 C...parametrizations.
22583 SUBROUTINE PYPDPR(X,Q2,XPPR)
22585 C...Double precision and integer declarations.
22586 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22587 INTEGER PYK,PYCHGE,PYCOMP
22589 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22590 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22591 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22592 COMMON/PYINT1/MINT(400),VINT(400)
22593 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
22594 C...Arrays and data.
22595 DIMENSION XPPR(-6:6),Q2MIN(6)
22596 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0/
22598 C...Reset output array.
22603 C...Common preliminaries.
22604 NSET=MAX(1,MIN(6,MSTP(51)))
22605 VINT(231)=Q2MIN(NSET)
22606 IF(MSTP(57).EQ.0) THEN
22609 Q2L=MAX(Q2MIN(NSET),Q2)
22612 IF(NSET.GE.1.AND.NSET.LE.3) THEN
22613 C...Interface to the CTEQ 3 parton distributions.
22614 QRT=SQRT(MAX(1D0,Q2L))
22616 C...Loop over flavours.
22619 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
22620 ELSEIF(I.LE.2) THEN
22621 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
22627 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
22628 C...Interface to the GRV 94 distributions.
22630 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22631 ELSEIF(NSET.EQ.5) THEN
22632 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22634 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22637 C...Put into output array.
22639 XPPR(-1)=0.5D0*(UDB+DEL)
22640 XPPR(-2)=0.5D0*(UDB-DEL)
22644 XPPR(1)=DV+XPPR(-1)
22645 XPPR(2)=UV+XPPR(-2)
22655 C*********************************************************************
22657 *$ CREATE PYCTEQ.FOR
22660 C...Gives the CTEQ 3 parton distribution function sets in
22661 C...parametrized form, of October 24, 1994.
22662 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
22663 C...J. Qiu, W.K. Tung and H. Weerts.
22665 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
22667 C...Double precision declaration.
22668 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22670 C...Data on Lambda values of fits, minimum Q and quark masses.
22671 DIMENSION ALM(3), QMS(4:6)
22672 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
22673 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
22675 C....Check flavour thresholds. Set up QI for SB.
22678 IF(Q .LE. QMS(IP)) THEN
22687 C...Use "standard lambda" of parametrization program for expansion.
22689 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
22694 C...Expansion for CTEQ3L.
22695 IF(ISET .EQ. 1) THEN
22696 IF(IPRT .EQ. 2) THEN
22697 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
22699 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
22700 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
22701 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
22702 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
22703 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
22704 ELSEIF(IPRT .EQ. 1) THEN
22705 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
22707 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
22708 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
22709 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
22710 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
22711 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
22712 ELSEIF(IPRT .EQ. 0) THEN
22713 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
22715 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
22716 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
22717 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
22718 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
22719 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
22720 ELSEIF(IPRT .EQ. -1) THEN
22721 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
22723 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
22724 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
22725 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
22726 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
22727 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
22728 ELSEIF(IPRT .EQ. -2) THEN
22729 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
22731 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
22732 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
22733 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
22734 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
22735 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
22736 ELSEIF(IPRT .EQ. -3) THEN
22737 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
22739 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
22740 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
22741 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
22742 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
22743 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
22744 ELSEIF(IPRT .EQ. -4) THEN
22745 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
22747 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
22748 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
22749 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
22750 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
22751 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
22752 ELSEIF(IPRT .EQ. -5) THEN
22753 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
22755 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
22756 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
22757 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
22758 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
22759 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
22760 ELSEIF(IPRT .EQ. -6) THEN
22761 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
22763 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
22764 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
22765 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
22766 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
22767 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
22770 C...Expansion for CTEQ3M.
22771 ELSEIF(ISET .EQ. 2) THEN
22772 IF(IPRT .EQ. 2) THEN
22773 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
22775 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
22776 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
22777 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
22778 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
22779 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
22780 ELSEIF(IPRT .EQ. 1) THEN
22781 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
22783 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
22784 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
22785 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
22786 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
22787 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
22788 ELSEIF(IPRT .EQ. 0) THEN
22789 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
22791 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
22792 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
22793 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
22794 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
22795 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
22796 ELSEIF(IPRT .EQ. -1) THEN
22797 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
22799 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
22800 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
22801 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
22802 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
22803 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
22804 ELSEIF(IPRT .EQ. -2) THEN
22805 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
22807 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
22808 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
22809 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
22810 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
22811 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
22812 ELSEIF(IPRT .EQ. -3) THEN
22813 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
22815 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
22816 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
22817 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
22818 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
22819 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
22820 ELSEIF(IPRT .EQ. -4) THEN
22821 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
22823 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
22824 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
22825 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
22826 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
22827 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
22828 ELSEIF(IPRT .EQ. -5) THEN
22829 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
22831 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
22832 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
22833 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
22834 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
22835 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
22836 ELSEIF(IPRT .EQ. -6) THEN
22837 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
22839 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
22840 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
22841 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
22842 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
22843 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
22846 C...Expansion for CTEQ3D.
22847 ELSEIF(ISET .EQ. 3) THEN
22848 IF(IPRT .EQ. 2) THEN
22849 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
22851 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
22852 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
22853 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
22854 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
22855 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
22856 ELSEIF(IPRT .EQ. 1) THEN
22857 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
22859 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
22860 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
22861 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
22862 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
22863 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
22864 ELSEIF(IPRT .EQ. 0) THEN
22865 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
22867 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
22868 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
22869 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
22870 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
22871 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
22872 ELSEIF(IPRT .EQ. -1) THEN
22873 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
22875 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
22876 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
22877 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
22878 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
22879 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
22880 ELSEIF(IPRT .EQ. -2) THEN
22881 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
22883 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
22884 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
22885 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
22886 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
22887 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
22888 ELSEIF(IPRT .EQ. -3) THEN
22889 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
22891 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
22892 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
22893 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
22894 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
22895 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
22896 ELSEIF(IPRT .EQ. -4) THEN
22897 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
22899 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
22900 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
22901 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
22902 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
22903 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
22904 ELSEIF(IPRT .EQ. -5) THEN
22905 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
22907 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
22908 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
22909 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
22910 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
22911 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
22912 ELSEIF(IPRT .EQ. -6) THEN
22913 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
22915 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
22916 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
22917 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
22918 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
22919 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
22923 C...Calculation of x * f(x, Q).
22924 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
22925 & *(LOG(1D0+1D0/X))**A5 )
22930 C*********************************************************************
22932 *$ CREATE PYGRVL.FOR
22935 C...Gives the GRV 94 L (leading order) parton distribution function set
22936 C...in parametrized form.
22937 C...Authors: M. Glueck, E. Reya and A. Vogt.
22939 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22941 C...Double precision declaration.
22942 IMPLICIT DOUBLE PRECISION (A - Z)
22944 C...Common expressions.
22946 LAM2 = 0.2322D0 * 0.2322D0
22947 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
22953 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
22954 AKU = 0.590D0 - 0.024D0 * S
22955 BKU = 0.131D0 + 0.063D0 * S
22956 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
22957 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
22958 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
22959 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
22960 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
22963 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
22965 BKD = 0.486D0 + 0.062D0 * S
22966 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
22967 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
22968 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
22969 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
22970 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
22973 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
22974 AKE = 0.409D0 - 0.005D0 * S
22975 BKE = 0.799D0 + 0.071D0 * S
22976 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
22977 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
22979 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
22980 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
22985 AKX = 0.410D0 - 0.232D0 * S
22986 BKX = 0.534D0 - 0.457D0 * S
22987 AGX = 0.890D0 - 0.140D0 * S
22989 CX = 0.320D0 + 0.683D0 * S
22990 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
22991 EX = 4.119D0 + 1.713D0 * S
22992 ESX = 0.682D0 + 2.978D0 * S
22993 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23000 AKS = 1.798D0 - 0.596D0 * S
23001 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
23002 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
23003 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
23004 EST = 3.981D0 + 1.638D0 * S
23006 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23014 BC = 4.24D0 - 0.804D0 * S
23015 DCT = 3.46D0 - 1.076D0 * S
23016 ECT = 4.61D0 + 1.49D0 * S
23017 ESC = 2.555D0 + 1.961D0 * S
23018 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23027 DBT = 2.929D0 + 1.396D0 * S
23028 EBT = 4.71D0 + 1.514D0 * S
23029 ESB = 4.02D0 + 1.239D0 * S
23030 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23035 AKG = 1.742D0 - 0.930D0 * S
23036 BKG = - 0.399D0 * S2
23037 AG = 7.486D0 - 2.185D0 * S
23038 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
23039 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
23040 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
23041 EG = 0.807D0 + 2.005D0 * S
23042 ESG = 3.841D0 + 0.316D0 * S
23043 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
23049 C*********************************************************************
23051 *$ CREATE PYGRVM.FOR
23054 C...Gives the GRV 94 M (MSbar) parton distribution function set
23055 C...in parametrized form.
23056 C...Authors: M. Glueck, E. Reya and A. Vogt.
23058 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
23060 C...Double precision declaration.
23061 IMPLICIT DOUBLE PRECISION (A - Z)
23063 C...Common expressions.
23065 LAM2 = 0.248D0 * 0.248D0
23066 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
23072 NU = 1.304D0 + 0.863D0 * S
23073 AKU = 0.558D0 - 0.020D0 * S
23075 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
23076 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
23077 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
23078 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
23079 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
23082 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
23083 AKD = 0.270D0 - 0.019D0 * S
23085 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
23086 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
23087 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
23088 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
23089 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23092 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
23093 AKE = 0.409D0 - 0.007D0 * S
23094 BKE = 0.782D0 + 0.082D0 * S
23095 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
23096 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
23098 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
23099 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23107 BGX = 3.210D0 - 1.866D0 * S
23109 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
23110 EX = 3.077D0 + 1.446D0 * S
23111 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
23112 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23119 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
23120 AS = -4.329D0 + 1.131D0 * S
23121 BS = 9.568D0 - 1.744D0 * S
23122 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
23123 EST = 3.031D0 + 1.639D0 * S
23124 ESS = 5.837D0 + 0.815D0 * S
23125 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23131 AKC = -0.625D0 - 0.523D0 * S
23133 BC = 1.896D0 + 1.616D0 * S
23134 DCT = 4.12D0 + 0.683D0 * S
23135 ECT = 4.36D0 + 1.328D0 * S
23136 ESC = 0.677D0 + 0.679D0 * S
23137 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23143 AKB = - 0.193D0 * S
23146 DBT = 3.447D0 + 0.927D0 * S
23147 EBT = 4.68D0 + 1.259D0 * S
23148 ESB = 1.892D0 + 2.199D0 * S
23149 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23154 AKG = 1.724D0 + 0.157D0 * S
23155 BKG = 0.800D0 + 1.016D0 * S
23156 AG = 7.517D0 - 2.547D0 * S
23157 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
23158 CG = 4.039D0 + 1.491D0 * S
23159 DG = 3.404D0 + 0.830D0 * S
23160 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
23161 ESG = 3.256D0 - 0.436D0 * S
23162 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23167 C*********************************************************************
23169 *$ CREATE PYGRVD.FOR
23172 C...Gives the GRV 94 D (DIS) parton distribution function set
23173 C...in parametrized form.
23174 C...Authors: M. Glueck, E. Reya and A. Vogt.
23176 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
23178 C...Double precision declaration.
23179 IMPLICIT DOUBLE PRECISION (A - Z)
23181 C...Common expressions.
23183 LAM2 = 0.248D0 * 0.248D0
23184 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
23190 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
23191 AKU = 0.563D0 - 0.025D0 * S
23192 BKU = 0.054D0 + 0.154D0 * S
23193 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
23194 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
23195 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
23196 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
23197 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
23200 ND = 0.156D0 - 0.017D0 * S
23201 AKD = 0.299D0 - 0.022D0 * S
23202 BKD = 0.259D0 - 0.015D0 * S
23203 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
23204 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
23205 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
23206 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
23207 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23210 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
23211 AKE = 0.419D0 - 0.013D0 * S
23212 BKE = 1.064D0 - 0.038D0 * S
23213 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
23214 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
23215 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
23216 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
23217 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23222 AKX = 0.326D0 + 0.150D0 * S
23223 BKX = 0.956D0 + 0.405D0 * S
23225 BGX = 3.794D0 - 2.359D0 * DS
23227 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
23228 EX = 3.049D0 + 1.597D0 * S
23229 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
23230 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23237 AKS = 1.415D0 - 0.641D0 * DS
23238 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
23239 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
23240 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
23241 EST = 4.546D0 + 0.372D0 * S2
23242 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
23243 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23249 AKC = -0.625D0 - 0.523D0 * S
23251 BC = 1.896D0 + 1.616D0 * S
23252 DCT = 4.12D0 + 0.683D0 * S
23253 ECT = 4.36D0 + 1.328D0 * S
23254 ESC = 0.677D0 + 0.679D0 * S
23255 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23261 AKB = - 0.193D0 * S
23264 DBT = 3.447D0 + 0.927D0 * S
23265 EBT = 4.68D0 + 1.259D0 * S
23266 ESB = 1.892D0 + 2.199D0 * S
23267 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23273 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
23274 AG = 25.09D0 - 7.935D0 * S
23275 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
23276 CG = 590.3D0 - 173.8D0 * S
23277 DG = 5.196D0 + 1.857D0 * S
23278 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
23279 ESG = 3.232D0 - 0.542D0 * S
23280 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23285 C*********************************************************************
23287 *$ CREATE PYGRVV.FOR
23290 C...Auxiliary for the GRV 94 parton distribution functions
23291 C...for u and d valence and d-u sea.
23292 C...Authors: M. Glueck, E. Reya and A. Vogt.
23294 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
23296 C...Double precision declaration.
23297 IMPLICIT DOUBLE PRECISION (A - Z)
23301 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
23307 C*********************************************************************
23309 *$ CREATE PYGRVW.FOR
23312 C...Auxiliary for the GRV 94 parton distribution functions
23313 C...for d+u sea and gluon.
23314 C...Authors: M. Glueck, E. Reya and A. Vogt.
23316 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
23318 C...Double precision declaration.
23319 IMPLICIT DOUBLE PRECISION (A - Z)
23323 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
23324 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
23329 C*********************************************************************
23331 *$ CREATE PYGRVS.FOR
23334 C...Auxiliary for the GRV 94 parton distribution functions
23335 C...for s, c and b sea.
23336 C...Authors: M. Glueck, E. Reya and A. Vogt.
23338 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
23340 C...Double precision declaration.
23341 IMPLICIT DOUBLE PRECISION (A - Z)
23349 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
23350 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
23356 C*********************************************************************
23358 *$ CREATE PYHFTH.FOR
23361 C...Gives threshold attractive/repulsive factor for heavy flavour
23364 FUNCTION PYHFTH(SH,SQM,FRATT)
23366 C...Double precision and integer declarations.
23367 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23368 INTEGER PYK,PYCHGE,PYCOMP
23370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23371 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23372 COMMON/PYINT1/MINT(400),VINT(400)
23373 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23375 C...Value for alpha_strong.
23376 IF(MSTP(35).LE.1) THEN
23381 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
23387 C...Evaluate attractive and repulsive factors.
23388 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23389 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
23390 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23391 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
23392 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
23398 C*********************************************************************
23400 *$ CREATE PYSPLI.FOR
23403 C...Splits a hadron remnant into two (partons or hadron + parton)
23404 C...in case it is more complicated than just a quark or a diquark.
23406 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
23408 C...Double precision and integer declarations.
23409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23410 INTEGER PYK,PYCHGE,PYCOMP
23412 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23413 COMMON/PYINT1/MINT(400),VINT(400)
23414 SAVE /PYPARS/,/PYINT1/
23418 C...Preliminaries. Parton composition.
23421 KFL(1)=MOD(KFA/1000,10)
23422 KFL(2)=MOD(KFA/100,10)
23423 KFL(3)=MOD(KFA/10,10)
23424 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
23425 KFL(2)=INT(1.5D0+PYR(0))
23426 IF(MINT(105).EQ.333) KFL(2)=3
23427 IF(MINT(105).EQ.443) KFL(2)=4
23429 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
23432 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
23436 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
23443 C...Subdivide lepton.
23444 IF(KFA.GE.11.AND.KFA.LE.18) THEN
23445 IF(KFLR.EQ.KFA) THEN
23447 ELSEIF(KFLR.EQ.22) THEN
23449 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
23451 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
23453 ELSEIF(KFLR.EQ.21) THEN
23461 C...Subdivide photon.
23462 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
23463 IF(KFLR.NE.21) THEN
23468 IF(RAGR.GT.0.125D0) KFLSP=2
23469 IF(RAGR.GT.0.625D0) KFLSP=3
23470 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
23474 C...Subdivide Reggeon or Pomeron.
23475 ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
23476 IF(KFLIN.EQ.21) THEN
23482 C...Subdivide meson.
23483 ELSEIF(KFL(1).EQ.0) THEN
23484 KFL(2)=KFL(2)*(-1)**KFL(2)
23485 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
23486 IF(KFLR.EQ.KFL(2)) THEN
23488 ELSEIF(KFLR.EQ.KFL(3)) THEN
23490 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
23493 ELSEIF(KFLR.EQ.21) THEN
23496 ELSEIF(KFLR*KFL(2).GT.0) THEN
23497 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
23500 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
23504 C...Subdivide baryon.
23508 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
23511 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
23514 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
23515 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
23518 IAGR=1.00001D0+2.99998D0*PYR(0)
23521 IF(IAGR.EQ.1) ID1=2
23522 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
23525 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
23526 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
23527 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
23528 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
23529 ELSEIF(MOD(KFA,10).EQ.2) THEN
23530 IF(IAGR.EQ.1) KSP=1
23531 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
23533 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
23534 IF(KFLR.EQ.21) THEN
23536 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
23537 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
23538 ELSEIF(NAGR.EQ.0) THEN
23539 CALL PYKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
23544 C...Add on correct sign for result.
23551 C*********************************************************************
23553 *$ CREATE PYGAMM.FOR
23556 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
23557 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
23558 C...(Dover, 1965) 6.1.36.
23562 C...Double precision and integer declarations.
23563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23564 INTEGER PYK,PYCHGE,PYCOMP
23565 C...Local array and data.
23567 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
23568 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
23577 PYGAMM=PYGAMM+B(I)*DXP
23583 PYGAMM=(X-IX)*PYGAMM
23590 C***********************************************************************
23592 *$ CREATE PYWAUX.FOR
23595 C...Calculates real and imaginary parts of the auxiliary functions W1
23596 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
23597 C...der Bij, Nucl. Phys. B297 (1988) 221.
23599 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
23601 C...Double precision and integer declarations.
23602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23603 INTEGER PYK,PYCHGE,PYCOMP
23605 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23608 ASINH(X)=LOG(X+SQRT(X**2+1D0))
23609 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
23611 IF(EPS.LT.0D0) THEN
23612 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
23613 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
23615 ELSEIF(EPS.LT.1D0) THEN
23616 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
23617 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
23618 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
23619 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
23621 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
23622 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
23629 C***********************************************************************
23631 *$ CREATE PYI3AU.FOR
23634 C...Calculates real and imaginary parts of the auxiliary function I3;
23635 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
23636 C...Nucl. Phys. B297 (1988) 221.
23638 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
23640 C...Double precision and integer declarations.
23641 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23642 INTEGER PYK,PYCHGE,PYCOMP
23644 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23647 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
23648 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
23650 IF(EPS.LT.0D0) THEN
23651 IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23652 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23653 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23654 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
23655 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
23656 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
23657 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
23658 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
23660 ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23661 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23662 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23663 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
23664 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
23665 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
23666 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
23667 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
23668 ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23669 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23670 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23671 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
23672 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
23673 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
23674 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
23675 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
23677 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23678 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
23679 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
23680 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
23681 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
23684 ELSEIF(EPS.LT.1D0) THEN
23685 IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23686 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23687 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23688 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
23689 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
23690 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23691 & (0.25D0*(RAT+1D0)*EPS))
23692 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23693 & (0.25D0*(RAT+1D0)*EPS))
23694 ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23695 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23696 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23697 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
23698 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
23699 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
23700 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23701 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23702 ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23703 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23704 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23705 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
23706 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
23707 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
23708 & (1D0+0.25D0*RAT*EPS-GA))
23709 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
23710 & (1D0+0.25D0*RAT*EPS-GA))
23712 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23713 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
23714 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
23715 & LOG((GA+BE-1D0)/(BE-GA))
23716 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
23719 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
23720 RCTHE=RSQ*(1D0-2D0*BE/EPS)
23721 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
23722 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
23723 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
23725 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
23726 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
23727 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
23728 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
23729 & (PHI-THE)*(PHI+THE-PARU(1))
23730 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
23731 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
23734 Y3RE=2D0/(2D0*BE-1D0)*F3RE
23735 Y3IM=2D0/(2D0*BE-1D0)*F3IM
23740 C***********************************************************************
23742 *$ CREATE PYSPEN.FOR
23745 C...Calculates real and imaginary part of Spence function; see
23746 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
23748 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
23750 C...Double precision and integer declarations.
23751 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23752 INTEGER PYK,PYCHGE,PYCOMP
23754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23756 C...Local array and data.
23759 &1.000000D+00, -5.000000D-01, 1.666667D-01,
23760 &0.000000D+00, -3.333333D-02, 0.000000D+00,
23761 &2.380952D-02, 0.000000D+00, -3.333333D-02,
23762 &0.000000D+00, 7.575757D-02, 0.000000D+00,
23763 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
23767 IF(ABS(1D0-XRE).LT.1.D-6.AND.ABS(XIM).LT.1.D-6) THEN
23768 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
23769 IF(IREIM.EQ.2) PYSPEN=0D0
23773 XMOD=SQRT(XRE**2+XIM**2)
23774 IF(XMOD.LT.1.D-6) THEN
23775 IF(IREIM.EQ.1) PYSPEN=0D0
23776 IF(IREIM.EQ.2) PYSPEN=0D0
23780 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23784 IF(XMOD.GT.1D0) THEN
23786 ALGXIM=XARG-SIGN(PARU(1),XARG)
23787 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
23788 SP0IM=-ALGXRE*ALGXIM
23795 IF(XRE.GT.0.5D0) THEN
23800 XMOD=SQRT(XRE**2+XIM**2)
23801 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23804 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
23805 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
23811 XMOD=SQRT(XRE**2+XIM**2)
23812 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23821 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
23822 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
23823 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
23826 SPRE=SPRE+B(I)*TERMRE
23827 SPIM=SPIM+B(I)*TERMIM
23830 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
23831 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
23836 C***********************************************************************
23838 *$ CREATE PYQQBH.FOR
23841 C...Calculates the matrix element for the processes
23842 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
23843 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
23844 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
23846 SUBROUTINE PYQQBH(WTQQBH)
23848 C...Double precision and integer declarations.
23849 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23850 INTEGER PYK,PYCHGE,PYCOMP
23852 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23853 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23854 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23855 COMMON/PYINT1/MINT(400),VINT(400)
23856 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23857 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
23858 C...Local arrays and function.
23859 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
23860 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
23863 C...Mass parameters.
23866 SHPR=SQRT(VINT(26))*VINT(1)
23867 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
23868 PH=SQRT(VINT(21))*VINT(1)
23872 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
23874 PT=SQRT(MAX(0D0,VINT(197+5*I)))
23875 PP(I,1)=PT*COS(VINT(198+5*I))
23876 PP(I,2)=PT*SIN(VINT(198+5*I))
23878 PP(3,1)=-PP(1,1)-PP(2,1)
23879 PP(3,2)=-PP(1,2)-PP(2,2)
23880 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
23881 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
23882 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
23884 PP(3,3)=PMT3*SINH(VINT(211))
23885 PP(3,4)=PMT3*COSH(VINT(211))
23886 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
23887 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
23888 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
23889 PP(2,3)=-PP(1,3)-PP(3,3)
23890 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
23891 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
23893 C...Set up incoming kinematics and derived momentum combinations.
23897 PP(I,3)=-0.5D0*SHPR*(-1)**I
23898 PP(I,4)=-0.5D0*SHPR
23901 PP(6,J)=PP(1,J)+PP(2,J)
23902 PP(7,J)=PP(1,J)+PP(3,J)
23903 PP(8,J)=PP(1,J)+PP(4,J)
23904 PP(9,J)=PP(1,J)+PP(5,J)
23905 PP(10,J)=-PP(2,J)-PP(3,J)
23906 PP(11,J)=-PP(2,J)-PP(4,J)
23907 PP(12,J)=-PP(2,J)-PP(5,J)
23908 PP(13,J)=-PP(4,J)-PP(5,J)
23911 C...Derived kinematics invariants.
23940 C...Define colour coefficients for g + g -> Q + Qbar + H.
23941 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
23945 CLR(I+3,J+3)=16D0/3D0
23946 CLR(I,J+3)=-2D0/3D0
23947 CLR(I+3,J)=-2D0/3D0
23960 CLR(6+K1,6+K2)=12D0
23964 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
23965 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
23966 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
23967 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
23968 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
23969 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
23970 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
23972 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
23973 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
23974 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
23975 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
23976 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
23977 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
23978 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
23979 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
23980 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
23981 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
23982 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
23983 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
23984 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
23985 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
23986 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
23987 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
23988 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
23989 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
23991 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
23992 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
23993 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
23994 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
23995 & +X4*X9*X5+X4*X5**2)
23996 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
23997 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
23998 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
23999 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
24000 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
24001 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
24002 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
24003 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
24004 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
24005 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
24006 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
24007 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
24008 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
24009 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
24010 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
24011 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
24012 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
24013 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
24014 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
24015 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
24017 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
24018 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
24019 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
24020 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
24021 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
24022 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
24023 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
24025 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
24026 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
24027 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
24028 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
24029 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
24030 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
24032 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
24033 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
24034 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
24035 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
24036 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
24037 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
24038 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
24040 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
24041 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
24042 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
24043 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
24044 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
24045 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
24046 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
24047 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
24048 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
24049 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
24050 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
24051 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
24052 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
24053 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
24054 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
24055 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
24056 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
24057 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
24058 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
24059 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
24060 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
24061 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
24062 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
24063 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
24064 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
24065 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
24066 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
24067 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
24068 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
24069 & +X3*X8*X5+X3*X5**2)
24070 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
24071 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
24072 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
24073 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
24074 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
24075 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
24076 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
24078 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
24079 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
24080 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
24081 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
24082 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
24083 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
24084 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
24085 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
24086 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
24087 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
24088 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
24089 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
24090 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
24091 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
24092 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
24093 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
24094 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
24095 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
24096 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
24097 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
24098 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
24099 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
24100 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
24101 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
24102 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
24103 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
24105 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
24106 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
24107 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
24108 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
24109 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
24110 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
24111 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
24112 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
24113 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
24114 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
24115 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
24116 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
24117 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
24118 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
24119 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
24120 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
24121 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
24122 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
24123 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
24124 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
24125 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
24126 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
24127 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
24128 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
24129 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
24130 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
24132 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24133 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24134 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
24135 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
24136 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
24137 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
24138 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
24139 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
24140 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
24141 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
24142 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
24143 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24144 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24145 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
24146 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
24147 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
24148 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
24149 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
24150 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
24151 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
24152 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
24153 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
24154 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
24155 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
24156 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
24157 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
24158 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
24159 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
24160 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
24161 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
24162 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
24163 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
24164 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
24165 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
24166 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
24167 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
24168 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
24169 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
24170 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
24171 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
24172 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
24173 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
24174 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
24175 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
24177 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
24178 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
24179 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
24180 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
24181 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
24182 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
24183 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
24184 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
24185 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
24186 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
24187 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
24189 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24190 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
24191 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
24192 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24193 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
24194 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
24196 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24197 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
24198 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
24200 FM(9,10)=0.5D0*(FMXX+FM(9,10))
24201 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24202 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
24203 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
24205 C...Repackage matrix elements.
24211 RM(7,7)=FM(7,7)-2D0*FM(9,9)
24212 RM(7,8)=FM(7,8)-2D0*FM(9,10)
24213 RM(8,8)=FM(8,8)-2D0*FM(10,10)
24215 C...Produce final result: matrix elements * colours * propagators.
24220 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
24223 WTQQBH=-WTQQBH/256D0
24226 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
24227 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
24228 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
24230 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
24231 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
24232 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
24234 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
24235 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
24238 C...Produce final result: matrix elements * propagators.
24240 A12=A12/(DX(7)*DX(8))
24242 WTQQBH=-(A11+A22+2D0*A12)/8D0
24248 C*********************************************************************
24250 *$ CREATE PYMSIN.FOR
24253 C...Initializes supersymmetry: finds sparticle masses and
24254 C...branching ratios and stores this information.
24255 C...AUTHOR: STEPHEN MRENNA
24259 C...Double precision and integer declarations.
24260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24261 INTEGER PYK,PYCHGE,PYCOMP
24262 C...Parameter statement to help give large particle numbers.
24263 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24267 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
24268 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24269 COMMON/PYINT4/MWID(500),WIDS(500,5)
24270 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24271 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24273 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
24276 C...Local variables.
24278 DOUBLE PRECISION ALFA,BETA
24279 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
24280 DOUBLE PRECISION PYALEM
24281 INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
24282 INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
24283 DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
24284 DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
24285 DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
24286 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
24287 DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
24288 DOUBLE PRECISION DELM,XMDIF,BRLIM
24289 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
24290 DOUBLE PRECISION ARG,SGNMU,R,GAM
24291 INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
24292 INTEGER IMSSM,KFHIGG
24296 &1000001,2000001,1000002,2000002,1000003,2000003,
24297 &1000004,2000004,1000005,2000005,1000006,2000006,
24298 &1000011,2000011,1000012,2000012,1000013,2000013,
24299 &1000014,2000014,1000015,2000015,1000016,2000016,
24300 &1000021,1000022,1000023,1000025,1000035,1000024,
24301 &1000037,1000039, 25, 35, 36, 37/
24303 C...Do nothing if SUSY not requested.
24305 IF(IMSSM.EQ.0) RETURN
24307 C...First part of routine: set masses and couplings.
24309 C...Reset mixing values in sfermion sector to pure left/right.
24317 C...Common couplings.
24322 COS2B=COS(2D0*BETA)
24328 C...Define sparticle masses for a general MSSM simulation.
24329 IF(IMSSM.EQ.1) THEN
24330 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
24332 KC=PYCOMP(KSUSY1+I)
24333 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
24334 KC=PYCOMP(KSUSY2+I)
24335 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
24336 KC=PYCOMP(KSUSY1+I+1)
24337 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
24338 KC=PYCOMP(KSUSY2+I+1)
24339 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
24341 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
24342 IF(XARG.LT.0D0) THEN
24343 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24344 & ' FROM THE SUM RULE. '
24345 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24351 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
24352 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
24353 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24354 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24356 IF(IMSS(8).EQ.1) THEN
24361 C...Alternatively derive masses from SUGRA relations.
24362 ELSEIF(IMSSM.EQ.2) THEN
24366 C...Add in extra D-term contributions.
24367 IF(IMSS(7).EQ.1) THEN
24372 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24373 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
24374 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
24375 WRITE(MSTU(11),*) 'C DX = ',DX
24376 WRITE(MSTU(11),*) 'C DY = ',DY
24377 WRITE(MSTU(11),*) 'C DS = ',DS
24378 WRITE(MSTU(11),*) 'C '
24379 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
24380 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
24381 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24382 DQ2=DY/6D0-DX/3D0-DS/3D0
24383 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
24384 DD2=DY/3D0+DX-2D0*DS/3D0
24385 DL2=-DY/2D0+DX-2D0*DS/3D0
24386 DE2=DY-DX/3D0-DS/3D0
24387 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
24388 DHD2=-DY/2D0-2D0*DX/3D0+DS
24389 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
24391 DMA2 = 2D0*DMU2+DHU2+DHD2
24393 KC=PYCOMP(KSUSY1+I)
24394 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24395 KC=PYCOMP(KSUSY2+I)
24396 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
24397 KC=PYCOMP(KSUSY1+I+1)
24398 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24399 KC=PYCOMP(KSUSY2+I+1)
24400 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
24403 KC=PYCOMP(KSUSY1+I)
24404 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24405 KC=PYCOMP(KSUSY2+I)
24406 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
24407 KC=PYCOMP(KSUSY1+I+1)
24408 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24410 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
24411 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
24414 SGNMU=SIGN(1D0,RMSS(4))
24415 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
24416 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
24417 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
24418 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
24419 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
24420 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
24421 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
24422 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
24423 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
24424 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
24425 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
24426 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
24427 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
24430 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
24431 RMSS(6)=SQRT(RMSS(6)**2+DL2)
24432 RMSS(7)=SQRT(RMSS(7)**2+DE2)
24433 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
24434 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
24435 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
24436 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
24437 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
24440 C...Fix the third generation sfermions.
24442 XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
24443 IF(XARG.LT.0D0) THEN
24444 WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
24445 & ' THE SUM RULE. '
24446 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24449 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
24452 C...Fix the neutralino--chargino--gluino sector.
24455 C...Fix the Higgs sector.
24458 C...Choose the Gunion-Haber convention.
24462 C...Print information on mass parameters.
24463 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
24464 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24465 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
24466 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
24467 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
24468 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
24469 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
24470 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
24471 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
24472 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
24473 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24475 IF(IMSS(20).EQ.1) THEN
24476 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24477 WRITE(MSTU(11),*) ' DEBUG MODE '
24478 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
24479 & UMIX(2,1),UMIX(2,2)
24480 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
24481 & VMIX(2,1),VMIX(2,2)
24482 WRITE(MSTU(11),*) ' ZMIX = ',ZMIX
24483 WRITE(MSTU(11),*) ' ALFA = ',ALFA
24484 WRITE(MSTU(11),*) ' BETA = ',BETA
24485 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
24486 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
24487 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24490 C...Set up the Higgs couplings - needed here since initialization
24491 C...in PYINRE did not yet occur when PYWIDT is called below.
24498 C...tanb (used for H+)
24502 C...Coupling to d-type quarks
24503 PARU(161)=SINA/COSB
24504 C...Coupling to u-type quarks
24505 PARU(162)=-COSA/SINB
24506 C...Coupling to leptons
24507 PARU(163)=PARU(161)
24509 PARU(164)=SIN(BE-AL)
24511 PARU(165)=PARU(164)
24513 PARU(168)=-SIN(BE-AL)-COS(2D0*BE)*SIN(BE+AL)/2D0/(1D0-XW)
24516 C...Coupling to d-type quarks
24517 PARU(171)=-COSA/COSB
24518 C...Coupling to u-type quarks
24519 PARU(172)=-SINA/SINB
24520 C...Coupling to leptons
24521 PARU(173)=PARU(171)
24523 PARU(174)=COS(BE-AL)
24525 PARU(175)=PARU(174)
24527 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
24529 PARU(177)=COS(2D0*BE)*COS(BE+AL)
24531 PARU(178)=-COS(BE-AL)+COS(2D0*BE)*COS(BE+AL)/2D0/(1D0-XW)
24534 C...Coupling to d-type quarks
24536 C...Coupling to u-type quarks
24537 PARU(182)=1D0/PARU(181)
24538 C...Coupling to leptons
24539 PARU(183)=PARU(181)
24542 C...Coupling to Z h
24543 PARU(186)=COS(BE-AL)
24544 C...Coupling to Z H
24545 PARU(187)=SIN(BE-AL)
24551 C...Coupling to W h
24552 PARU(195)=COS(BE-AL)
24554 C...Tell that all Higgs couplings have been set.
24557 C...Second part of routine: set decay modes and branching ratios.
24559 C...Allow chi10 -> gravitino + gamma or not.
24560 KC=PYCOMP(KSUSY1+39)
24561 IF( IMSS(11) .NE. 0 ) THEN
24562 PMAS(KC,1)=RMSS(21)/1000000000D0
24563 PMAS(KC,2)=0.0001D0
24565 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
24571 C...Loop over sparticle and Higgs species.
24572 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
24578 C...Sfermion decays.
24580 C...First check to see if sneutrino is lighter than chi10.
24581 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
24582 & PMAS(KC,1).LT.PMCHI1) THEN
24584 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
24588 ELSEIF(I.EQ.25) THEN
24589 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
24591 C...Neutralino decays.
24592 ELSEIF(I.GE.26.AND.I.LE.29) THEN
24593 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
24594 C...chi10 stable or chi10 -> gravitino + gamma.
24595 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
24601 C...Chargino decays.
24602 ELSEIF(I.GE.30.AND.I.LE.31) THEN
24603 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
24605 C...Gravitino is stable.
24606 ELSEIF(I.EQ.32) THEN
24611 ELSEIF(I.GE.33.AND.I.LE.36) THEN
24612 C...Calculate decays to non-SUSY particles.
24613 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
24618 DO 170 I1=1,MDCY(KC,3)
24620 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
24621 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 170
24623 XLAM(0)=XLAM(0)+XLAM(I1)
24625 IDLAM(I1,J1)=KFDP(K1,J1)
24629 C...Add the decays to SUSY particles.
24630 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
24633 C...Set stable particles.
24641 C...Store branching ratios in the standard tables.
24643 IDC=MDCY(KC,2)+MDCY(KC,3)-1
24648 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
24649 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
24650 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
24651 BRAT(IDC)=XLAM(IL)/XLAM(0)
24653 IF(MDME(IDC,1).GE.1) THEN
24654 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
24655 & PMAS(PYCOMP(KFDP(IDC,2)),1)
24656 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
24657 & PMAS(PYCOMP(KFDP(IDC,3)),1)
24660 IF(XMDIF.GE.0D0) THEN
24661 DELM=MIN(DELM,XMDIF)
24663 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
24664 WRITE(MSTU(11),*) ' KF = ',KF
24665 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
24669 ELSEIF(IDC.EQ.IDCSV) THEN
24670 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
24671 & 'channel not recognized:'
24672 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
24679 C...Store width, cutoff and lifetime.
24681 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
24682 PMAS(KC,3)=PMAS(KC,2)*10D0
24684 PMAS(KC,3)=0.95D0*DELM
24686 IF(PMAS(KC,2).NE.0D0) THEN
24687 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
24695 C*********************************************************************
24697 *$ CREATE PYAPPS.FOR
24700 C...Uses approximate analytical formulae to determine the full set of
24701 C...MSSM parameters from SUGRA input.
24702 C...See M. Drees and S.P. Martin, hep-ph/9504124
24706 C...Double precision and integer declarations.
24707 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24708 INTEGER PYK,PYCHGE,PYCOMP
24709 C...Parameter statement to help give large particle numbers.
24710 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24712 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24713 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24714 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24715 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
24733 DTERM=XMZ2*COS(2D0*BETA)
24734 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
24735 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
24738 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
24739 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
24740 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
24741 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
24743 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
24744 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
24745 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
24746 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
24748 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
24749 IF(XARG.LT.0D0) THEN
24750 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24751 & ' FROM THE SUM RULE. '
24752 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24758 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
24759 PMAS(PYCOMP(KSUSY2+I),1)=XMER
24760 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24761 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24766 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
24767 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
24769 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
24770 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
24771 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
24772 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
24775 XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
24776 XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
24777 XMU=SIGN(SQRT(XMU2),RMSS(4))
24779 RMSS(19)=SQRT(XMA2)
24780 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
24781 IF(ARG.GT.0D0) THEN
24784 WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
24787 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
24788 IF(ARG.GT.0D0) THEN
24791 WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
24794 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
24795 IF(ARG.GT.0D0) THEN
24798 RMSS(10)=-SQRT(-ARG)
24800 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
24801 IF(ARG.GT.0D0) THEN
24804 RMSS(12)=-SQRT(-ARG)
24806 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
24807 IF(ARG.GT.0D0) THEN
24810 RMSS(11)=-SQRT(-ARG)
24816 C*********************************************************************
24818 *$ CREATE PYRNMQ.FOR
24821 C...Determines the running mass of quarks.
24823 FUNCTION PYRNMQ(ID,DTERM)
24825 C...Double precision and integer declarations.
24826 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24827 INTEGER PYK,PYCHGE,PYCOMP
24829 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24832 C...Local variables.
24833 DOUBLE PRECISION PI,R
24834 DOUBLE PRECISION TOL
24835 DOUBLE PRECISION CI(3)
24838 DATA PI,R/3.141592654D0,.61803399D0/
24839 DATA CI/0.47D0,0.07D0,0.02D0/
24843 AG=(0.71D0)**2/4D0/PI
24850 AS=PYALPS(XM02+6D0*XMG2)
24851 CG=8D0/9D0*((AS/AG)**2-1D0)
24852 BX=XM02+(CA+CG)*XMG2+DTERM
24853 AX=MIN(50D0**2,0.5D0*BX)
24854 CX=MAX(2000D0**2,2D0*BX)
24858 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24866 CG=8D0/9D0*((AS1/AG)**2-1D0)
24867 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24869 CG=8D0/9D0*((AS2/AG)**2-1D0)
24870 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24871 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24878 CG=8D0/9D0*((AS2/AG)**2-1D0)
24879 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24886 CG=8D0/9D0*((AS1/AG)**2-1D0)
24887 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24902 C*********************************************************************
24904 *$ CREATE PYRNMT.FOR
24907 C...Determines the running mass of the top quark.
24909 FUNCTION PYRNMT(XMT)
24911 C...Double precision and integer declarations.
24912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24913 INTEGER PYK,PYCHGE,PYCOMP
24915 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24918 C...Local variables.
24919 DOUBLE PRECISION XMT
24920 DOUBLE PRECISION PI,R
24921 DOUBLE PRECISION TOL
24924 DATA PI,R/3.141592654D0,0.61803399D0/
24929 AX=MIN(50D0,BX*0.5D0)
24930 CX=MAX(300D0,2D0*BX)
24934 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24941 AS1=PYALPS(X1**2)/PI
24942 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24943 AS2=PYALPS(X2**2)/PI
24944 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24945 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24951 AS2=PYALPS(X2**2)/PI
24952 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24958 AS1=PYALPS(X1**2)/PI
24959 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24974 C*********************************************************************
24976 *$ CREATE PYTHRG.FOR
24979 C...Calculates the mass eigenstates of the third generation sfermions.
24980 C...Created: 5-31-96
24984 C...Double precision and integer declarations.
24985 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24986 INTEGER PYK,PYCHGE,PYCOMP
24987 C...Parameter statement to help give large particle numbers.
24988 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24990 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24991 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24992 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24993 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24995 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
24997 C...Local variables.
24998 DOUBLE PRECISION BETA
24999 DOUBLE PRECISION PYRNMT
25000 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
25001 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
25002 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
25003 DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
25004 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
25005 INTEGER IF,I,J,II,JJ,IT,L
25019 COS2B=COS(2D0*BETA)
25021 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
25031 XMQL2=CTT2*XM12+STT2*XM22
25032 XMQR2=STT2*XM12+CTT2*XM22
25034 XMF2=PYRNMT(XMFR)**2
25035 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25036 ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
25037 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
25038 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
25040 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25043 C......SUBTRACT OUT D-TERM AND FERMION MASS
25044 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
25045 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
25046 IF(XMQL2.GE.0D0) THEN
25047 RMSS(10)=SQRT(XMQL2)
25049 RMSS(10)=-SQRT(-XMQL2)
25051 IF(XMQR2.GE.0D0) THEN
25052 RMSS(12)=SQRT(XMQR2)
25054 RMSS(12)=-SQRT(-XMQR2)
25056 C SAME FOR SBOTTOM SQUARK
25060 STT=MAX(SQRT(STT2),1D-6)
25064 XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
25065 IF(ABS(CTT).EQ.1D0) THEN
25069 ELSEIF(CTT.EQ.0D0) THEN
25073 XM22=(XMQL2-CTT2*XM12)/STT2
25074 XMQR2=STT2*XM12+CTT2*XM22
25076 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25077 ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
25078 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
25079 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
25081 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25084 C......SUBTRACT OUT D-TERM AND FERMION MASS
25085 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
25086 IF(XMQR2.GE.0D0) THEN
25087 RMSS(11)=SQRT(XMQR2)
25089 RMSS(11)=-SQRT(-XMQR2)
25095 IF(AMQL.LT.0D0) THEN
25103 IF(L.EQ.2) XMF=PYRNMT(XMF)
25107 IF(AMQR.LT.0D0) THEN
25112 AM2(1,1)=XMQL2+XMF2
25113 AM2(2,2)=XMQR2+XMF2
25116 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
25117 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
25118 AM2(1,2)=XMF*(ATR+XMU*TANB)
25119 ELSEIF(L.EQ.2) THEN
25120 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
25121 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
25122 AM2(1,2)=XMF*(ATR+XMU/TANB)
25123 ELSEIF(L.EQ.3) THEN
25124 IF(IMSS(8).EQ.1) THEN
25125 AM2(1,1)=RMSS(6)**2
25126 AM2(2,2)=RMSS(7)**2
25131 AM2(1,2)=XMF*(ATR+XMU*TANB)
25136 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
25137 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
25140 IF(XMF12.LT.0D0) THEN
25141 WRITE(MSTU(11),*) ' NEGATIVE**2 MASS FOR SFERMION '
25145 IF(XMF22-XMF12.GT.0D0) THEN
25146 RT(1,1) = SQRT((XMF22-AM2(1,1))/(XMF22-XMF12))
25148 RT(1,2) = -SIGN(SQRT(1D0-RT(1,1)**2),AM2(1,2)/(XMF22-XMF12))
25164 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
25170 IF(DI(1,1).GT.DI(2,2)) THEN
25171 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
25172 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
25173 WRITE(MSTU(11),*) AM2
25174 WRITE(MSTU(11),*) DI
25175 WRITE(MSTU(11),*) RT
25186 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
25187 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25188 & ' OFF DIAGONAL ELEMENTS '
25189 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
25190 WRITE(MSTU(11),*) DI
25191 WRITE(MSTU(11),*) ' ROTATION = ',RT
25193 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
25194 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25195 & ' NEGATIVE MASSES '
25198 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
25199 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
25200 SFMIX(IF,1)=RT(1,1)
25201 SFMIX(IF,2)=RT(1,2)
25202 SFMIX(IF,3)=RT(2,1)
25203 SFMIX(IF,4)=RT(2,2)
25209 C*********************************************************************
25211 *$ CREATE PYINOM.FOR
25214 C...Finds the mass eigenstates and mixing matrices for neutralinos
25219 C...Double precision and integer declarations.
25220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25221 INTEGER PYK,PYCHGE,PYCOMP
25222 C...Parameter statement to help give large particle numbers.
25223 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25225 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25226 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25227 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25228 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25230 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
25232 C...Local variables.
25233 DOUBLE PRECISION XMW,XMZ
25234 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
25235 DOUBLE PRECISION ZP(4,4)
25236 DOUBLE PRECISION DETX,XI(2,2)
25237 DOUBLE PRECISION XXX,YYY,XMH,XML
25238 DOUBLE PRECISION COSW,SINW
25239 DOUBLE PRECISION XMU
25240 DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
25241 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
25242 DOUBLE PRECISION XM1,XM2,XM3,BETA
25243 DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
25244 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
25245 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
25246 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
25247 DOUBLE PRECISION PYALPS,PYALEM
25248 DOUBLE PRECISION PYRNM3
25249 INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
25250 DATA KFNCHI/1000022,1000023,1000025,1000035/
25253 IF(IMSS(1).EQ.2) THEN
25256 C...M1, M2, AND M3 ARE INDEPENDENT
25261 ELSEIF(IOPT.GE.1) THEN
25265 A1=AEM/(1D0-PARU(102))
25268 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
25270 XM2=XM1*A2/A1*3D0/5D0
25271 ELSEIF(IOPT.EQ.3) THEN
25272 XM1=XM2*5D0/3D0*A1/A2
25275 IF(XM3.LE.0D0) THEN
25276 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
25282 IF(IMSS(3).EQ.1) THEN
25283 PMAS(PYCOMP(KSUSY1+21),1)=XM3
25288 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25289 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
25290 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
25296 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25297 RM2=PMAS(I,1)**2/XM3**2
25298 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
25299 IF(ARG.GE.0D0) THEN
25300 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
25302 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
25307 ELSEIF(X0.EQ.0D0) THEN
25311 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
25312 & 0.5D0*X0**2*LOG(AX0)
25313 BT=(-1D0-2D0*X0)/4D0
25318 ELSEIF(X1.EQ.0D0) THEN
25322 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
25323 & X1**2*LOG(AX1)+AT
25324 BT=(-1D0-2D0*X1)/4D0+BT
25328 X0=0.5D0*(1D0+RM2-RM1)
25329 Y0=-0.5D0*SQRT(-ARG)
25330 AMGX0=SQRT(X0**2+Y0**2)
25331 AM1X0=SQRT((1D0-X0)**2+Y0**2)
25332 ARGX0=ATAN2(-X0,-Y0)
25333 AR1X0=ATAN2(1D0-X0,Y0)
25338 ARGX1=ATAN2(-X1,-Y1)
25339 AR1X1=ATAN2(1D0-X1,Y1)
25340 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
25341 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
25342 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
25343 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
25344 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
25345 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
25350 PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
25354 C...NEUTRALINO MASSES
25358 SINW=SQRT(PARU(102))
25359 COSW=SQRT(1D0-PARU(102))
25370 AR(1,3) = -XMZ*SINW*COSB
25372 AR(1,4) = XMZ*SINW*SINB
25374 AR(2,3) = XMZ*COSW*COSB
25376 AR(2,4) = -XMZ*COSW*SINB
25380 CALL PYEIG4(AR,WR,ZR)
25383 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
25386 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
25390 C...CHARGINO MASSES
25393 AR(1,2) = SQRT(2D0)*XMW*SINB
25394 AR(2,1) = SQRT(2D0)*XMW*COSB
25395 TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2
25396 TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2
25397 TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)*
25398 &(AR(1,2)**2+AR(2,1)**2)+
25399 &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1)
25401 IF(DISCR.LT.0D0) THEN
25402 WRITE(MSTU(11),*) ' PROBLEM WITH DISCR '
25406 XML2=0.5D0*(TERMB-DISCR)
25407 XMH2=0.5D0*(TERMB+DISCR)
25410 PMAS(PYCOMP(KSUSY1+24),1)=XML
25411 PMAS(PYCOMP(KSUSY1+37),1)=XMH
25414 XXX=AR(1,1)**2+AR(2,1)**2
25415 YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1)
25416 VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2)
25417 VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25418 VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2)
25419 VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25424 DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1)
25425 XI(1,1) = AR(2,2)/DETX
25426 XI(2,2) = AR(1,1)/DETX
25427 XI(1,2) = -AR(1,2)/DETX
25428 XI(2,1) = -AR(2,1)/DETX
25434 UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J)
25443 C*********************************************************************
25445 *$ CREATE PYRNM3.FOR
25448 C...Calculates the running of M3, the SU(3) gluino mass parameter.
25450 FUNCTION PYRNM3(RGUT)
25452 C...Double precision and integer declarations.
25453 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25454 INTEGER PYK,PYCHGE,PYCOMP
25456 C...Local variables.
25457 DOUBLE PRECISION PI,R
25458 DOUBLE PRECISION TOL
25461 DATA PI,R/3.141592654D0,0.61803399D0/
25465 BX=RGUT*PYALPS(RGUT**2)
25466 AX=MIN(50D0,BX*0.5D0)
25467 CX=MAX(2000D0,2D0*BX)
25471 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
25479 F1=ABS(X1-RGUT*AS1)
25481 F2=ABS(X2-RGUT*AS2)
25482 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
25489 F2=ABS(X2-RGUT*AS2)
25496 F1=ABS(X1-RGUT*AS1)
25511 C*********************************************************************
25513 *$ CREATE PYEIG4.FOR
25516 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
25517 C...Specific application: mixing in neutralino sector.
25519 SUBROUTINE PYEIG4(A,W,Z)
25520 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25521 INTEGER PYK,PYCHGE,PYCOMP
25523 C...Arrays: in call and local.
25524 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
25526 C...Coefficients of fourth-degree equation from matrix.
25527 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
25528 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
25532 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
25541 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
25542 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
25543 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
25544 B0=B0+(-1D0)**(I+1)*A(1,I)*(
25545 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
25546 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
25547 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
25550 C...Coefficients of third-degree equation needed for
25551 C...separation into two second-degree equations.
25552 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
25555 C0=-B1**2-B0*B3**2+4D0*B0*B2
25556 CQ=C1/3D0-C2**2/9D0
25557 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
25560 C...Cases with one or three real roots.
25561 IF(CQR.GE.0D0) THEN
25562 S1=(CR+SQRT(CQR))**(1D0/3D0)
25563 S2=(CR-SQRT(CQR))**(1D0/3D0)
25567 THE=ACOS(CR/SABS**3)/3D0
25572 C...Find and solve two second-degree equations.
25573 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
25574 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
25575 Q1=U/2D0+SQRT(U**2/4D0-B0)
25576 Q2=U/2D0-SQRT(U**2/4D0-B0)
25577 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
25582 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
25583 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
25584 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
25585 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
25587 C...Order eigenvalues in asceding mass.
25590 DO 130 I2=I1-1,1,-1
25591 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
25597 C...Find equation system for eigenvectors.
25600 D(J1,J1)=A(J1,J1)-W(I)
25607 C...Find largest element in matrix.
25611 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
25614 DAMAX=ABS(D(J1,J2))
25618 C...Subtract others by multiple of row selected above.
25620 DO 210 J3=JA+1,JA+3
25622 RL=D(J1,JB)/D(JA,JB)
25624 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
25625 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
25628 DAMAX=ABS(D(J1,J2))
25632 C...Do one more subtraction of a row.
25634 DO 230 J3=JC+1,JC+3
25636 IF(J1.EQ.JA) GOTO 230
25637 RL=D(J1,JD)/D(JC,JD)
25639 IF(J2.EQ.JB) GOTO 220
25640 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
25641 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
25643 DAMAX=ABS(D(J1,J2))
25647 C...Construct unnormalized eigenvector.
25649 JF2=JD+2-4*((JD+1)/4)
25650 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
25651 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
25654 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
25655 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
25658 C...Normalize and fill in final array.
25659 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
25660 SGN=(-1D0)**INT(PYR(0)+0.5D0)
25669 C*********************************************************************
25671 *$ CREATE PYHGGM.FOR
25674 C...Determines the Higgs boson mass spectrum using several inputs.
25676 SUBROUTINE PYHGGM(ALPHA)
25678 C...Double precision and integer declarations.
25679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25680 INTEGER PYK,PYCHGE,PYCOMP
25681 C...Parameter statement to help give large particle numbers.
25682 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25685 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25686 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25687 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25688 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
25690 C...Local variables.
25691 DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
25692 DOUBLE PRECISION ALPHA
25693 INTEGER I,J,IHOPT,II,JJ,IT
25694 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
25695 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
25696 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
25697 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
25700 IF(IHOPT.EQ.2) THEN
25715 DMC=PMAS(PYCOMP(KSUSY1+37),1)
25720 IF(IHOPT.EQ.0) THEN
25721 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25722 & DMHCH,DSA,DCA,DTANBA)
25723 ELSEIF(IHOPT.EQ.1) THEN
25724 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25725 & DMHCH,DSA,DCA,DTANBA)
25726 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
25727 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
25728 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA)
25732 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.1D-1) THEN
25733 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
25734 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
25735 & PMAS(PYCOMP(1000006),1),DSTOP2
25737 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.1D-1) THEN
25738 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
25739 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
25740 & PMAS(PYCOMP(2000006),1),DSTOP1
25742 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.1D-1) THEN
25743 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
25744 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
25745 & PMAS(PYCOMP(1000005),1),DSBOT2
25747 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.1D-1) THEN
25748 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
25749 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
25750 & PMAS(PYCOMP(2000005),1),DSBOT1
25765 C*********************************************************************
25767 *$ CREATE PYSUBH.FOR
25770 C...This routine computes the renormalization group improved
25771 C...values of Higgs masses and couplings in the MSSM.
25773 C...Program based on the work by M. Carena, J.R. Espinosa,
25774 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
25776 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
25777 C...All masses in GeV units. MA is the CP-odd Higgs mass,
25778 C...MTOP is the physical top mass, MQ and MUR are the soft
25779 C...supersymmetry breaking mass parameters of left handed
25780 C...and right handed stops respectively, AU and AD are the
25781 C...stop and sbottom trilinear soft breaking terms,
25782 C...respectively, and MU is the supersymmetric
25783 C...Higgs mass parameter. We use the conventions from
25784 C...the physics report of Haber and Kane: left right
25785 C...stop mixing term proportional to (AU - MU/TANB)
25786 C...We use as input TANB defined at the scale MTOP
25788 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
25789 C...where MH and HM are the lightest and heaviest CP-even
25790 C...Higgs masses, MHCH is the charged Higgs mass and
25791 C...ALPHA is the Higgs mixing angle
25792 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
25794 C...Range of validity:
25795 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
25796 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
25797 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
25798 C...are the sbottom mass eigenvalues, respectively. This
25799 C...range automatically excludes the existence of tachyons.
25800 C...For the charged Higgs mass computation, the method is
25802 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
25803 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
25804 C...where M_SUSY**2 is the average of the squared stop mass
25805 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
25806 C...masses have been assumed to be of order of the stop ones
25807 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
25809 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
25810 &XMHCH,SA,CA,TANBA)
25812 C...Double precision and integer declarations.
25813 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25814 INTEGER PYK,PYCHGE,PYCOMP
25815 C...Parameter statement to help give large particle numbers.
25816 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25819 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25820 SAVE /PYDAT1/,/PYDAT2/
25822 C...Local variables.
25823 DOUBLE PRECISION PYALEM,PYALPS
25824 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
25825 DOUBLE PRECISION XMHCH,SA,CA
25826 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
25827 DOUBLE PRECISION Q02
25828 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
25829 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
25830 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
25831 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
25832 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
25833 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
25834 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
25835 DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
25840 ALP1=AEM/(1D0-PARU(102))
25853 C...MBOTTOM(MTOP) = 3. GEV
25855 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
25856 &LOG(XMTOP**2/XMZ**2))
25858 C...RMTOP= RUNNING TOP QUARK MASS
25859 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
25860 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
25861 T = LOG(XMS**2/XMTOP**2)
25862 SINB = TANB/((1D0 + TANB**2)**0.5D0)
25864 C...IF(MA.LE.XMTOP) TANBA = TANBT
25866 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
25867 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
25868 &LOG(XMA**2/XMTOP**2))
25870 SINBT = TANBT/SQRT(1D0 + TANBT**2)
25871 COSBT = 1D0/SQRT(1D0 + TANBT**2)
25872 COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
25873 G1 = SQRT(ALP1*4D0*PI)
25874 G2 = SQRT(ALP2*4D0*PI)
25875 G3 = SQRT(ALP3*4D0*PI)
25890 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
25891 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
25892 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
25893 &+ 3D0*(AU + AD)**2/XMS2)/6D0
25894 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
25895 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
25896 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
25897 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
25898 &- 16D0*G3**2) *T/16D0/PI2)
25899 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
25900 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
25901 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
25902 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
25903 &- 16D0*G3**2) *T/16D0/PI2)
25904 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
25905 &(HU2 + HD2)*T/16D0/PI2)
25906 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25907 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25908 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25909 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
25910 &- 16D0*G3**2) *T/16D0/PI2)
25911 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25912 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
25913 &- 16D0*G3**2) *T/16D0/PI2)
25914 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
25915 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25916 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25917 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25919 &(1+ (6D0*HU2 -2D0* HD2
25920 &- 16D0*G3**2) *T/16D0/PI2)
25921 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25923 &(1+ (6D0*HD2 -2D0* HU2/2D0
25924 &- 16D0*G3**2) *T/16D0/PI2)
25925 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
25926 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
25927 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
25928 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
25929 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
25930 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25931 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
25932 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25933 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
25934 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25935 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
25936 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25937 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
25938 &2D0* XLAM6*SINBT*COSBT
25939 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
25941 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
25943 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
25944 &2D0* XLAM6* COSBT*SINBT
25945 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25946 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
25947 &((XLAM1* COSBT**2 +2D0*
25948 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
25949 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
25951 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
25952 &+ XLAM4) + XLAM6*COSBT**2
25953 &+ XLAM7* SINBT**2))
25955 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
25956 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
25959 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
25960 XMHCH = SQRT(XMHCH2)
25962 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25963 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25964 &XLAM6* COSBT*SINBT
25965 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25966 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25967 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
25968 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
25970 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
25971 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
25972 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
25973 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
25974 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25975 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25976 &XLAM6* COSBT*SINBT
25977 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25978 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25979 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
25989 C*********************************************************************
25991 *$ CREATE PYPOLE.FOR
25994 C...This subroutine computes the CP-even higgs and CP-odd pole
25995 c...Higgs masses and mixing angles.
25997 C...Program based on the work by M. Carena, M. Quiros
25998 C...and C.E.M. Wagner, "Effective potential methods and
25999 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
26001 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
26003 C...where MCHI is the largest chargino mass, MA is the running
26004 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
26005 C...expectaion values at the scale MTOP, MQ is the third generation
26006 C...left handed squark mass parameter, MUR is the third generation
26007 C...right handed stop mass parameter, MDR is the third generation
26008 C...right handed sbottom mass parameter, MTOP is the pole top quark
26009 C...mass; AT,AB are the soft supersymmetry breaking trilinear
26010 C...couplings of the stop and sbottoms, respectively, and MU is the
26011 C...supersymmetric mass parameter
26013 C...The parameter IHIGGS=0,1,2,3 corresponds to the
26014 c...number of Higgses whose pole mass is computed
26015 c...by the subroutine PYVACU(...). If IHIGGS=0 only running
26016 c...masses are given, what makes the running of the program
26017 c...much faster and it is quite generally a good approximation
26018 c...(for a theoretical discussion see ref. below).
26019 c...If IHIGGS=1, only the pole
26020 c...mass for H is computed. If IHIGGS=2, then h and H, and
26021 c...if IHIGGS=3, then h,H,A polarizations are computed
26023 C...Output: MH and MHP which are the lightest CP-even Higgs running
26024 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
26025 C...Higgs running and pole masses, repectively; SA and CA are the
26026 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
26027 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
26028 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
26029 C...the value of TANB at the CP-odd Higgs mass scale
26031 C...This subroutine makes use of CERN library subroutine
26032 C...integration package, which makes the computation of the
26033 C...pole Higgs masses somewhat faster. We thank P. Janot for this
26034 C...improvement. Those who are not able to call the CERN
26035 C...libraries, please use the subroutine SUBHPOLE2.F, which
26036 C...although somewhat slower, gives identical results
26038 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
26039 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
26041 C...Double precision and integer declarations.
26042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26043 INTEGER PYK,PYCHGE,PYCOMP
26045 CALL PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
26046 &XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,SBOT1,SBOT2,
26047 &SA,CA,STOP1W,STOP2W,TANBA)
26048 SINB = TANB/(TANB**2+1D0)**0.5D0
26049 COSB = 1D0/(TANB**2+1D0)**0.5D0
26050 SINBMA = SINB*CA - COSB*SA
26055 C*********************************************************************
26057 *$ CREATE PYVACU.FOR
26060 C...Computes Higgs masses and mixing angles, see PYPOLE above.
26062 SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
26063 &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
26064 &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
26066 C...Double precision and integer declarations.
26067 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26069 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26070 INTEGER PYK,PYCHGE,PYCOMP
26072 C...Local variables.
26073 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
26074 &SSBOT2(2),B(2,2),COUPB(2,2),
26075 &HCOUPT(2,2),HCOUPB(2,2),
26076 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
26086 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
26088 C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
26092 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
26093 &XMU,XMH,HM,SA,CA,TANBA)
26094 SINB = TANB/(TANB**2+1D0)**0.5D0
26095 COSB = 1D0/(TANB**2+1D0)**0.5D0
26096 COS2B = SINB**2 - COSB**2
26097 SINBPA = SINB*CA + COSB*SA
26098 COSBPA = COSB*CA - SINB*SA
26102 IF(XMUR.LT.0D0) XMUR2=-XMUR2
26104 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
26105 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
26106 IF(XMST11.LT.0D0) GOTO 500
26107 IF(XMST22.LT.0D0) GOTO 500
26108 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
26109 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
26110 IF(XMSB11.LT.0D0) GOTO 500
26111 IF(XMSB22.LT.0D0) GOTO 500
26112 WMST11 = RXMT**2 + XMQ2
26113 WMST22 = RXMT**2 + XMUR2
26114 XMST12 = RXMT*(AT - XMU/TANB)
26115 XMSB12 = RMBOT*(AB - XMU*TANB)
26117 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26118 C...STOP EIGENVALUES CALCULATION
26119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26121 STOP12 = 0.5D0*(XMST11+XMST22) +
26122 &0.5D0*((XMST11+XMST22)**2 -
26123 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
26124 STOP22 = 0.5D0*(XMST11+XMST22) -
26125 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
26126 &XMST12**2))**0.5D0
26128 IF(STOP22.LT.0D0) GOTO 500
26131 STOP1 = STOP12**0.5D0
26132 STOP2 = STOP22**0.5D0
26136 IF(XMST12.EQ.0D0) XST11 = 1D0
26137 IF(XMST12.EQ.0D0) XST12 = 0D0
26138 IF(XMST12.EQ.0D0) XST21 = 0D0
26139 IF(XMST12.EQ.0D0) XST22 = 1D0
26141 IF(XMST12.EQ.0D0) GOTO 110
26143 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26144 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26145 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26146 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26153 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
26154 &0.5D0*((XMSB11+XMSB22)**2 -
26155 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
26156 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
26157 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
26158 &XMSB12**2))**0.5D0
26159 IF(SBOT22.LT.0D0) GOTO 500
26160 SBOT1 = SBOT12**0.5D0
26161 SBOT2 = SBOT22**0.5D0
26166 IF(XMSB12.EQ.0D0) XSB11 = 1D0
26167 IF(XMSB12.EQ.0D0) XSB12 = 0D0
26168 IF(XMSB12.EQ.0D0) XSB21 = 0D0
26169 IF(XMSB12.EQ.0D0) XSB22 = 1D0
26171 IF(XMSB12.EQ.0D0) GOTO 130
26173 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26174 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26175 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26176 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26188 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26189 C...STARTING OF LIGHT HIGGS
26190 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26192 IF(IHIGGS.EQ.0) GOTO 490
26197 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
26198 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26199 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
26200 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
26209 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
26210 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26211 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
26212 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
26220 180 ITER = ITER + 1
26223 PR(I3)=PRUN+(I3-2)*EPS/2
26228 POLT = POLT + COUPT(I,J)**2*3D0*
26229 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26235 POLB = POLB + COUPB(I,J)**2*3D0*
26236 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26243 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26245 & (-2D0*XMT**2+0.5D0*P2)*
26246 & PYFINT(P2,XMT2,XMT2)
26248 POL = POLT + POLB + POLTT
26249 POLAR(I3) = P2 - XMH**2 - POL
26251 DERIV = (POLAR(3)-POLAR(1))/EPS
26252 DRUN = - POLAR(2)/DERIV
26255 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240
26261 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26262 C...END OF LIGHT HIGGS
26263 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26265 250 IF(IHIGGS.EQ.1) GOTO 490
26267 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26268 C... STARTING OF HEAVY HIGGS
26269 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26274 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
26275 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26276 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
26277 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
26285 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
26286 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26287 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
26288 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
26297 300 ITER = ITER + 1
26299 PR(I3)=PRUN+(I3-2)*EPS/2
26305 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
26306 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26313 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
26314 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26322 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26324 & (-2D0*XMT**2+0.5D0*HP2)*
26325 & PYFINT(HP2,XMT2,XMT2)
26327 HPOL = HPOLT + HPOLB + HPOLTT
26328 POLAR(I3) =HP2-HM**2-HPOL
26330 DERIV = (POLAR(3)-POLAR(1))/EPS
26331 DRUN = - POLAR(2)/DERIV
26334 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360
26342 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26343 C... END OF HEAVY HIGGS
26344 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26346 IF(IHIGGS.EQ.2) GOTO 490
26348 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26349 C...BEGINNING OF PSEUDOSCALAR HIGGS
26350 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26355 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
26356 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
26362 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
26363 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
26370 420 ITER = ITER + 1
26372 PR(I3)=PRUN+(I3-2)*EPS/2
26377 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
26378 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26384 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
26385 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26391 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26392 & COSB**2/SINB**2 *
26394 & PYFINT(AP2,XMT2,XMT2)
26395 APOL = APOLT + APOLB + APOLTT
26396 POLAR(I3) = AP2 - XMA**2 -APOL
26398 DERIV = (POLAR(3)-POLAR(1))/EPS
26399 DRUN = - POLAR(2)/DERIV
26402 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480
26408 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26409 C...END OF PSEUDOSCALAR HIGGS
26410 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26412 IF(IHIGGS.EQ.3) GOTO 490
26417 WRITE(MSTU(11),*) ' EXITING IN PYVACU '
26418 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
26419 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
26420 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
26424 C*********************************************************************
26426 *$ CREATE PYRGHM.FOR
26429 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26431 SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
26432 &XMHP,HMP,SA,CA,TANBA)
26434 C...Double precision and integer declarations.
26435 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26436 INTEGER PYK,PYCHGE,PYCOMP
26438 C...Local variables.
26439 DIMENSION VH(2,2),XM2(2,2),XM2P(2,2)
26450 C...MBOTTOM(XMT) = 3. GEV
26452 ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z*
26453 &LOG(XMT**2/XMZ**2))
26455 C...RXMT= RUNNING TOP QUARK MASS
26456 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26457 TQ = LOG((XMQ**2+XMT**2)/XMT**2)
26458 TU = LOG((XMUR**2 + XMT**2)/XMT**2)
26459 TD = LOG((XMDL**2 + XMT**2)/XMT**2)
26460 SINB = TANB/((1D0 + TANB**2)**0.5D0)
26463 &TANBA = TANB*(1D0-3D0/32D0/PI**2*
26464 &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
26465 &LOG(XMA**2/XMT**2))
26466 IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA
26467 SINB = TANBT/((1D0 + TANBT**2)**0.5D0)
26468 COSB = 1D0/((1D0 + TANBT**2)**0.5D0)
26469 COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
26470 G1 = (ALP1*4D0*PI)**0.5D0
26471 G2 = (ALP2*4D0*PI)**0.5D0
26472 G3 = (ALP3*4D0*PI)**0.5D0
26476 CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD,
26477 &XMU,VH,STOP1,STOP2)
26479 IF(XMQ.GT.XMUR) TP = TQ - TU
26480 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ
26481 IF(XMQ.GT.XMUR) TDP = TU
26482 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ
26483 IF(XMQ.GT.XMDL) TPD = TQ - TD
26484 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ
26485 IF(XMQ.GT.XMDL) TDPD = TD
26486 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ
26488 IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
26489 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2*
26490 &HD**2*(G1**2/3D0+G2**2)*TPD
26492 IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP
26493 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2*
26494 &HU**2*(-G1**2/3D0+G2**2)*TP
26499 IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
26500 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2*
26501 &(G2**2-G1**2/3D0)*TPD
26503 IF(XMQ.GT.XMUR) DLAM3 = DLAM3 -
26504 &1D0/16D0/PI**2*G1**2*HU**2*TP
26505 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 +
26506 &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
26508 IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
26509 IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2*
26512 XLAM1 = ((G1**2 + G2**2)/4D0)*
26513 &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
26514 &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0
26515 &+ (3D0*HD**2/2D0 + HU**2/2D0
26516 &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
26517 &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
26518 &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1
26519 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
26520 &(TP + TDP)/8D0/PI**2)
26521 &+(3D0*HU**4/16D0/PI**2) *TP*(1D0
26522 &+ (3D0*HU**2/2D0 + HD**2/2D0
26523 &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
26524 &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
26525 &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2
26526 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
26527 &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
26528 &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3
26529 XLAM4 = (- G2**2/2D0)*(1D0
26530 &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
26531 &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4
26537 XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6*
26538 &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2
26540 XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7*
26541 &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2
26542 XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)*
26543 &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB
26545 XM2(2,1) = XM2(1,2)
26547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26548 C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
26549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26551 XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0
26553 IF(XMC.GT.XMSSU) GOTO 100
26554 IF(XMC.LT.XMT) XMC=XMT
26556 TCHAR=LOG(XMSSU**2/XMC**2)
26558 DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
26559 DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
26560 &+4D0/32/PI**2*G1**2*G2**2)*TCHAR
26562 DEM112=2D0*DEL12*V**2*COSB**2
26563 DEM222=2D0*DEL12*V**2*SINB**2
26564 DEM122=2D0*DEL3P4*V**2*SINB*COSB
26566 XM2(1,1)=XM2(1,1)+DEM112
26567 XM2(2,2)=XM2(2,2)+DEM222
26568 XM2(1,2)=XM2(1,2)+DEM122
26569 XM2(2,1)=XM2(2,1)+DEM122
26573 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26574 C...END OF CHARGINOS/NEUTRALINOS
26575 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26579 XM2P(I,J) = XM2(I,J) + VH(I,J)
26583 TRM2P = XM2P(1,1) + XM2P(2,2)
26584 DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1)
26586 XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26587 HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26589 IF(XMH2P.LT.0D0) GOTO 130
26590 XMHP = XMH2P**0.5D0
26591 S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0
26592 C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0
26593 IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0
26594 IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0
26597 SQBMA = (SINB*CA - COSB*SA)**2
26604 C*********************************************************************
26606 *$ CREATE PYGFXX.FOR
26609 C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
26611 SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
26614 C...Double precision and integer declarations.
26615 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26616 INTEGER PYK,PYCHGE,PYCOMP
26618 C...Local variables.
26619 DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
26620 &VH3T(2,2),VH3B(2,2),
26621 &HMIX(2,2),AL(2,2),XM2(2,2)
26623 C...Statement function.
26624 G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y)
26626 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
26631 SINBA = TANBA/(TANBA**2+1D0)**0.5D0
26632 COSBA = SINBA/TANBA
26634 SINB = TANB/(TANB**2+1D0)**0.5D0
26637 G2 = (0.0336D0*4D0*PI)**0.5D0
26638 G12 = (0.0101D0*4D0*PI)
26642 MW = (G2**2*V**2/2D0)**0.5D0
26643 ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2))
26646 IF(XMQ.GT.XMUR) XMST = XMQ
26647 IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR
26649 XMSUT = (XMST**2 + XMT**2)**0.5D0
26651 IF(XMQ.GT.XMDL) XMSB = XMQ
26652 IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL
26654 XMSUB = (XMSB**2 + XMB**2)**0.5D0
26656 TT = LOG(XMSUT**2/XMT**2)
26657 TB = LOG(XMSUB**2/XMT**2)
26659 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26660 HT = RXMT/(174.1D0*SINB)
26661 HTST = RXMT/174.1D0
26662 HB = XMB/174.1D0/COSB
26664 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
26665 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
26666 AL2 = 3D0/8D0/PI**2*HT**2
26667 BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2
26668 ALST = 3D0/8D0/PI**2*HTST**2
26669 AL1 = 3D0/8D0/PI**2*HB**2
26672 AL(1,2) = (AL2+AL1)/2D0
26673 AL(2,1) = (AL2+AL1)/2D0
26676 XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT)
26678 XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB)
26679 XMBOT2 = SQRT(XMBOT4)
26681 IF(XMA.GT.XMT) THEN
26682 VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2*
26683 & LOG(XMT**2/XMA**2))
26686 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0
26687 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0
26688 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0
26689 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0
26694 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0
26695 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0
26696 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0
26697 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0
26701 SINBT = TANBST/(1D0+TANBST**2)**0.5D0
26702 COSBT = SINBT/TANBST
26705 SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0
26706 COSBB = SINBB/TANBSB
26708 STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26709 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26710 &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26711 &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0
26712 STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26713 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26714 &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26715 &XMQ2 - XMUR2)**2*0.25D0
26716 &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0
26717 IF(STOP22.LT.0D0) GOTO 120
26718 SBOT12 = (XMQ2 + XMDL2)*0.5D0
26719 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26720 &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26721 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26722 SBOT22 = (XMQ2 + XMDL2)*0.5D0
26723 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26724 &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26725 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26726 IF(SBOT22.LT.0D0) GOTO 120
26728 STOP1 = STOP12**0.5D0
26729 STOP2 = STOP22**0.5D0
26730 SBOT1 = SBOT12**0.5D0
26731 SBOT2 = SBOT22**0.5D0
26733 VH1(1,1) = 1D0/TANBST
26740 VH2(2,2) = 1D0/TANBST
26742 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26744 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26747 F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)*
26749 &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2))
26750 &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2))
26752 F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)*
26754 &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2))
26755 &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2))
26757 F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)*
26758 &(-0.5D0*LOG(STOP12/STOP22)
26759 &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)*
26762 F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
26763 &(0.5D0*LOG(SBOT12/SBOT22)
26764 &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)*
26767 VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
26768 &(XMQ2+XMBOT2)/(XMDL2+XMBOT2))
26769 &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
26770 &LOG(SBOT1**2/SBOT2**2)) +
26771 &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
26772 &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
26775 &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
26776 &-STOP2**2))**2*G(STOP12,STOP22)
26778 VH3B(1,1)=VH3B(1,1)+
26779 &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B)
26781 VH3T(1,1) = VH3T(1,1) +
26782 &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T)
26784 VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
26785 &(XMQ2+XMT2)/(XMUR2+XMT2))
26786 &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
26787 &LOG(STOP1**2/STOP2**2)) +
26788 &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
26789 &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
26792 &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
26793 &-SBOT2**2))**2*G(SBOT12,SBOT22)
26795 VH3T(2,2)=VH3T(2,2)+
26796 &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T)
26798 VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B
26801 &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
26802 &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
26803 &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
26806 &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/
26807 &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
26808 &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
26810 VH3T(1,2)=VH3T(1,2) +
26811 &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T)
26813 VH3B(1,2)=VH3B(1,2)
26814 &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B)
26816 VH3T(2,1) = VH3T(1,2)
26817 VH3B(2,1) = VH3B(1,2)
26819 TQ = LOG((XMQ2 + XMT2)/XMT2)
26820 TU = LOG((XMUR2+XMT2)/XMT2)
26821 TQD = LOG((XMQ2 + XMB**2)/XMB**2)
26822 TD = LOG((XMDL2+XMB**2)/XMB**2)
26828 & 6D0/(8D0*PI**2*(H1T**2+H2T**2))
26829 & *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
26830 & 6D0/(8D0*PI**2*(H1B**2+H2B**2))
26831 & *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
26848 C*********************************************************************
26850 *$ CREATE PYFINT.FOR
26853 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26855 FUNCTION PYFINT(A,B,C)
26857 C...Double precision and integer declarations.
26858 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26859 INTEGER PYK,PYCHGE,PYCOMP
26861 COMMON/PYINTS/XXM(20)
26864 C...Local variables.
26872 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
26877 C*********************************************************************
26879 *$ CREATE PYFISB.FOR
26882 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
26886 C...Double precision and integer declarations.
26887 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26888 INTEGER PYK,PYCHGE,PYCOMP
26890 COMMON/PYINTS/XXM(20)
26893 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
26894 &(X*(XXM(2)-XXM(3))+XXM(3)))
26899 C*********************************************************************
26901 *$ CREATE PYSFDC.FOR
26904 C...Calculates decays of sfermions.
26906 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
26908 C...Double precision and integer declarations.
26909 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26910 INTEGER PYK,PYCHGE,PYCOMP
26911 C...Parameter statement to help give large particle numbers.
26912 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
26914 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26915 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26916 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
26917 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
26919 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
26921 C...Local variables.
26923 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
26925 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
26926 DOUBLE PRECISION PYLAMF,XL
26927 DOUBLE PRECISION TANW,XW,AEM,C1,AS
26928 DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
26929 DOUBLE PRECISION CH1,CH2,CH3,CH4
26930 DOUBLE PRECISION XMBOT,XMTOP
26931 DOUBLE PRECISION XLAM(0:200)
26932 INTEGER IDLAM(200,3)
26933 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
26934 DOUBLE PRECISION SR2
26935 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
26936 DOUBLE PRECISION CW
26937 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
26938 DOUBLE PRECISION COSA,SINA,TANB
26939 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
26940 DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
26941 INTEGER IG,KF1,KF2,ILR2,IDP
26942 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
26943 DATA IGG/23,25,35,36/
26944 DATA PI/3.141592654D0/
26945 DATA SR2/1.4142136D0/
26946 DATA KFNCHI/1000022,1000023,1000025,1000035/
26947 DATA KFCCHI/1000024,1000037/
26949 C...COUNT THE NUMBER OF DECAY MODES
26953 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
26954 &KFIN.EQ.KSUSY2+16) RETURN
26961 TANW = SQRT(XW/(1D0-XW))
26966 C...ILR is 1 for left and 2 for right.
26968 C...IFL is matching non-SUSY flavour.
26969 IFL=MOD(KFIN,KSUSY1)
26970 C...IDU is weak isospin, 1 for down and 2 for up.
26982 XMTOP=PYRNMT(PMAS(6,1))
26997 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
26999 IF(IMSS(11).EQ.1) THEN
27002 XMGR=PMAS(PYCOMP(IDG),1)
27003 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
27006 ELSEIF(IFL.EQ.6) THEN
27011 IF(XMI.GT.XMGR+XMF) THEN
27016 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
27020 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
27022 C...CHARGED DECAYS:
27024 C...DI -> U CHI1-,CHI2-
27028 C...UI -> D CHI1+,CHI2+
27035 IF(XMI.GE.AXMJ+XMFP) THEN
27042 ELSEIF(IFL.LT.6) THEN
27047 AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA
27048 BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA
27054 ELSEIF(IFL.LT.5) THEN
27059 AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA
27060 BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA
27064 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
27065 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
27066 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
27067 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
27083 XL=PYLAMF(XMI2,XMA2,XMB2)
27084 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
27085 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27086 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP)
27089 IDLAM(LKNT,1)=-KFCCHI(IX)
27090 IDLAM(LKNT,2)=IFL+1
27092 IDLAM(LKNT,1)=KFCCHI(IX)
27093 IDLAM(LKNT,2)=IFL-1
27104 IF(XMI.GE.AXMJ+XMF) THEN
27110 ELSEIF(IFL.LT.5) THEN
27113 BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1)
27114 AL=XMF*ZMIX(IX,3)/XMW/CBETA
27115 AR=-2D0*EI*TANW*ZMIX(IX,1)
27120 ELSEIF(IFL.LT.5) THEN
27123 BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1)
27124 AL=XMF*ZMIX(IX,4)/XMW/SBETA
27125 AR=-2D0*EI*TANW*ZMIX(IX,1)
27129 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
27130 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
27131 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
27132 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
27148 XL=PYLAMF(XMI2,XMA2,XMB2)
27149 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
27150 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27151 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27152 IDLAM(LKNT,1)=KFNCHI(IX)
27158 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
27162 IF(ILR.EQ.1) GOTO 120
27164 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
27165 IF(XMI.LT.XMSF1+XMB) GOTO 120
27167 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
27170 ELSEIF(IG.EQ.25) THEN
27173 ELSEIF(IFL.EQ.6) THEN
27175 ELSEIF(IFL.LT.5) THEN
27181 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27182 & XMF**2/XMW*COSA/SBETA
27183 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27184 & XMF**2/XMW*COSA/SBETA
27186 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27187 & XMF**2/XMW*(-SINA)/CBETA
27188 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27189 & XMF**2/XMW*(-SINA)/CBETA
27193 ELSEIF(IFL.EQ.6) THEN
27195 ELSEIF(IFL.EQ.15) THEN
27201 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
27204 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
27210 ELSEIF(IG.EQ.35) THEN
27213 ELSEIF(IFL.EQ.6) THEN
27215 ELSEIF(IFL.LT.5) THEN
27221 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27222 & XMF**2/XMW*SINA/SBETA
27223 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27224 & XMF**2/XMW*SINA/SBETA
27226 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27227 & XMF**2/XMW*COSA/CBETA
27228 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27229 & XMF**2/XMW*COSA/CBETA
27233 ELSEIF(IFL.EQ.6) THEN
27235 ELSEIF(IFL.EQ.15) THEN
27241 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
27244 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
27250 ELSEIF(IG.EQ.36) THEN
27255 ELSEIF(IFL.EQ.6) THEN
27257 ELSEIF(IFL.LT.5) THEN
27264 ELSEIF(IFL.EQ.6) THEN
27266 ELSEIF(IFL.EQ.15) THEN
27272 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
27274 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
27280 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
27281 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
27282 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
27283 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27286 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27288 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
27291 IDLAM(LKNT,1)=KFIN-KSUSY1
27297 IF(MOD(IFL,2).EQ.0) THEN
27303 XMSF1=PMAS(PYCOMP(KF1),1)
27304 XMSF2=PMAS(PYCOMP(KF2),1)
27305 IF(XMI.GT.XMB+XMSF1) THEN
27306 IF(MOD(IFL,2).EQ.0) THEN
27308 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
27310 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
27314 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
27316 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
27319 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27321 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27324 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27326 IF(XMI.GT.XMB+XMSF2) THEN
27327 IF(MOD(IFL,2).EQ.0) THEN
27329 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
27331 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
27335 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
27337 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
27340 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
27342 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27345 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27350 IF(MOD(IFL,2).EQ.0) THEN
27356 XMSF1=PMAS(PYCOMP(KF1),1)
27357 XMSF2=PMAS(PYCOMP(KF2),1)
27358 IF(XMI.GT.XMB+XMSF1) THEN
27363 IF(MOD(IFL,2).EQ.0) THEN
27366 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
27367 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
27368 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
27369 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
27372 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
27373 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
27374 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
27375 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
27386 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
27387 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
27388 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
27389 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
27392 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
27393 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
27394 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
27395 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
27404 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27406 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27407 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27408 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27409 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27412 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27414 IF(XMI.GT.XMB+XMSF2) THEN
27419 IF(MOD(IFL,2).EQ.0) THEN
27422 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
27423 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
27424 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
27425 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
27428 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
27429 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
27430 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
27431 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
27442 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
27443 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
27444 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
27445 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
27448 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
27449 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
27450 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
27451 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
27460 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27462 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27463 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27464 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27465 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27468 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27471 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
27476 IF(IFL.EQ.6) XMF=PMAS(6,1)
27477 IF(IFL.EQ.5) XMF=PMAS(5,1)
27478 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
27480 IF(XMI.GE.AXMJ+XMF) THEN
27497 XL=PYLAMF(XMI2,XMA2,XMB2)
27498 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27499 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27500 IDLAM(LKNT,1)=KSUSY1+21
27506 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
27507 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
27508 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
27509 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
27510 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
27511 C...M*M = C1**2 * G**2/(16PI**2)
27512 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
27514 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
27515 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
27516 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
27517 IDLAM(LKNT,1)=KSUSY1+22
27525 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27526 XLAM(0)=XLAM(0)+XLAM(I)
27528 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
27533 C*********************************************************************
27535 *$ CREATE PYGLUI.FOR
27538 C...Calculates gluino decay modes.
27540 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
27542 C...Double precision and integer declarations.
27543 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27544 INTEGER PYK,PYCHGE,PYCOMP
27545 C...Parameter statement to help give large particle numbers.
27546 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27550 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27551 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27553 COMMON/PYINTS/XXM(20)
27554 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
27556 C...Local variables.
27557 INTEGER KFIN,KCIN,KF
27558 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
27559 &XMZ,XMZ2,AXMJ,AXMI
27560 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
27561 DOUBLE PRECISION C1L,C1R,D1L,D1R
27562 DOUBLE PRECISION C2L,C2R,D2L,D2R
27563 DOUBLE PRECISION PYLAMF,XL
27564 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
27565 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
27566 DOUBLE PRECISION ALFA,BETA
27567 DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
27568 DOUBLE PRECISION XLAM(0:200)
27569 INTEGER IDLAM(200,3)
27570 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
27571 DOUBLE PRECISION SR2
27572 DOUBLE PRECISION GAM
27573 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
27574 DOUBLE PRECISION PYGAUS
27575 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
27576 DOUBLE PRECISION PREC
27577 INTEGER KFNCHI(4),KFCCHI(2)
27578 DATA PI/3.141592654D0/
27579 DATA SR2/1.4142136D0/
27581 DATA KFNCHI/1000022,1000023,1000025,1000035/
27582 DATA KFCCHI/1000024,1000037/
27584 C...COUNT THE NUMBER OF DECAY MODES
27586 IF(KFIN.NE.KSUSY1+21) RETURN
27594 TANW = SQRT(XW/(1D0-XW))
27605 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
27607 IF(IMSS(11).EQ.1) THEN
27610 XMGR=PMAS(PYCOMP(IDG),1)
27611 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
27612 IF(AXMI.GT.XMGR) THEN
27621 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
27625 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
27628 IDU=3-(1+MOD(IFL,2))
27629 IF(XMI.GE.AXMJ+XMF) THEN
27646 XL=PYLAMF(XMI2,XMA2,XMB2)
27647 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
27648 & (CA**2+CB**2)+4D0*CA*CB*XMI*XMF)
27649 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
27653 XLAM(LKNT)=XLAM(LKNT-1)
27654 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27655 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27661 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
27662 C...GLUINO -> NI Q QBAR
27666 IF(XMI.GE.AXMJ) THEN
27671 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
27672 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
27678 S12MAX=(XMI-AXMJ)**2
27683 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27685 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
27686 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120
27687 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
27689 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27690 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27691 IDLAM(LKNT,1)=KFNCHI(IX)
27695 IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
27697 XLAM(LKNT)=XLAM(LKNT-1)
27698 IDLAM(LKNT,1)=KFNCHI(IX)
27703 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130
27704 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
27705 CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
27708 IDLAM(LKNT,1)=KFNCHI(IX)
27714 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
27715 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
27717 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27719 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
27720 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140
27721 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
27723 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27724 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27725 IDLAM(LKNT,1)=KFNCHI(IX)
27729 IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
27731 XLAM(LKNT)=XLAM(LKNT-1)
27732 IDLAM(LKNT,1)=KFNCHI(IX)
27737 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
27738 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
27739 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150
27741 IF(XMI.GE.AXMJ+2D0*XMF) THEN
27742 CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
27745 IDLAM(LKNT,1)=KFNCHI(IX)
27753 C...GLUINO -> CI Q QBAR'
27757 IF(XMI.GE.AXMJ) THEN
27759 S12MAX=(AXMI-AXMJ)**2
27768 XXM(7)=UMIX(IX,1)*SR2
27769 XXM(8)=VMIX(IX,1)*SR2
27770 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
27771 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
27772 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170
27773 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
27775 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
27776 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
27777 IDLAM(LKNT,1)=KFCCHI(IX)
27781 XLAM(LKNT)=XLAM(LKNT-1)
27782 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27783 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27784 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27786 IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
27788 XLAM(LKNT)=XLAM(LKNT-1)
27789 IDLAM(LKNT,1)=KFCCHI(IX)
27793 XLAM(LKNT)=XLAM(LKNT-1)
27794 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27795 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27796 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27800 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180
27801 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180
27804 IF(XMI.GE.AXMJ+XMF+XMFP) THEN
27805 CALL PYTBBC(IX,80,AXMI,GAM)
27808 IDLAM(LKNT,1)=KFCCHI(IX)
27812 XLAM(LKNT)=XLAM(LKNT-1)
27813 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27814 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27815 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27824 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27825 XLAM(0)=XLAM(0)+XLAM(I)
27827 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
27832 C*********************************************************************
27834 *$ CREATE PYTBBN.FOR
27837 C...Calculates the three-body decay of gluinos into
27838 C...neutralinos and third generation fermions.
27840 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
27842 C...Double precision and integer declarations.
27843 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27844 INTEGER PYK,PYCHGE,PYCOMP
27845 C...Parameter statement to help give large particle numbers.
27846 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27850 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27851 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27853 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
27855 C...Local variables.
27856 EXTERNAL PYSIMP,PYLAMF
27858 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
27859 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
27860 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
27861 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
27862 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
27863 DOUBLE PRECISION XLN1,XLN2,B1,B2
27864 DOUBLE PRECISION E,XMGLU,GAM
27865 DOUBLE PRECISION PYSIMP,PYLAMF
27866 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
27867 SAVE HRB,HLB,FLB,FRB
27868 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
27869 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
27870 SAVE HLT,HRT,FLT,FRT
27871 DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
27873 SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD
27874 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
27875 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
27877 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
27878 DOUBLE PRECISION ROT1(4,4)
27881 DATA IFIRST/.TRUE./
27884 SINB=TANB/SQRT(1D0+TANB**2)
27896 AMTOP=PYRNMT(PMAS(6,1))
27898 FAKT1=AMBOT/W2/AMW/COSB
27899 FAKT2=AMTOP/W2/AMW/SINB
27910 ROT1(2,1)=-ROT1(1,2)
27911 ROT1(2,2)=ROT1(1,1)
27914 ROT1(4,3)=-ROT1(3,4)
27915 ROT1(4,4)=ROT1(3,3)
27919 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
27924 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
27925 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27926 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
27928 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
27929 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
27930 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
27931 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
27934 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
27935 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27936 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
27937 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
27938 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
27939 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
27940 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
27944 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
27945 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
27946 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
27947 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
27951 IF(NINT(3D0*E).EQ.2) THEN
27958 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
27959 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
27968 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
27969 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
27975 SIN2D=SIND*COSD*2D0
27989 ALPHAW=PYALEM(XMG2)
27990 ALPHAS=PYALPS(XMG2)
27994 XM24=(XMG2+XM2)*(XM2+XMR2)
27996 SMAX=(XMG-ABS(XMR))**2
27997 XMQA=XMG2+2D0*XM2+XMR2
27999 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
28001 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
28003 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
28004 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
28005 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
28006 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
28007 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
28008 & +2D0*(FF*SIND2-HH*COSD2))*W
28009 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
28010 & +4D0*HFL*XM*XMR)*XLN1
28011 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
28012 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
28013 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
28014 & +8D0*HFL*XMQ4*SIN2D)*B1
28015 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
28016 & +4D0*HFR*XMR*XM)*XLN2
28017 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
28018 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
28019 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
28020 & -8D0*HFR*XMQ4*SIN2D)*B2
28021 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
28022 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
28023 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
28024 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
28025 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
28026 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
28027 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
28028 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
28029 G(5)=(2D0*(HH*COSD2-FF*SIND2)
28030 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
28031 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
28032 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
28033 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
28034 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
28035 & +COS2D*XM*(SBAR+XMG2-XMR2))
28036 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
28037 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
28038 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
28039 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
28040 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
28041 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
28042 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
28045 SUMME(LIN)=SUMME(LIN)+G(J)
28050 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
28051 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
28056 C*********************************************************************
28058 *$ CREATE PYTBBC.FOR
28061 C...Calculates the three-body decay of gluinos into
28062 C...charginos and third generation fermions.
28064 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
28066 C...Double precision and integer declarations.
28067 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28068 INTEGER PYK,PYCHGE,PYCOMP
28069 C...Parameter statement to help give large particle numbers.
28070 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28072 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28073 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28074 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28075 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28077 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
28079 C...Local variables.
28080 EXTERNAL PYSIMP,PYLAMF
28082 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
28083 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
28084 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
28085 DOUBLE PRECISION SUMME(0:100),A(4,8)
28086 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
28087 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
28088 DOUBLE PRECISION XMGLU,GAM
28089 DOUBLE PRECISION PYSIMP,PYLAMF
28090 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
28091 &DDD(2),EEE(2),FFF(2)
28092 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
28093 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
28094 DOUBLE PRECISION AMC(2),AMN(4)
28096 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
28097 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
28099 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
28102 DATA IFIRST/.TRUE./
28105 SINB=TANB/SQRT(1D0+TANB**2)
28116 AMTOP=PYRNMT(PMAS(6,1))
28119 FAKT1=AMBOT/W2/AMW/COSB
28120 FAKT2=AMTOP/W2/AMW/SINB
28125 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
28126 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
28127 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
28128 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
28129 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
28130 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
28131 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
28132 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
28134 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
28135 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
28136 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
28137 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
28142 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
28143 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
28144 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
28145 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
28147 COS2A=COSA**2-SINA**2
28148 SIN2A=SINA*COSA*2D0
28149 COS2C=COSC**2-SINC**2
28150 SIN2C=SINC*COSC*2D0
28157 ALPHAW=PYALEM(XMG2)
28158 ALPHAS=PYALPS(XMG2)
28162 XMQ2=XMG2+XMT2+XMB2+XMR2
28163 XMQ4=XMG*XMT*XMB*XMR
28164 XMQ3=XMG2*XMR2+XMT2*XMB2
28165 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
28166 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
28168 XMST(1)=AMST(1)*AMST(1)
28169 XMST(2)=AMST(1)*AMST(1)
28170 XMST(3)=AMST(2)*AMST(2)
28171 XMST(4)=AMST(2)*AMST(2)
28172 XMSB(1)=AMSB(1)*AMSB(1)
28173 XMSB(2)=AMSB(2)*AMSB(2)
28174 XMSB(3)=AMSB(1)*AMSB(1)
28175 XMSB(4)=AMSB(2)*AMSB(2)
28177 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
28178 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
28179 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
28180 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
28181 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
28182 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
28183 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
28184 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
28186 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
28187 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
28188 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
28189 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
28190 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
28191 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
28192 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
28193 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
28195 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
28196 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
28197 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
28198 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
28199 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
28200 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
28201 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
28202 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
28204 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
28205 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
28206 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
28207 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
28208 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
28209 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
28210 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
28211 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
28213 SMAX=(XMG-ABS(XMR))**2
28214 SMIN=(XMB+XMT)**2+0.1D0
28217 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
28218 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
28220 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
28221 W=DSQRT(W)/2D0/SBAR
28222 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
28223 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
28224 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
28225 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
28226 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
28227 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
28228 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
28229 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
28230 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
28231 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
28232 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
28233 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
28234 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
28235 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
28236 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
28237 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
28238 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
28239 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
28240 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
28241 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
28242 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
28243 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
28244 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
28245 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
28246 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
28247 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
28248 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
28249 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
28250 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
28251 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
28252 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
28253 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
28254 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
28255 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
28256 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
28257 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
28258 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
28259 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
28260 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
28261 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
28262 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
28263 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
28264 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
28266 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
28267 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
28268 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
28269 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
28270 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
28271 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
28272 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
28273 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
28274 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
28275 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
28276 & -A(J,6)*(XMG2+XMR2-SBAR)
28277 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
28278 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
28279 & /(GRS+XMSB(J)+XMST(J))
28283 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
28284 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
28289 C*********************************************************************
28291 *$ CREATE PYNJDC.FOR
28294 C...Calculates decay widths for the neutralinos (admixtures of
28295 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
28297 C...Input: KCIN = KF code for particle
28298 C...Output: XLAM = widths
28299 C... IDLAM = KF codes for decay particles
28300 C... IKNT = number of decay channels defined
28301 C...AUTHOR: STEPHEN MRENNA
28303 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
28304 C...when CHIGAMMA .NE. 0
28305 C...10 FEB 96: Calculate this decay for small tan(beta)
28307 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
28309 C...Double precision and integer declarations.
28310 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28311 INTEGER PYK,PYCHGE,PYCOMP
28312 C...Parameter statement to help give large particle numbers.
28313 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28315 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28316 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28317 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28318 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28320 COMMON/PYINTS/XXM(20)
28321 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
28323 C...Local variables.
28325 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
28326 &XMZ,XMZ2,AXMJ,AXMI
28327 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
28328 DOUBLE PRECISION S12MIN,S12MAX
28329 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
28330 DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
28331 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
28332 DOUBLE PRECISION PYX2XH,PYX2XG
28333 DOUBLE PRECISION XLAM(0:200)
28334 INTEGER IDLAM(200,3)
28335 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
28336 INTEGER ITH(3),KF1,KF2
28338 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
28339 DOUBLE PRECISION SR2
28340 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
28341 DOUBLE PRECISION GAMCON,XMT1,XMT2
28342 DOUBLE PRECISION PYALEM,PI,PYALPS
28343 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
28344 DOUBLE PRECISION RAT1,RAT2
28345 DOUBLE PRECISION T3T,CA,CB,FCOL
28346 DOUBLE PRECISION ALFA,BETA,TANB
28347 DOUBLE PRECISION PYGAUS,PYXXGA
28348 EXTERNAL PYXXW5,PYGAUS,PYXXZ5
28349 DOUBLE PRECISION PREC
28350 INTEGER KFNCHI(4),KFCCHI(2)
28351 DATA ETAH/1D0,1D0,-1D0/
28355 DATA PI/3.141592654D0/
28356 DATA SR2/1.4142136D0/
28357 DATA KFNCHI/1000022,1000023,1000025,1000035/
28358 DATA KFCCHI/1000024,1000037/
28360 C...COUNT THE NUMBER OF DECAY MODES
28368 TANW = SQRT(XW/(1D0-XW))
28370 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
28373 IF(KFIN.EQ.KFNCHI(2)) IX=2
28374 IF(KFIN.EQ.KFNCHI(3)) IX=3
28375 IF(KFIN.EQ.KFNCHI(4)) IX=4
28393 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
28394 IF(IX.EQ.1.AND.IMSS(11).EQ.0) THEN
28398 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
28399 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
28403 GAMCON=AEM**3/8D0/PI/XMW2/XW
28404 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28405 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28406 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28407 IDLAM(LKNT,1)=KSUSY1+22
28410 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
28414 C...GRAVITINO DECAY MODES
28416 IF(IMSS(11).EQ.1) THEN
28419 XMGR=PMAS(PYCOMP(IDG),1)
28422 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
28423 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
28428 XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2
28430 IF(AXMI.GT.XMGR+XMZ) THEN
28435 XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 +
28436 $ .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4
28438 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
28443 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)*
28444 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
28446 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
28451 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)*
28452 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
28454 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
28459 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)*
28460 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
28469 C...CHI0_I -> CHI0_J + GAMMA
28470 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
28471 RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2
28472 RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 )
28473 RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2
28474 RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 )
28475 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
28476 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
28478 IDLAM(LKNT,1)=KFNCHI(IJ)
28481 GAMCON=AEM**3/8D0/PI/XMW2/XW
28482 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28483 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28484 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28488 C...CHI0_I -> CHI0_J + Z0
28489 IF(AXMI.GE.AXMJ+XMZ) THEN
28491 GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28493 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
28494 IDLAM(LKNT,1)=KFNCHI(IJ)
28497 ELSEIF(AXMI.GE.AXMJ) THEN
28505 XXM(5)=PMAS(PYCOMP(KSUSY1+11),1)
28506 XXM(6)=PMAS(PYCOMP(KSUSY2+11),1)
28509 XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28511 XXM(11)=(T3-EI*XW)/(1D0-XW)
28512 XXM(12)=-EI*XW/(1D0-XW)
28513 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28514 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28515 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28516 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28518 S12MAX=(AXMI-AXMJ)**2
28520 C...CHARGED LEPTONS
28521 IF( XXM(5).LT.AXMI ) THEN
28524 IF(XXM(6).LT.AXMI ) THEN
28527 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
28529 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28530 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28531 IDLAM(LKNT,1)=KFNCHI(IJ)
28534 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
28536 XLAM(LKNT)=XLAM(LKNT-1)
28537 IDLAM(LKNT,1)=KFNCHI(IJ)
28543 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28544 XXM(5)=PMAS(PYCOMP(KSUSY1+15),1)
28545 XXM(6)=PMAS(PYCOMP(KSUSY2+15),1)
28547 XXM(6)=PMAS(PYCOMP(KSUSY1+15),1)
28548 XXM(5)=PMAS(PYCOMP(KSUSY2+15),1)
28550 IF( XXM(5).LT.AXMI ) THEN
28553 IF(XXM(6).LT.AXMI ) THEN
28557 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
28559 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28560 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28561 IDLAM(LKNT,1)=KFNCHI(IJ)
28571 XXM(5)=PMAS(PYCOMP(KSUSY1+12),1)
28573 XXM(11)=(T3-EI*XW)/(1D0-XW)
28574 XXM(12)=-EI*XW/(1D0-XW)
28575 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28576 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28577 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28578 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28580 IF( XXM(5).LT.AXMI ) THEN
28585 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28586 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28587 IDLAM(LKNT,1)=KFNCHI(IJ)
28591 XLAM(LKNT)=XLAM(LKNT-1)
28592 IDLAM(LKNT,1)=KFNCHI(IJ)
28596 XXM(5)=PMAS(PYCOMP(KSUSY1+16),1)
28597 IF( XXM(5).LT.AXMI ) THEN
28601 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28602 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28603 IDLAM(LKNT,1)=KFNCHI(IJ)
28609 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28610 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28615 XXM(11)=(T3-EI*XW)/(1D0-XW)
28616 XXM(12)=-EI*XW/(1D0-XW)
28617 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28618 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28619 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28620 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28622 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140
28623 IF( XXM(5).LT.AXMI ) THEN
28625 ELSEIF( XXM(6).LT.AXMI ) THEN
28628 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
28630 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28631 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28632 IDLAM(LKNT,1)=KFNCHI(IJ)
28635 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
28637 XLAM(LKNT)=XLAM(LKNT-1)
28638 IDLAM(LKNT,1)=KFNCHI(IJ)
28644 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
28645 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
28646 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
28648 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
28649 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
28651 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150
28652 IF(XXM(5).LT.AXMI) THEN
28654 ELSEIF(XXM(6).LT.AXMI) THEN
28657 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
28659 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28660 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28661 IDLAM(LKNT,1)=KFNCHI(IJ)
28668 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
28669 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
28674 XXM(11)=(T3-EI*XW)/(1D0-XW)
28675 XXM(12)=-EI*XW/(1D0-XW)
28676 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28677 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28678 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28679 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28681 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160
28682 IF(XXM(5).LT.AXMI) THEN
28684 ELSEIF(XXM(6).LT.AXMI) THEN
28687 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
28689 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28690 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28691 IDLAM(LKNT,1)=KFNCHI(IJ)
28694 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
28696 XLAM(LKNT)=XLAM(LKNT-1)
28697 IDLAM(LKNT,1)=KFNCHI(IJ)
28705 C...CHI0_I -> CHI0_J + H0_K
28713 QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)-
28714 & TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1))
28715 RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)-
28716 & TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1))
28719 XMH=PMAS(ITH(IH),1)
28721 IF(AXMI.GE.AXMJ+XMH) THEN
28723 XL=PYLAMF(XMI2,XMJ2,XMH2)
28724 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
28726 C...SIGN OF MASSES I,J
28728 IF(IH.EQ.3) XMK=-XMK
28729 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
28730 IDLAM(LKNT,1)=KFNCHI(IJ)
28731 IDLAM(LKNT,2)=ITH(IH)
28737 C...CHI0_I -> CHI+_J + W-
28742 IF(AXMI.GE.AXMJ+XMW) THEN
28744 GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28745 GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28746 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
28747 IDLAM(LKNT,1)=KFCCHI(IJ)
28751 XLAM(LKNT)=XLAM(LKNT-1)
28752 IDLAM(LKNT,1)=-KFCCHI(IJ)
28755 ELSEIF(AXMI.GE.AXMJ) THEN
28757 S12MAX=(AXMI-AXMJ)**2
28758 XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28759 XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28765 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28769 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28777 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
28778 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
28779 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190
28780 IF(XXM(11).LT.AXMI) THEN
28782 ELSEIF(XXM(12).LT.AXMI) THEN
28785 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
28787 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28788 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28789 IDLAM(LKNT,1)=KFCCHI(IJ)
28793 XLAM(LKNT)=XLAM(LKNT-1)
28794 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28795 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28796 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28797 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
28799 XLAM(LKNT)=XLAM(LKNT-1)
28800 IDLAM(LKNT,1)=KFCCHI(IJ)
28804 XLAM(LKNT)=XLAM(LKNT-1)
28805 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28806 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28807 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28811 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28812 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
28813 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28815 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
28816 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28819 IF(XXM(11).LT.AXMI) THEN
28822 IF(XXM(12).LT.AXMI) THEN
28825 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
28827 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28828 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28829 XLAM(LKNT)=XLAM(LKNT-1)
28830 IDLAM(LKNT,1)=KFCCHI(IJ)
28834 XLAM(LKNT)=XLAM(LKNT-1)
28835 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28836 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28837 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28840 C...NOW, DO THE QUARKS
28845 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28849 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28851 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
28852 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
28853 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210
28854 IF(XXM(11).LT.AXMI) THEN
28856 ELSEIF(XXM(12).LT.AXMI) THEN
28859 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
28861 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
28862 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28863 IDLAM(LKNT,1)=KFCCHI(IJ)
28867 XLAM(LKNT)=XLAM(LKNT-1)
28868 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28869 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28870 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28871 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
28873 XLAM(LKNT)=XLAM(LKNT-1)
28874 IDLAM(LKNT,1)=KFCCHI(IJ)
28878 XLAM(LKNT)=XLAM(LKNT-1)
28879 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28880 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28881 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28889 C...CHI0_I -> CHI+_I + H-
28896 IF(AXMI.GE.AXMJ+XMHP) THEN
28898 GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+
28899 & ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2)
28900 GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+
28901 & ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2)
28902 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
28903 IDLAM(LKNT,1)=KFCCHI(IJ)
28904 IDLAM(LKNT,2)=-ITHC
28907 XLAM(LKNT)=XLAM(LKNT-1)
28908 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28909 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28910 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28916 C...2-BODY DECAYS TO FERMION SFERMION
28918 IF(J.GE.7.AND.J.LE.10) GOTO 250
28921 XMSF1=PMAS(PYCOMP(KF1),1)
28922 XMSF2=PMAS(PYCOMP(KF2),1)
28932 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
28933 IF(MOD(J,2).EQ.0) THEN
28934 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28935 AL=XMF*ZMIX(IX,4)/XMW/SBETA
28936 AR=-2D0*EI*TANW*ZMIX(IX,1)
28939 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28940 AL=XMF*ZMIX(IX,3)/XMW/CBETA
28941 AR=-2D0*EI*TANW*ZMIX(IX,1)
28946 IF(AXMI.GE.XMF+XMSF1) THEN
28950 XL=PYLAMF(XMI2,XMA2,XMB2)
28951 CA=AL*SFMIX(J,1)+AR*SFMIX(J,2)
28952 CB=BL*SFMIX(J,1)+BR*SFMIX(J,2)
28953 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28954 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28959 XLAM(LKNT)=XLAM(LKNT-1)
28960 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28961 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28966 IF(AXMI.GE.XMF+XMSF2) THEN
28970 CA=AL*SFMIX(J,3)+AR*SFMIX(J,4)
28971 CB=BL*SFMIX(J,3)+BR*SFMIX(J,4)
28972 XL=PYLAMF(XMI2,XMA2,XMB2)
28973 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28974 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28979 XLAM(LKNT)=XLAM(LKNT-1)
28980 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28981 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28986 C...3-BODY DECAY TO Q Q~ GLUINO
28987 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
28988 IF(AXMI.GE.XMJ) THEN
28994 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28995 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
29001 S12MAX=(AXMI-AXMJ)**2
29002 C...ALL QUARKS BUT T
29006 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
29008 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
29009 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 260
29010 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
29012 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
29013 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29014 IDLAM(LKNT,1)=KSUSY1+21
29017 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
29019 XLAM(LKNT)=XLAM(LKNT-1)
29020 IDLAM(LKNT,1)=KSUSY1+21
29026 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
29027 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
29028 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
29030 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
29031 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
29033 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270
29034 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
29036 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
29037 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29038 IDLAM(LKNT,1)=KSUSY1+21
29044 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
29045 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
29047 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
29049 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
29050 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280
29051 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
29053 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
29054 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29055 IDLAM(LKNT,1)=KSUSY1+21
29058 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
29060 XLAM(LKNT)=XLAM(LKNT-1)
29061 IDLAM(LKNT,1)=KSUSY1+21
29072 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
29073 XLAM(0)=XLAM(0)+XLAM(I)
29075 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
29080 C*********************************************************************
29082 *$ CREATE PYCJDC.FOR
29085 C...Calculate decay widths for the charginos (admixtures of
29086 C...charged Wino and charged Higgsino.
29088 C...Input: KCIN = KF code for particle
29089 C...Output: XLAM = widths
29090 C... IDLAM = KF codes for decay particles
29091 C... IKNT = number of decay channels defined
29092 C...AUTHOR: STEPHEN MRENNA
29094 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
29095 C...when CHIENU .NE. 0
29097 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
29099 C...Double precision and integer declarations.
29100 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29101 INTEGER PYK,PYCHGE,PYCOMP
29102 C...Parameter statement to help give large particle numbers.
29103 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29105 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29106 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29107 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29108 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29110 COMMON/PYINTS/XXM(20)
29111 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
29113 C...Local variables.
29115 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
29116 &XMZ,XMZ2,AXMJ,AXMI
29117 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
29118 DOUBLE PRECISION S12MIN,S12MAX
29119 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
29120 DOUBLE PRECISION PYLAMF,XL
29121 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
29122 DOUBLE PRECISION PYX2XH,PYX2XG
29123 DOUBLE PRECISION XLAM(0:200)
29124 INTEGER IDLAM(200,3)
29125 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
29128 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
29129 DOUBLE PRECISION SR2
29130 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
29132 DOUBLE PRECISION PYALEM,PI,PYALPS
29133 DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
29134 DOUBLE PRECISION CA,CB,FCOL
29135 INTEGER KF1,KF2,ISF
29136 INTEGER KFNCHI(4),KFCCHI(2)
29138 DOUBLE PRECISION TEMP
29139 DOUBLE PRECISION PYGAUS
29140 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
29141 DOUBLE PRECISION PREC
29144 DATA ETAH/1D0,1D0,-1D0/
29145 DATA SR2/1.4142136D0/
29146 DATA PI/3.141592654D0/
29148 DATA KFNCHI/1000022,1000023,1000025,1000035/
29149 DATA KFCCHI/1000024,1000037/
29151 C...COUNT THE NUMBER OF DECAY MODES
29158 TANW = SQRT(XW/(1D0-XW))
29160 C...1 OR 2 DEPENDING ON CHARGINO TYPE
29162 IF(KFIN.EQ.KFCCHI(2)) IX=2
29178 C...GRAVITINO DECAY MODES
29180 IF(IMSS(11).EQ.1) THEN
29183 XMGR=PMAS(PYCOMP(IDG),1)
29186 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
29187 IF(AXMI.GT.XMGR+XMW) THEN
29192 XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+
29193 & .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))*
29194 & (1D0-XMW2/XMI2)**4
29196 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
29201 XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+
29202 & (UMIX(IX,2)*SBETA)**2))
29203 & *(1D0-PMAS(37,1)**2/XMI2)**4
29207 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
29208 IF(IX.EQ.1) GOTO 150
29213 C...CHI_2+ -> CHI_1+ + Z0
29214 IF(AXMI.GE.AXMJ+XMZ) THEN
29216 GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)
29217 GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)
29218 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
29219 IDLAM(LKNT,1)=KFCCHI(1)
29223 C...CHARGED LEPTONS
29224 ELSEIF(AXMI.GE.AXMJ) THEN
29225 XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2))
29226 XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2))
29234 S12MAX=(AXMJ-AXMI)**2
29235 XXM(7)= (-0.5D0+XW)/(1D0-XW)
29236 XXM(8)= XW/(1D0-XW)
29237 XXM(11)=PMAS(PYCOMP(KSUSY1+12),1)
29238 XXM(12)=VMIX(2,1)*VMIX(1,1)
29239 IF( XXM(11).LT.AXMI ) THEN
29242 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
29244 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29245 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29246 IDLAM(LKNT,1)=KFCCHI(1)
29249 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
29251 XLAM(LKNT)=XLAM(LKNT-1)
29252 IDLAM(LKNT,1)=KFCCHI(1)
29255 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
29257 XLAM(LKNT)=XLAM(LKNT-1)
29258 IDLAM(LKNT,1)=KFCCHI(1)
29267 XXM(7)= (0.5D0)/(1D0-XW)
29269 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29270 XXM(12)=UMIX(2,1)*UMIX(1,1)
29271 IF( XXM(11).LT.AXMI ) THEN
29274 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
29276 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29277 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29278 IDLAM(LKNT,1)=KFCCHI(1)
29282 XLAM(LKNT)=XLAM(LKNT-1)
29283 IDLAM(LKNT,1)=KFCCHI(1)
29287 XLAM(LKNT)=XLAM(LKNT-1)
29288 IDLAM(LKNT,1)=KFCCHI(1)
29295 XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW)
29296 XXM(8)= XW/3D0/(1D0-XW)
29297 XXM(11)=PMAS(PYCOMP(KSUSY1+2),1)
29298 XXM(12)=VMIX(2,1)*VMIX(1,1)
29299 IF( XXM(11).LT.AXMI ) GOTO 120
29300 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
29302 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29303 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29304 IDLAM(LKNT,1)=KFCCHI(1)
29307 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
29309 XLAM(LKNT)=XLAM(LKNT-1)
29310 IDLAM(LKNT,1)=KFCCHI(1)
29313 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
29315 XLAM(LKNT)=XLAM(LKNT-1)
29316 IDLAM(LKNT,1)=KFCCHI(1)
29325 XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW)
29326 XXM(8)= -2D0*XW/3D0/(1D0-XW)
29327 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29328 XXM(12)=UMIX(2,1)*UMIX(1,1)
29329 IF( XXM(11).LT.AXMI ) GOTO 130
29330 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
29332 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29333 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29334 IDLAM(LKNT,1)=KFCCHI(1)
29337 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
29339 XLAM(LKNT)=XLAM(LKNT-1)
29340 IDLAM(LKNT,1)=KFCCHI(1)
29348 C...CHI_2+ -> CHI_1+ + H0_K
29356 XMH=PMAS(ITH(IH),1)
29358 C...NO 3-BODY OPTION
29359 IF(AXMI.GE.AXMJ+XMH) THEN
29361 XL=PYLAMF(XMI2,XMJ2,XMH2)
29362 F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) -
29363 & VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2
29364 F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) -
29365 & VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2
29367 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
29368 IDLAM(LKNT,1)=KFCCHI(1)
29369 IDLAM(LKNT,2)=ITH(IH)
29374 C...CHI1 JUMPS TO HERE
29377 C...CHI+_I -> CHI0_J + W+
29382 IF(AXMI.GE.AXMJ+XMW) THEN
29384 GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2
29385 GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2
29386 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
29387 IDLAM(LKNT,1)=KFNCHI(IJ)
29392 ELSEIF(AXMI.GE.AXMJ) THEN
29395 S12MIN=(XMF1+XMF2)**2
29396 S12MAX=(AXMJ-AXMI)**2
29397 XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1)
29398 XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1)
29402 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29406 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29414 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29415 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
29417 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
29418 C...--> 1/(16PI)/M**3*(AEM/XW)**2
29420 IF(XXM(11).LT.AXMI) THEN
29423 IF(XXM(12).LT.AXMI) THEN
29426 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
29428 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29429 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29430 IDLAM(LKNT,1)=KFNCHI(IJ)
29434 C...ONLY DECAY CHI+1 -> E+ NU_E
29435 IF( IMSS(12).NE. 0 ) GOTO 220
29436 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
29438 XXM(11)=PMAS(PYCOMP(KSUSY1+13),1)
29439 XXM(12)=PMAS(PYCOMP(KSUSY1+14),1)
29440 IF(XXM(11).LT.AXMI) THEN
29442 ELSEIF(XXM(12).LT.AXMI) THEN
29445 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29446 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29447 IDLAM(LKNT,1)=KFNCHI(IJ)
29450 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
29452 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
29453 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
29455 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
29457 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
29458 IF(XXM(11).LT.AXMI) THEN
29461 IF(XXM(12).LT.AXMI) THEN
29464 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29465 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29466 IDLAM(LKNT,1)=KFNCHI(IJ)
29473 C...NOW, DO THE QUARKS
29478 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29482 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29484 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29485 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29486 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170
29487 IF(XXM(11).LT.AXMI) THEN
29489 ELSEIF(XXM(12).LT.AXMI) THEN
29492 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29494 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29495 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29496 IDLAM(LKNT,1)=KFNCHI(IJ)
29499 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29501 XLAM(LKNT)=XLAM(LKNT-1)
29502 IDLAM(LKNT,1)=KFNCHI(IJ)
29511 C...CHI+_I -> CHI0_J + H+
29518 IF(AXMI.GE.AXMJ+XMHP) THEN
29520 GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+
29521 & ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2)
29522 GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+
29523 & ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2)
29524 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
29525 IDLAM(LKNT,1)=KFNCHI(IJ)
29533 C...2-BODY DECAYS TO FERMION SFERMION
29535 IF(J.GE.7.AND.J.LE.10) GOTO 200
29536 IF(MOD(J,2).EQ.0) THEN
29542 XMSF1=PMAS(PYCOMP(KF1),1)
29543 XMSF2=PMAS(PYCOMP(KF2),1)
29552 IF(MOD(J,2).EQ.0) THEN
29555 BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2
29556 AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2
29562 BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2
29564 AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2
29569 IF(AXMI.GE.XMF+XMSF1) THEN
29573 XL=PYLAMF(XMI2,XMA2,XMB2)
29574 CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2)
29575 CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2)
29576 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29577 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29579 IF(MOD(J,2).EQ.0) THEN
29589 IF(AXMI.GE.XMF+XMSF2) THEN
29593 CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4)
29594 CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4)
29595 XL=PYLAMF(XMI2,XMA2,XMB2)
29596 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29597 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29599 IF(MOD(J,2).EQ.0) THEN
29609 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
29610 C...A 2-BODY -- 2-BODY CHAIN
29611 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
29612 IF(AXMI.GE.XMJ) THEN
29615 S12MAX=(AXMI-AXMJ)**2
29624 XXM(7)=UMIX(IX,1)*SR2
29625 XXM(8)=VMIX(IX,1)*SR2
29626 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29627 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29628 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210
29629 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29631 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
29632 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29633 IDLAM(LKNT,1)=KSUSY1+21
29636 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29638 XLAM(LKNT)=XLAM(LKNT-1)
29639 IDLAM(LKNT,1)=KSUSY1+21
29650 XLAM(0)=XLAM(0)+XLAM(I)
29651 IF(XLAM(I).LT.0D0) THEN
29652 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
29653 & (IDLAM(I,J),J=1,3)
29657 IF(XLAM(0).EQ.0D0) THEN
29659 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
29660 WRITE(MSTU(11),*) LKNT
29661 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
29667 C*********************************************************************
29669 *$ CREATE PYXXZ5.FOR
29672 C...Calculates chi0 -> chi0 + f + ~f.
29676 C...Double precision and integer declarations.
29677 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29678 INTEGER PYK,PYCHGE,PYCOMP
29679 C...Parameter statement to help give large particle numbers.
29680 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29682 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29683 COMMON/PYINTS/XXM(20)
29684 SAVE /PYDAT1/,/PYINTS/
29686 C...Local variables.
29687 DOUBLE PRECISION PYXXZ5,X
29688 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
29689 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
29690 DOUBLE PRECISION SIJ
29691 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
29692 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
29693 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29695 DATA SR2/1.4142136D0/
29697 C...Statement functions.
29698 C...Integral from x to y of (t-a)(b-t) dt.
29699 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29700 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29701 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29702 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29703 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29704 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29705 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29706 C...Integral from x to y of (t-a)/(b-t) dt.
29707 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29708 C...Integral from x to y of 1/(t-a) dt.
29709 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29717 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29718 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29719 &( (X-XM22-S)**2 -4D0*XM22*S ) )
29721 S23MIN=(S23AVE-S23DEL)
29722 S23MAX=(S23AVE+S23DEL)
29741 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
29742 SIJ=2D0*XXM(2)*XXM(4)*S13
29744 IF(XMV.LE.1000D0) THEN
29745 WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S)
29746 & +SIJ*(S23MAX-S23MIN) )/WPROP2
29747 IF(XXM(5).LE.10000D0) THEN
29748 WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29749 & + SIJ*TPROP(S23MAX,S23MIN,XMSD) )
29750 WFL1=WFL1*(S13-XMV**2)/WPROP2
29754 IF(XXM(6).LE.10000D0) THEN
29755 WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29756 & + SIJ*TPROP(S23MAX,S23MIN,XMSU) )
29757 WFL2=WFL2*(S13-XMV**2)/WPROP2
29766 IF(XXM(5).LE.10000D0) THEN
29767 WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29768 & + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) )
29772 IF(XXM(6).LE.10000D0) THEN
29773 WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29774 & + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) )
29781 PYXXZ5=(WW+WF1+WF2+WFL1+WFL2)
29782 IF(PYXXZ5.LT.0D0) THEN
29783 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 '
29784 WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4)
29785 WRITE(MSTU(11),*) (XXM(I),I=5,8)
29786 WRITE(MSTU(11),*) (XXM(I),I=9,12)
29787 WRITE(MSTU(11),*) (XXM(I),I=13,16)
29788 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
29789 WRITE(MSTU(11),*) S23MIN,S23MAX
29796 C*********************************************************************
29798 *$ CREATE PYXXW5.FOR
29801 C...Calculates chi0(+) -> chi+(0) + f + ~f'.
29805 C...Double precision and integer declarations.
29806 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29807 INTEGER PYK,PYCHGE,PYCOMP
29808 C...Parameter statement to help give large particle numbers.
29809 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29812 COMMON/PYINTS/XXM(20)
29813 SAVE /PYDAT1/,/PYINTS/
29815 C...Local variables.
29816 DOUBLE PRECISION PYXXW5,X
29817 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
29818 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
29819 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
29820 DOUBLE PRECISION SIJ
29821 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29825 DATA SR2/1.4142136D0/
29827 C...Statement functions.
29828 C...Integral from x to y of (t-a)(b-t) dt.
29829 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29830 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29831 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29832 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29833 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29834 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29835 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29836 C...Integral from x to y of (t-a)/(b-t) dt.
29837 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29838 C...Integral from x to y of 1/(t-a) dt.
29839 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29846 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
29847 S23AVE=0.5D0*(XM22+S-S13)
29848 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
29850 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29851 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29852 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
29854 S23MIN=(S23AVE-S23DEL)
29855 S23MAX=(S23AVE+S23DEL)
29856 IF(S23DEL.LT.1D-3) THEN
29869 WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2)
29870 SIJ=S13*XXM(2)*XXM(4)
29871 IF(XMV.LE.1000D0) THEN
29872 WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S)
29873 & -2D0*OL*OR*SIJ*(S23MAX-S23MIN)
29875 IF(XXM(11).LE.10000D0) THEN
29876 WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD)
29877 & -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29879 WWD=WWD*(S13-XMV**2)/WPROP2
29883 IF(XXM(12).LE.10000D0) THEN
29884 WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU)
29885 & -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29887 WWU=WWU*(S13-XMV**2)/WPROP2
29896 IF(XXM(12).LE.10000D0) THEN
29897 WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29901 IF(XXM(11).LE.10000D0) THEN
29902 WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29906 IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN
29907 WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU)
29912 PYXXW5=WW+WU+WD+WWU+WWD+WUD
29914 IF(PYXXW5.LT.0D0) THEN
29916 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 '
29917 WRITE(MSTU(11),*) WW,WU,WD
29918 WRITE(MSTU(11),*) WWD,WWU,WUD
29919 WRITE(MSTU(11),*) SQRT(S13)
29920 WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S)
29929 C*********************************************************************
29931 *$ CREATE PYXXGA.FOR
29934 C...Calculates chi0_i -> chi0_j + gamma.
29936 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
29938 C...Double precision and integer declarations.
29939 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29940 INTEGER PYK,PYCHGE,PYCOMP
29942 C...Local variables.
29943 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
29944 DOUBLE PRECISION F1,F2
29946 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
29947 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
29948 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
29949 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
29954 C*********************************************************************
29956 *$ CREATE PYX2XG.FOR
29959 C...Calculates the decay rate for ino -> ino + gauge boson.
29961 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
29963 C...Double precision and integer declarations.
29964 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29965 INTEGER PYK,PYCHGE,PYCOMP
29967 C...Local variables.
29968 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
29969 DOUBLE PRECISION XL,PYLAMF,C1
29970 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
29976 XL=PYLAMF(XMI2,XMJ2,XMV2)
29977 PYX2XG=C1/8D0/XMI3*SQRT(XL)
29978 &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
29979 &12D0*GL*GR*XM1*XM2*XMV2)
29984 C*********************************************************************
29986 *$ CREATE PYX2XH.FOR
29989 C...Calculates the decay rate for ino -> ino + H.
29991 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR)
29993 C...Double precision and integer declarations.
29994 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29995 INTEGER PYK,PYCHGE,PYCOMP
29997 C...Local variables.
29998 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
29999 DOUBLE PRECISION XL,PYLAMF,C1
30000 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
30006 XL=PYLAMF(XMI2,XMJ2,XMV2)
30007 PYX2XH=C1/8D0/XMI3*SQRT(XL)
30008 &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+
30009 &4D0*GL*GR*XM1*XM2)
30014 C*********************************************************************
30016 *$ CREATE PYXXZ2.FOR
30019 C...Calculates chi+ -> chi+ + f + ~f.
30023 C...Double precision and integer declarations.
30024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30025 INTEGER PYK,PYCHGE,PYCOMP
30026 C...Parameter statement to help give large particle numbers.
30027 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30029 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30030 COMMON/PYINTS/XXM(20)
30031 SAVE /PYDAT1/,/PYINTS/
30033 C...Local variables.
30034 DOUBLE PRECISION PYXXZ2,X
30035 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
30036 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
30037 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
30038 DOUBLE PRECISION SIJ
30039 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
30040 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
30042 DATA SR2/1.4142136D0/
30044 C...Statement functions.
30045 C...Integral from x to y of (t-a)(b-t) dt.
30046 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
30047 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
30048 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
30049 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
30050 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
30051 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
30052 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
30053 C...Integral from x to y of 1/(t-a) dt.
30054 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
30061 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
30062 S23AVE=0.5D0*(XM22+S-S13)
30063 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
30065 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
30066 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
30067 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
30069 S23MIN=(S23AVE-S23DEL)
30070 S23MAX=(S23AVE+S23DEL)
30071 IF(S23DEL.LT.1D-3) THEN
30089 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
30090 SIJ=XXM(2)*XXM(4)*S13
30091 WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S)
30092 &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN)
30094 IF(XMSL.GT.1D4*S) THEN
30098 WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL)
30099 WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)-
30100 & OR*SIJ*TPROP(S23MAX,S23MIN,XMSL)
30101 WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2
30105 IF(PYXXZ2.LT.0D0) THEN
30106 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 '
30107 WRITE(MSTU(11),*) WW,WD,WWD
30108 WRITE(MSTU(11),*) S23MIN,S23MAX
30109 WRITE(MSTU(11),*) (XXM(I),I=1,4)
30110 WRITE(MSTU(11),*) (XXM(I),I=5,8)
30111 WRITE(MSTU(11),*) (XXM(I),I=9,12)
30118 C*********************************************************************
30120 *$ CREATE PYHEXT.FOR
30123 C...Calculates the non-standard decay modes of the Higgs boson.
30125 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
30127 C...Double precision and integer declarations.
30128 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30129 INTEGER PYK,PYCHGE,PYCOMP
30130 C...Parameter statement to help give large particle numbers.
30131 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30133 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30134 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30135 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30136 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
30137 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
30139 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
30141 C...Local variables.
30143 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
30144 &XMZ,XMZ2,AXMJ,AXMI
30145 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
30146 DOUBLE PRECISION S12MIN,S12MAX
30147 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
30148 DOUBLE PRECISION PYLAMF,XL,CF,EI
30149 INTEGER IDU,IC,ILR,IFL
30150 DOUBLE PRECISION TANW,XW,AEM,C1,AS
30151 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
30152 DOUBLE PRECISION XLAM(0:200)
30153 INTEGER IDLAM(200,3)
30154 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
30156 INTEGER KFNCHI(4),KFCCHI(2)
30157 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
30158 DOUBLE PRECISION SR2
30159 DOUBLE PRECISION BETA,ALFA
30160 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
30161 DOUBLE PRECISION PYALEM,PI,PYALPS
30162 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
30163 DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
30164 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
30165 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
30166 DATA ITH/25,35,36,37/
30167 DATA ETAH/1D0,1D0,-1D0/
30168 DATA SR2/1.4142136D0/
30169 DATA PI/3.141592654D0/
30170 DATA KFNCHI/1000022,1000023,1000025,1000035/
30171 DATA KFCCHI/1000024,1000037/
30173 C...COUNT THE NUMBER OF DECAY MODES
30181 TANW = SQRT(XW/(1D0-XW))
30184 C...1 - 4 DEPENDING ON Higgs species.
30186 IF(KFIN.EQ.ITH(2)) IH=2
30187 IF(KFIN.EQ.ITH(3)) IH=3
30188 IF(KFIN.EQ.ITH(4)) IH=4
30210 IF(IH.EQ.4) GOTO 180
30212 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
30213 C...H0_K -> CHI0_I + CHI0_J
30226 IF(AXMI.GE.AXMJ+AXMK) THEN
30229 & EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2)
30230 & -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+
30231 & 0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2)
30232 & -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) )
30234 & EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2)
30235 & -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+
30236 & 0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2)
30237 & -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) )
30238 C...SIGN OF MASSES I,J
30240 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30241 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
30242 IDLAM(LKNT,1)=KFNCHI(IJ)
30243 IDLAM(LKNT,2)=KFNCHI(IK)
30249 C...H0_K -> CHI+_I CHI-_J
30256 IF(AXMI.GE.AXMJ+AXMK) THEN
30258 F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) -
30259 & VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2
30260 F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) -
30261 & VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2
30263 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30264 IDLAM(LKNT,1)=KFCCHI(IJ)
30265 IDLAM(LKNT,2)=-KFCCHI(IK)
30271 C...HIGGS TO SFERMION SFERMION
30273 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160
30275 XMJL=PMAS(PYCOMP(IJ),1)
30276 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
30277 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
30280 XL=PYLAMF(XMI2,XMJ2,XMJ2)
30287 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
30288 & XMF**2/XMW*SINA/CBETA
30289 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
30290 & XMF**2/XMW*SINA/CBETA
30292 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30294 ELSEIF(IFL.EQ.15) THEN
30295 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30301 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
30302 & XMF**2/XMW*COSA/SBETA
30303 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
30304 & XMF**2/XMW*COSA/SBETA
30306 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
30313 ELSEIF(IH.EQ.2) THEN
30315 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
30316 & XMF**2/XMW*COSA/CBETA
30317 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30318 & XMF**2/XMW*COSA/CBETA
30320 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30322 ELSEIF(IFL.EQ.15) THEN
30323 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30329 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
30330 & XMF**2/XMW*SINA/SBETA
30331 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30332 & XMF**2/XMW*SINA/SBETA
30334 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
30341 ELSEIF(IH.EQ.3) THEN
30347 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
30348 ELSEIF(IFL.EQ.15) THEN
30349 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
30353 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
30357 IF(IH.EQ.3) GOTO 140
30361 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
30368 IF(AXMI.GE.2D0*XMJ) THEN
30370 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30372 & +2D0*GHLR*ALR)**2
30378 IF(AXMI.GE.2D0*XMJR) THEN
30382 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
30385 XL=PYLAMF(XMI2,XMJ2,XMJ2)
30386 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30388 & +2D0*GHLR*ALR)**2
30389 IDLAM(LKNT,1)=IJ+KSUSY1
30390 IDLAM(LKNT,2)=-(IJ+KSUSY1)
30395 IF(AXMI.GE.XMJL+XMJR) THEN
30397 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
30398 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
30399 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
30402 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
30403 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30404 & (GHLL*AL+GHRR*AR)**2
30406 IDLAM(LKNT,2)=-(IJ+KSUSY1)
30410 IDLAM(LKNT,2)=IJ+KSUSY1
30412 XLAM(LKNT)=XLAM(LKNT-1)
30422 C...H+ -> CHI+_I + CHI0_J
30431 IF(AXMI.GE.AXMJ+AXMK) THEN
30433 GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)*
30434 & TANW)*VMIX(IK,2)/SR2)
30435 GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)*
30436 & TANW)*UMIX(IK,2)/SR2)
30437 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR)
30438 IDLAM(LKNT,1)=KFNCHI(IJ)
30439 IDLAM(LKNT,2)=KFCCHI(IK)
30445 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
30446 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
30452 XM1=PMAS(PYCOMP(KSUSY1+6),1)
30453 XM2=PMAS(PYCOMP(KSUSY1+5),1)
30454 IF(XMI.GE.XM1+XM2) THEN
30455 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30457 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30458 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
30459 IDLAM(LKNT,1)=KSUSY1+6
30460 IDLAM(LKNT,2)=-(KSUSY1+5)
30465 XM1=PMAS(PYCOMP(KSUSY2+6),1)
30466 XM2=PMAS(PYCOMP(KSUSY1+5),1)
30467 IF(XMI.GE.XM1+XM2) THEN
30468 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30470 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30471 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
30472 IDLAM(LKNT,1)=KSUSY2+6
30473 IDLAM(LKNT,2)=-(KSUSY1+5)
30478 XM1=PMAS(PYCOMP(KSUSY1+6),1)
30479 XM2=PMAS(PYCOMP(KSUSY2+5),1)
30480 IF(XMI.GE.XM1+XM2) THEN
30481 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30483 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30484 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
30485 IDLAM(LKNT,1)=KSUSY1+6
30486 IDLAM(LKNT,2)=-(KSUSY2+5)
30491 XM1=PMAS(PYCOMP(KSUSY2+6),1)
30492 XM2=PMAS(PYCOMP(KSUSY2+5),1)
30493 IF(XMI.GE.XM1+XM2) THEN
30494 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30496 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30497 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
30498 IDLAM(LKNT,1)=KSUSY2+6
30499 IDLAM(LKNT,2)=-(KSUSY2+5)
30504 GL=-XMW/SR2*SIN(2D0*BETA)
30506 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30507 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30508 IF(XMI.GE.XM1+XM2) THEN
30509 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30511 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30512 IDLAM(LKNT,1)=-(KSUSY1+IJ)
30513 IDLAM(LKNT,2)=KSUSY1+IJ+1
30521 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30522 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30523 IF(XMI.GE.XM1+XM2) THEN
30524 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30526 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30527 IDLAM(LKNT,1)=-(KSUSY1+IJ)
30528 IDLAM(LKNT,2)=KSUSY1+IJ+1
30533 C...H+ -> TAU1 NUTAUL
30534 XM1=PMAS(PYCOMP(KSUSY1+15),1)
30535 XM2=PMAS(PYCOMP(KSUSY1+16),1)
30536 IF(XMI.GE.XM1+XM2) THEN
30537 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30539 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2
30540 IDLAM(LKNT,1)=-(KSUSY1+15)
30541 IDLAM(LKNT,2)= KSUSY1+16
30545 C...H+ -> TAU2 NUTAUL
30546 XM1=PMAS(PYCOMP(KSUSY2+15),1)
30547 XM2=PMAS(PYCOMP(KSUSY1+16),1)
30548 IF(XMI.GE.XM1+XM2) THEN
30549 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30551 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2
30552 IDLAM(LKNT,1)=-(KSUSY2+15)
30553 IDLAM(LKNT,2)= KSUSY1+16
30561 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
30562 XLAM(0)=XLAM(0)+XLAM(I)
30564 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
30569 C*********************************************************************
30571 *$ CREATE PYH2XX.FOR
30574 C...Calculates the decay rate for a Higgs to an ino pair.
30576 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR)
30578 C...Double precision and integer declarations.
30579 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30580 INTEGER PYK,PYCHGE,PYCOMP
30582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30585 C...Local variables.
30586 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
30587 DOUBLE PRECISION XL,PYLAMF,C1
30588 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
30594 XL=PYLAMF(XMI2,XMJ2,XMK2)
30595 PYH2XX=C1/4D0/XMI3*SQRT(XL)
30596 &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)-
30597 &4D0*GL*GR*XM3*XM2)
30598 IF(PYH2XX.LT.0D0) THEN
30599 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
30600 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3
30607 C*********************************************************************
30609 *$ CREATE PYGAUS.FOR
30612 C...Integration by adaptive Gaussian quadrature.
30613 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
30615 FUNCTION PYGAUS(F, A, B, EPS)
30617 C...Double precision and integer declarations.
30618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30619 INTEGER PYK,PYCHGE,PYCOMP
30621 C...Local declarations.
30623 DOUBLE PRECISION W(12), X(12)
30624 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
30625 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
30626 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
30627 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
30628 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
30629 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
30630 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
30631 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
30632 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
30633 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
30634 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
30635 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
30637 C...The Gaussian quadrature algorithm.
30639 IF(B .EQ. A) GO TO 140
30640 CONST = 5D-3 / ABS(B-A)
30651 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
30656 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
30659 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
30661 IF(BB .NE. B) GO TO 100
30664 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110
30666 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
30675 C*********************************************************************
30677 *$ CREATE PYSIMP.FOR
30680 C...Simpson formula for an integral.
30682 FUNCTION PYSIMP(Y,X0,X1,N)
30684 C...Double precision and integer declarations.
30685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30686 INTEGER PYK,PYCHGE,PYCOMP
30688 C...Local variables.
30689 DOUBLE PRECISION Y,X0,X1,H,S
30695 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
30702 C*********************************************************************
30704 *$ CREATE PYLAMF.FOR
30707 C...The standard lambda function.
30709 FUNCTION PYLAMF(X,Y,Z)
30711 C...Double precision and integer declarations.
30712 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30713 INTEGER PYK,PYCHGE,PYCOMP
30715 C...Local variables.
30716 DOUBLE PRECISION PYLAMF,X,Y,Z
30718 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
30719 IF(PYLAMF.LT.0D0) PYLAMF=0D0
30724 C*********************************************************************
30726 *$ CREATE PYTBDY.FOR
30729 C...Generates 3-body decays of gauginos.
30731 SUBROUTINE PYTBDY(XM)
30733 C...Double precision and integer declarations.
30734 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30735 INTEGER PYK,PYCHGE,PYCOMP
30736 C...Parameter statement to help give large particle numbers.
30737 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30739 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30740 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30741 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30742 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
30743 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30744 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/
30746 C...Local variables.
30747 DOUBLE PRECISION XM(5)
30748 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
30749 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
30750 DOUBLE PRECISION CPHI1,SPHI1
30751 DOUBLE PRECISION S23DEL,EPS
30752 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
30753 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
30754 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
30758 S12MIN=(XM(1)+XM(2))**2
30759 S12MAX=(XM(5)-XM(3))**2
30760 YJACO1=S12MAX-S12MIN
30765 BX=S12MIN+0.5D0*YJACO1
30768 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
30776 C...SOLVE FOR F1 AND F2
30777 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30778 &-(2D0*XM(1)*XM(2))**2
30779 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30780 &-(2D0*XM(3)*XM(5))**2
30783 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30785 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30786 &-(2D0*XM(1)*XM(2))**2
30787 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30788 &-(2D0*XM(3)*XM(5))**2
30791 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30794 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
30800 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30801 & -(2D0*XM(1)*XM(2))**2
30802 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30803 & -(2D0*XM(3)*XM(5))**2
30806 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30813 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30814 & -(2D0*XM(1)*XM(2))**2
30815 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30816 & -(2D0*XM(3)*XM(5))**2
30819 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30824 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
30834 110 S12=S12MIN+PYR(0)*YJACO1
30837 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
30838 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
30839 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
30840 &-(2D0*XM(1)*XM(2))**2
30841 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
30842 &-(2D0*XM(3)*XM(5))**2
30845 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12)
30847 S23MIN=S23AVE-S23DEL
30848 S23MAX=S23AVE+S23DEL
30849 YJACO2=S23MAX-S23MIN
30850 S23=S23MIN+PYR(0)*YJACO2
30852 C...CHECK THE SAMPLING
30853 IF(IKNT.GT.100) THEN
30854 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
30857 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110
30858 120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
30859 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
30861 P1=SQRT(D1*D1-XM(1)**2)
30862 P2=SQRT(D2*D2-XM(2)**2)
30863 P3=SQRT(D3*D3-XM(3)**2)
30864 CTHE1=2D0*PYR(0)-1D0
30865 ANG1=2D0*PYR(0)*PARU(1)
30869 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30871 P(N+1,1)=P1*STHE1*CPHI1
30872 P(N+1,2)=P1*STHE1*SPHI1
30877 ANG3=2D0*PYR(0)*PARU(1)
30880 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
30882 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30884 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
30885 &+P3*STHE3*SPHI3*SPHI1
30886 &+P3*CTHE3*STHE1*CPHI1
30887 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
30888 &-P3*STHE3*SPHI3*CPHI1
30889 &+P3*CTHE3*STHE1*SPHI1
30890 P(N+3,3)=P3*STHE3*CPHI3*STHE1
30895 P(N+2,I)=-P(N+1,I)-P(N+3,I)
30902 C*********************************************************************
30904 *$ CREATE PY1ENT.FOR
30907 C...Stores one parton/particle in commonblock PYJETS.
30909 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
30911 C...Double precision and integer declarations.
30912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30913 INTEGER PYK,PYCHGE,PYCOMP
30915 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30916 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30917 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30918 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30920 C...Standard checks.
30922 IF(MSTU(12).GE.1) CALL PYLIST(0)
30923 IPA=MAX(1,IABS(IP))
30924 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
30925 &'(PY1ENT:) writing outside PYJETS memory')
30927 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
30929 C...Find mass. Reset K, P and V vectors.
30931 IF(MSTU(10).EQ.1) PM=P(IPA,5)
30932 IF(MSTU(10).GE.2) PM=PYMASS(KF)
30939 C...Store parton/particle in K and P vectors.
30941 IF(IP.LT.0) K(IPA,1)=2
30944 P(IPA,4)=MAX(PE,PM)
30945 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
30946 P(IPA,1)=PA*SIN(THE)*COS(PHI)
30947 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
30948 P(IPA,3)=PA*COS(THE)
30950 C...Set N. Optionally fragment/decay.
30952 IF(IP.EQ.0) CALL PYEXEC
30957 C*********************************************************************
30959 *$ CREATE PY2ENT.FOR
30962 C...Stores two partons/particles in their CM frame,
30963 C...with the first along the +z axis.
30965 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
30967 C...Double precision and integer declarations.
30968 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30969 INTEGER PYK,PYCHGE,PYCOMP
30971 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30972 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30973 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30974 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30976 C...Standard checks.
30978 IF(MSTU(12).GE.1) CALL PYLIST(0)
30979 IPA=MAX(1,IABS(IP))
30980 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
30981 &'(PY2ENT:) writing outside PYJETS memory')
30984 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
30985 &'(PY2ENT:) unknown flavour code')
30987 C...Find masses. Reset K, P and V vectors.
30989 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
30990 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
30992 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
30993 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31002 C...Check flavours.
31003 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31004 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31005 IF(MSTU(19).EQ.1) THEN
31008 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
31009 & '(PY2ENT:) unphysical flavour combination')
31014 C...Store partons/particles in K vectors for normal case.
31017 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
31020 C...Store partons in K vectors for parton shower evolution.
31024 K(IPA,4)=MSTU(5)*(IPA+1)
31026 K(IPA+1,4)=MSTU(5)*IPA
31027 K(IPA+1,5)=K(IPA+1,4)
31030 C...Check kinematics and store partons/particles in P vectors.
31031 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
31032 &'(PY2ENT:) energy smaller than sum of masses')
31033 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
31036 P(IPA,4)=SQRT(PM1**2+PA**2)
31039 P(IPA+1,4)=SQRT(PM2**2+PA**2)
31042 C...Set N. Optionally fragment/decay.
31044 IF(IP.EQ.0) CALL PYEXEC
31049 C*********************************************************************
31051 *$ CREATE PY3ENT.FOR
31054 C...Stores three partons or particles in their CM frame,
31055 C...with the first along the +z axis and the third in the (x,z)
31056 C...plane with x > 0.
31058 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
31060 C...Double precision and integer declarations.
31061 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31062 INTEGER PYK,PYCHGE,PYCOMP
31064 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31065 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31066 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31067 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31069 C...Standard checks.
31071 IF(MSTU(12).GE.1) CALL PYLIST(0)
31072 IPA=MAX(1,IABS(IP))
31073 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
31074 &'(PY3ENT:) writing outside PYJETS memory')
31078 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
31079 &'(PY3ENT:) unknown flavour code')
31081 C...Find masses. Reset K, P and V vectors.
31083 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
31084 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
31086 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
31087 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31089 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
31090 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
31099 C...Check flavours.
31100 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31101 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31102 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
31103 IF(MSTU(19).EQ.1) THEN
31105 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
31106 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
31107 & KQ1+KQ3.EQ.4)) THEN
31109 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
31115 C...Store partons/particles in K vectors for normal case.
31118 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
31120 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
31123 C...Store partons in K vectors for parton shower evolution.
31129 IF(KQ1.EQ.-1) KCS=5
31130 K(IPA,KCS)=MSTU(5)*(IPA+1)
31131 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
31132 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
31133 K(IPA+1,9-KCS)=MSTU(5)*IPA
31134 K(IPA+2,KCS)=MSTU(5)*IPA
31135 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
31138 C...Check kinematics.
31140 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
31141 &0.5D0*X3*PECM.LE.PM3) MKERR=1
31142 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
31143 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
31144 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
31145 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
31146 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
31147 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
31148 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
31149 IF(MKERR.NE.0) CALL PYERRM(13,
31150 &'(PY3ENT:) unphysical kinematical variable setup')
31152 C...Store partons/particles in P vectors.
31154 P(IPA,4)=SQRT(PA1**2+PM1**2)
31156 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
31157 P(IPA+2,3)=PA3*CTHE3
31158 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
31160 P(IPA+1,1)=-P(IPA+2,1)
31161 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
31162 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
31165 C...Set N. Optionally fragment/decay.
31167 IF(IP.EQ.0) CALL PYEXEC
31172 C*********************************************************************
31174 *$ CREATE PY4ENT.FOR
31177 C...Stores four partons or particles in their CM frame, with
31178 C...the first along the +z axis, the last in the xz plane with x > 0
31179 C...and the second having y < 0 and y > 0 with equal probability.
31181 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
31183 C...Double precision and integer declarations.
31184 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31185 INTEGER PYK,PYCHGE,PYCOMP
31187 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31188 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31189 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31190 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31192 C...Standard checks.
31194 IF(MSTU(12).GE.1) CALL PYLIST(0)
31195 IPA=MAX(1,IABS(IP))
31196 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
31197 &'(PY4ENT:) writing outside PYJETS momory')
31202 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
31203 &'(PY4ENT:) unknown flavour code')
31205 C...Find masses. Reset K, P and V vectors.
31207 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
31208 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
31210 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
31211 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31213 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
31214 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
31216 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
31217 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
31226 C...Check flavours.
31227 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31228 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31229 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
31230 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
31231 IF(MSTU(19).EQ.1) THEN
31233 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
31234 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
31235 & KQ1+KQ4.EQ.4)) THEN
31236 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
31239 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
31246 C...Store partons/particles in K vectors for normal case.
31249 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
31251 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
31254 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
31257 C...Store partons for parton shower evolution from q-g-g-qbar or
31259 ELSEIF(KQ1+KQ2.NE.0) THEN
31265 IF(KQ1.EQ.-1) KCS=5
31266 K(IPA,KCS)=MSTU(5)*(IPA+1)
31267 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
31268 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
31269 K(IPA+1,9-KCS)=MSTU(5)*IPA
31270 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
31271 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
31272 K(IPA+3,KCS)=MSTU(5)*IPA
31273 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
31275 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
31281 K(IPA,4)=MSTU(5)*(IPA+1)
31283 K(IPA+1,4)=MSTU(5)*IPA
31284 K(IPA+1,5)=K(IPA+1,4)
31285 K(IPA+2,4)=MSTU(5)*(IPA+3)
31286 K(IPA+2,5)=K(IPA+2,4)
31287 K(IPA+3,4)=MSTU(5)*(IPA+2)
31288 K(IPA+3,5)=K(IPA+3,4)
31291 C...Check kinematics.
31293 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
31294 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
31296 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
31297 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
31298 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
31299 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
31300 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
31301 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
31302 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
31303 STHE4=SQRT(1D0-CTHE4**2)
31304 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
31305 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
31306 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
31307 STHE2=SQRT(1D0-CTHE2**2)
31308 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
31309 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
31310 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
31311 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
31312 IF(MKERR.EQ.1) CALL PYERRM(13,
31313 &'(PY4ENT:) unphysical kinematical variable setup')
31315 C...Store partons/particles in P vectors.
31317 P(IPA,4)=SQRT(PA1**2+PM1**2)
31319 P(IPA+3,1)=PA4*STHE4
31320 P(IPA+3,3)=PA4*CTHE4
31321 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
31323 P(IPA+1,1)=PA2*STHE2*CPHI2
31324 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
31325 P(IPA+1,3)=PA2*CTHE2
31326 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
31328 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
31329 P(IPA+2,2)=-P(IPA+1,2)
31330 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
31331 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
31334 C...Set N. Optionally fragment/decay.
31336 IF(IP.EQ.0) CALL PYEXEC
31341 C*********************************************************************
31343 *$ CREATE PYJOIN.FOR
31346 C...Connects a sequence of partons with colour flow indices,
31347 C...as required for subsequent shower evolution (or other operations).
31349 SUBROUTINE PYJOIN(NJOIN,IJOIN)
31351 C...Double precision and integer declarations.
31352 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31353 INTEGER PYK,PYCHGE,PYCOMP
31355 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31356 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31357 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31358 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31362 C...Check that partons are of right types to be connected.
31363 IF(NJOIN.LT.2) GOTO 120
31367 IF(I.LE.0.OR.I.GT.N) GOTO 120
31368 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
31370 IF(KC.EQ.0) GOTO 120
31371 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
31372 IF(KQ.EQ.0) GOTO 120
31373 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
31374 IF(KQ.NE.2) KQSUM=KQSUM+KQ
31375 IF(IJN.EQ.1) KQS=KQ
31377 IF(KQSUM.NE.0) GOTO 120
31379 C...Connect the partons sequentially (closing for gluon loop).
31381 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
31385 IF(IJN.NE.1) IP=IJOIN(IJN-1)
31386 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
31387 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
31388 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
31389 K(I,KCS)=MSTU(5)*IN
31390 K(I,9-KCS)=MSTU(5)*IP
31391 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
31392 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
31395 C...Error exit: no action taken.
31397 120 CALL PYERRM(12,
31398 &'(PYJOIN:) given entries can not be joined by one string')
31403 C*********************************************************************
31405 *$ CREATE PYGIVE.FOR
31408 C...Sets values of commonblock variables.
31410 SUBROUTINE PYGIVE(CHIN)
31412 C...Double precision and integer declarations.
31413 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31414 INTEGER PYK,PYCHGE,PYCOMP
31416 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31417 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31418 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31419 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31420 COMMON/PYDAT4/CHAF(500,2)
31422 COMMON/PYDATR/MRPY(6),RRPY(100)
31423 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31424 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31425 COMMON/PYINT1/MINT(400),VINT(400)
31426 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31427 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31428 COMMON/PYINT4/MWID(500),WIDS(500,5)
31429 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
31430 COMMON/PYINT6/PROC(0:500)
31432 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
31433 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
31435 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31436 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
31437 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
31438 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/
31439 C...Local arrays and character variables.
31440 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
31441 &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10,
31443 DIMENSION MSVAR(49,8)
31445 C...For each variable to be translated give: name,
31446 C...integer/real/character, no. of indices, lower&upper index bounds.
31447 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
31448 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
31449 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
31450 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
31451 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
31452 &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
31453 DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
31454 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
31455 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31456 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
31457 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
31458 &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
31459 &1,1,1,6,4*0, 2,1,1,100,4*0,
31460 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
31461 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31462 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
31463 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
31464 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
31465 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
31466 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
31467 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
31468 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
31469 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
31470 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
31472 C...Length of character variable. Subdivide it into instructions.
31473 IF(MSTU(12).GE.1) CALL PYLIST(0)
31477 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
31480 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
31482 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
31487 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
31489 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
31491 C...Identify commonblock variable.
31494 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
31495 &LNAM.LE.6) GOTO 140
31496 CHNAM=CHBIT(1:LNAM-1)//' '
31497 DO 160 LCOM=1,LNAM-1
31499 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
31500 & CHALP(2)(LALP:LALP)
31505 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
31508 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
31510 IF(LLOW.LT.LTOT) GOTO 120
31514 C...Identify any indices.
31519 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
31522 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
31524 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
31525 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17))
31527 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
31528 READ(CHIND,'(I8)') KF
31530 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
31532 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
31535 IF(LLOW.LT.LTOT) GOTO 120
31538 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31539 READ(CHIND,'(I8)') I1
31542 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31545 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31548 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
31550 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31551 READ(CHIND,'(I8)') I2
31553 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31556 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31559 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
31561 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31562 READ(CHIND,'(I8)') I3
31567 C...Check that indices allowed.
31569 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
31570 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
31572 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
31574 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
31576 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
31578 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
31581 IF(LLOW.LT.LTOT) GOTO 120
31585 C...Save old value of variable.
31588 ELSEIF(IVAR.EQ.2) THEN
31590 ELSEIF(IVAR.EQ.3) THEN
31592 ELSEIF(IVAR.EQ.4) THEN
31594 ELSEIF(IVAR.EQ.5) THEN
31596 ELSEIF(IVAR.EQ.6) THEN
31598 ELSEIF(IVAR.EQ.7) THEN
31600 ELSEIF(IVAR.EQ.8) THEN
31602 ELSEIF(IVAR.EQ.9) THEN
31604 ELSEIF(IVAR.EQ.10) THEN
31606 ELSEIF(IVAR.EQ.11) THEN
31608 ELSEIF(IVAR.EQ.12) THEN
31610 ELSEIF(IVAR.EQ.13) THEN
31612 ELSEIF(IVAR.EQ.14) THEN
31614 ELSEIF(IVAR.EQ.15) THEN
31616 ELSEIF(IVAR.EQ.16) THEN
31618 ELSEIF(IVAR.EQ.17) THEN
31620 ELSEIF(IVAR.EQ.18) THEN
31622 ELSEIF(IVAR.EQ.19) THEN
31624 ELSEIF(IVAR.EQ.20) THEN
31626 ELSEIF(IVAR.EQ.21) THEN
31628 ELSEIF(IVAR.EQ.22) THEN
31630 ELSEIF(IVAR.EQ.23) THEN
31632 ELSEIF(IVAR.EQ.24) THEN
31634 ELSEIF(IVAR.EQ.25) THEN
31636 ELSEIF(IVAR.EQ.26) THEN
31638 ELSEIF(IVAR.EQ.27) THEN
31640 ELSEIF(IVAR.EQ.28) THEN
31642 ELSEIF(IVAR.EQ.29) THEN
31644 ELSEIF(IVAR.EQ.30) THEN
31646 ELSEIF(IVAR.EQ.31) THEN
31648 ELSEIF(IVAR.EQ.32) THEN
31650 ELSEIF(IVAR.EQ.33) THEN
31651 IOLD=ICOL(I1,I2,I3)
31652 ELSEIF(IVAR.EQ.34) THEN
31654 ELSEIF(IVAR.EQ.35) THEN
31656 ELSEIF(IVAR.EQ.36) THEN
31658 ELSEIF(IVAR.EQ.37) THEN
31660 ELSEIF(IVAR.EQ.38) THEN
31662 ELSEIF(IVAR.EQ.39) THEN
31664 ELSEIF(IVAR.EQ.40) THEN
31666 ELSEIF(IVAR.EQ.41) THEN
31668 ELSEIF(IVAR.EQ.42) THEN
31669 ROLD=SIGT(I1,I2,I3)
31670 ELSEIF(IVAR.EQ.43) THEN
31672 ELSEIF(IVAR.EQ.44) THEN
31674 ELSEIF(IVAR.EQ.45) THEN
31676 ELSEIF(IVAR.EQ.46) THEN
31678 ELSEIF(IVAR.EQ.47) THEN
31680 ELSEIF(IVAR.EQ.48) THEN
31682 ELSEIF(IVAR.EQ.49) THEN
31686 C...Print current value of variable. Loop back.
31687 IF(LNAM.GE.LBIT) THEN
31689 CHBIT(15:60)=' has the value '
31690 IF(MSVAR(IVAR,1).EQ.1) THEN
31691 WRITE(CHBIT(51:60),'(I10)') IOLD
31692 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31693 WRITE(CHBIT(47:60),'(F14.5)') ROLD
31694 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31699 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31701 IF(LLOW.LT.LTOT) GOTO 120
31705 C...Read in new variable value.
31706 IF(MSVAR(IVAR,1).EQ.1) THEN
31708 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
31709 READ(CHINI,'(I10)') INEW
31710 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31712 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
31714 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31715 CHNEW=CHBIT(LNAM+1:LBIT)//' '
31717 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
31720 C...Store new variable value.
31723 ELSEIF(IVAR.EQ.2) THEN
31725 ELSEIF(IVAR.EQ.3) THEN
31727 ELSEIF(IVAR.EQ.4) THEN
31729 ELSEIF(IVAR.EQ.5) THEN
31731 ELSEIF(IVAR.EQ.6) THEN
31733 ELSEIF(IVAR.EQ.7) THEN
31735 ELSEIF(IVAR.EQ.8) THEN
31737 ELSEIF(IVAR.EQ.9) THEN
31739 ELSEIF(IVAR.EQ.10) THEN
31741 ELSEIF(IVAR.EQ.11) THEN
31743 ELSEIF(IVAR.EQ.12) THEN
31745 ELSEIF(IVAR.EQ.13) THEN
31747 ELSEIF(IVAR.EQ.14) THEN
31749 ELSEIF(IVAR.EQ.15) THEN
31751 ELSEIF(IVAR.EQ.16) THEN
31753 ELSEIF(IVAR.EQ.17) THEN
31755 ELSEIF(IVAR.EQ.18) THEN
31757 ELSEIF(IVAR.EQ.19) THEN
31759 ELSEIF(IVAR.EQ.20) THEN
31761 ELSEIF(IVAR.EQ.21) THEN
31763 ELSEIF(IVAR.EQ.22) THEN
31765 ELSEIF(IVAR.EQ.23) THEN
31767 ELSEIF(IVAR.EQ.24) THEN
31769 ELSEIF(IVAR.EQ.25) THEN
31771 ELSEIF(IVAR.EQ.26) THEN
31773 ELSEIF(IVAR.EQ.27) THEN
31775 ELSEIF(IVAR.EQ.28) THEN
31777 ELSEIF(IVAR.EQ.29) THEN
31779 ELSEIF(IVAR.EQ.30) THEN
31781 ELSEIF(IVAR.EQ.31) THEN
31783 ELSEIF(IVAR.EQ.32) THEN
31785 ELSEIF(IVAR.EQ.33) THEN
31786 ICOL(I1,I2,I3)=INEW
31787 ELSEIF(IVAR.EQ.34) THEN
31789 ELSEIF(IVAR.EQ.35) THEN
31791 ELSEIF(IVAR.EQ.36) THEN
31793 ELSEIF(IVAR.EQ.37) THEN
31795 ELSEIF(IVAR.EQ.38) THEN
31797 ELSEIF(IVAR.EQ.39) THEN
31799 ELSEIF(IVAR.EQ.40) THEN
31801 ELSEIF(IVAR.EQ.41) THEN
31803 ELSEIF(IVAR.EQ.42) THEN
31804 SIGT(I1,I2,I3)=RNEW
31805 ELSEIF(IVAR.EQ.43) THEN
31807 ELSEIF(IVAR.EQ.44) THEN
31809 ELSEIF(IVAR.EQ.45) THEN
31811 ELSEIF(IVAR.EQ.46) THEN
31813 ELSEIF(IVAR.EQ.47) THEN
31815 ELSEIF(IVAR.EQ.48) THEN
31817 ELSEIF(IVAR.EQ.49) THEN
31821 C...Write old and new value. Loop back.
31823 CHBIT(15:60)=' changed from to '
31824 IF(MSVAR(IVAR,1).EQ.1) THEN
31825 WRITE(CHBIT(33:42),'(I10)') IOLD
31826 WRITE(CHBIT(51:60),'(I10)') INEW
31827 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31828 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31829 WRITE(CHBIT(29:42),'(F14.5)') ROLD
31830 WRITE(CHBIT(47:60),'(F14.5)') RNEW
31831 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31832 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31835 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31837 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
31838 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
31841 IF(LLOW.LT.LTOT) GOTO 120
31843 C...Format statement for output on unit MSTU(11) (by default 6).
31844 5000 FORMAT(5X,A60)
31845 5100 FORMAT(5X,A88)
31850 C*********************************************************************
31852 *$ CREATE PYEXEC.FOR
31855 C...Administrates the fragmentation and decay chain.
31859 C...Double precision and integer declarations.
31860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31861 INTEGER PYK,PYCHGE,PYCOMP
31863 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31864 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31865 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31866 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31867 COMMON/PYINT4/MWID(500),WIDS(500,5)
31868 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
31870 DIMENSION PS(2,6),IJOIN(100)
31872 C...Initialize and reset.
31874 IF(MSTU(12).GE.1) CALL PYLIST(0)
31875 MSTU(31)=MSTU(31)+1
31879 IF(MSTU(17).LE.0) MSTU(90)=0
31882 C...Sum up momentum, energy and charge for starting entries.
31890 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
31892 PS(1,J)=PS(1,J)+P(I,J)
31894 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
31898 C...Prepare system for subsequent fragmentation/decay.
31901 C...Loop through jet fragmentation and particle decays.
31907 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
31910 C...Deal with any remaining undecayed resonance
31911 C...(normally the task of PYEVNT, so seldom used).
31912 ELSEIF(MWID(KC).NE.0) THEN
31914 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
31917 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
31918 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
31921 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
31922 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
31925 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
31934 C...Particle decay if unstable and allowed. Save long-lived particle
31935 C...decays until second pass after Bose-Einstein effects.
31936 ELSEIF(KCHG(KC,2).EQ.0) THEN
31937 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
31938 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
31941 C...Decay products may develop a shower.
31942 IF(MSTJ(92).GT.0) THEN
31944 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
31945 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
31946 CALL PYSHOW(IP1,IP1+1,QMAX)
31949 ELSEIF(MSTJ(92).LT.0) THEN
31951 CALL PYSHOW(IP1,-3,P(IP,5))
31956 C...Jet fragmentation: string or independent fragmentation.
31957 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
31959 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
31960 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
31961 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
31962 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
31963 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
31966 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
31967 IF(MFRAG.EQ.2) CALL PYINDF(IP)
31968 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
31969 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
31972 C...Loop back if enough space left in PYJETS and no error abort.
31973 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
31974 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
31976 ELSEIF(IP.LT.N) THEN
31977 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
31980 C...Include simple Bose-Einstein effect parametrization if desired.
31981 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
31986 C...Check that momentum, energy and charge were conserved.
31988 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
31990 PS(2,J)=PS(2,J)+P(I,J)
31992 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
31994 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
31995 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
31996 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
31997 &'(PYEXEC:) four-momentum was not conserved')
31998 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
31999 &'(PYEXEC:) charge was not conserved')
32004 C*********************************************************************
32006 *$ CREATE PYPREP.FOR
32009 C...Rearranges partons along strings. Allows small systems
32010 C...to collapse into one or two particles and checks flavours.
32012 SUBROUTINE PYPREP(IP)
32014 C...Double precision and integer declarations.
32015 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32016 INTEGER PYK,PYCHGE,PYCOMP
32018 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
32019 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32020 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32021 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
32022 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
32024 DIMENSION DPS(5),DPC(5),UE(3)
32026 C...Rearrange parton shower product listing along strings: begin loop.
32029 DO 120 I=MAX(1,IP),N
32030 IF(K(I,1).NE.3) GOTO 120
32032 IF(KC.EQ.0) GOTO 120
32034 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
32036 C...Pick up loose string end.
32038 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
32042 IF(NSTP.GT.4*N) THEN
32043 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
32047 C...Copy undecayed parton.
32048 IF(K(IA,1).EQ.3) THEN
32049 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
32050 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
32055 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
32065 IF(K(I1,1).EQ.1) GOTO 120
32068 C...Go to next parton in colour space.
32070 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
32072 IA=MOD(K(IB,KCS),MSTU(5))
32073 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
32076 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
32077 & MSTU(5)).EQ.0) KCS=9-KCS
32078 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
32079 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
32082 IF(IA.LE.0.OR.IA.GT.N) THEN
32083 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
32086 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
32087 & MSTU(5)).EQ.IB) THEN
32088 IF(MREV.EQ.1) KCS=9-KCS
32089 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
32090 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
32092 IF(MREV.EQ.0) KCS=9-KCS
32093 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
32094 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
32096 IF(IA.NE.I) GOTO 100
32101 IF(MSTJ(14).LT.0) RETURN
32103 C...Find lowest-mass colour singlet jet system, OK if above threshold.
32104 IF(MSTJ(14).EQ.0) GOTO 320
32109 DO 190 I=MAX(1,IP),NS
32110 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
32111 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
32118 DPS(5)=PYMASS(K(I,2))
32119 ELSEIF(K(I,1).EQ.2) THEN
32121 DPS(J)=DPS(J)+P(I,J)
32123 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
32125 DPS(J)=DPS(J)+P(I,J)
32128 DPS(5)=DPS(5)+PYMASS(K(I,2))
32129 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
32144 IF(PDM.GE.PARJ(32)) GOTO 320
32146 C...Fill small-mass system as cluster.
32148 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
32160 C...Form two particles from flavours of lowest-mass system, if feasible.
32163 IF(MSTU(16).NE.2) THEN
32174 IF(IABS(K(IC1,2)).NE.21) THEN
32175 KC1=PYCOMP(K(IC1,2))
32176 KC2=PYCOMP(K(IC2,2))
32177 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
32178 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
32179 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
32180 IF(KQ1+KQ2.NE.0) GOTO 320
32181 C.. Start with qq, if there is one. Only allow for rank 1 popcorn meson
32183 IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
32185 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
32186 CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
32187 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
32189 IF(IABS(K(IC2,2)).NE.21) GOTO 320
32190 C.. No room for popcorn mesons in closed string -> 2 hadrons.
32192 210 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
32193 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
32194 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
32195 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
32197 P(N+2,5)=PYMASS(K(N+2,2))
32198 P(N+3,5)=PYMASS(K(N+3,2))
32199 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
32200 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
32202 C...Perform two-particle decay of jet system, if possible.
32203 IF(PECM.GE.0.02D0*DPC(4)) THEN
32204 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
32205 & (P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
32206 UE(3)=2D0*PYR(0)-1D0
32208 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
32209 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
32214 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
32215 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
32217 CALL PYROBO(N+2,N+3,0D0,0D0,DPC(1)/DPC(4),DPC(2)/DPC(4),
32222 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
32224 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
32225 & P(IC1,3)*P(IC2,3)
32226 IF(NP.GE.3.OR.HA.LE.1.25D0*P(IC1,5)*P(IC2,5)) GOTO 260
32227 HD1=0.5D0*(P(N+2,5)**2-P(IC1,5)**2)
32228 HD2=0.5D0*(P(N+3,5)**2-P(IC2,5)**2)
32229 HR=SQRT(MAX(0D0,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
32230 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1D0
32231 HC=P(IC1,5)**2+2D0*HA+P(IC2,5)**2
32232 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
32233 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
32235 P(N+2,J)=(1D0+HK1)*P(IC1,J)-HK2*P(IC2,J)
32236 P(N+3,J)=(1D0+HK2)*P(IC2,J)-HK1*P(IC1,J)
32250 C...Else form one particle from the flavours available, if possible.
32252 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
32254 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
32255 CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
32257 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
32258 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
32260 IF(K(N+2,2).EQ.0) GOTO 260
32261 P(N+2,5)=PYMASS(K(N+2,2))
32263 C...Find parton/particle which combines to largest extra mass.
32268 IF(IR.NE.0) GOTO 280
32269 DO 270 I=MAX(1,IP),N
32270 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
32271 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
32272 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
32273 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
32274 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
32275 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
32277 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
32278 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
32279 IF(HSR.GT.HSM) THEN
32287 C...Shuffle energy and momentum to put new particle on mass shell.
32292 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
32293 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
32294 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
32296 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
32297 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
32305 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
32309 C...Mark collapsed system and store daughter pointers. Iterate.
32310 300 DO 310 I=IC1,IC2
32311 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(PYCOMP(K(I,2)),2).NE.0)
32314 IF(MSTU(16).NE.2) THEN
32323 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
32325 C...Check flavours and invariant masses in parton systems.
32332 DO 360 I=MAX(1,IP),N
32333 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
32335 IF(KC.EQ.0) GOTO 360
32336 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32337 IF(KQ.EQ.0) GOTO 360
32343 DPS(5)=DPS(5)+PYMASS(K(I,2))
32346 DPS(J)=DPS(J)+P(I,J)
32348 IF(K(I,1).EQ.1) THEN
32349 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
32350 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
32351 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32352 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
32353 & '(PYPREP:) too small mass in jet system')
32355 C IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32356 C & (0.9D0*PARJ(32)+DPS(5))**2)
32357 C & WRITE(*,*) 'I,DPS',I,DPS
32371 C*********************************************************************
32373 *$ CREATE PYSTRF.FOR
32376 C...Handles the fragmentation of an arbitrary colour singlet
32377 C...jet system according to the Lund string fragmentation model.
32379 SUBROUTINE PYSTRF(IP)
32381 C...Double precision and integer declarations.
32382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32383 INTEGER PYK,PYCHGE,PYCOMP
32385 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
32386 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32387 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32388 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
32389 C...Local arrays. All MOPS variables ends with MO
32390 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
32391 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
32392 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
32393 &INMO(9),PM2QMO(2),XTMO(2)
32395 C...Function: four-product of two vectors.
32396 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)
32397 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
32400 C...Reset counters. Identify parton system.
32413 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
32414 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
32415 IF(MSTU(21).GE.1) RETURN
32417 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
32419 IF(KC.EQ.0) GOTO 110
32420 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32421 IF(KQ.EQ.0) GOTO 110
32422 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
32423 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32424 IF(MSTU(21).GE.1) RETURN
32427 C...Take copy of partons to be considered. Check flavour sum.
32432 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
32434 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
32436 IF(KQ.NE.2) KQSUM=KQSUM+KQ
32437 IF(K(I,1).EQ.41) THEN
32439 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
32440 IF(KQSUM.NE.KQ) MJU(2)=N+NP
32442 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
32443 IF(KQSUM.NE.0) THEN
32444 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32445 IF(MSTU(21).GE.1) RETURN
32448 C...Boost copied system to CM frame (for better numerical precision).
32449 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
32452 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
32456 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
32458 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
32459 IF(P(I,3).GT.0D0) THEN
32460 HHPEZ=(P(I,4)+P(I,3))/HHBZ
32461 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
32462 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32464 HHPEZ=(P(I,4)-P(I,3))*HHBZ
32465 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
32466 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32471 C...Search for very nearby partons that may be recombined.
32478 140 IF(NR.GE.3) THEN
32481 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
32483 IF(I.EQ.N+NR) I1=N+1
32484 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
32485 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
32487 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
32489 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
32490 & P(I1,2)**2+P(I1,3)**2))
32491 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
32492 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
32493 IF(PDR.LT.PDRMIN) THEN
32499 C...Recombine very nearby partons to avoid machine precision problems.
32500 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
32502 P(N+1,J)=P(N+1,J)+P(N+NR,J)
32504 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
32508 ELSEIF(PDRMIN.LT.PARU12) THEN
32510 P(IR,J)=P(IR,J)+P(IR+1,J)
32512 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
32514 DO 190 I=IR+1,N+NR-1
32520 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
32522 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
32523 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
32529 C...Reset particle counter. Skip ahead if no junctions are present;
32530 C...this is usually the case!
32531 NRS=MAX(5*NR+11,NP)
32534 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32538 ELSEIF(NTRY.GT.100) THEN
32539 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32540 IF(MSTU(21).GE.1) RETURN
32544 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
32545 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
32546 & ' junction strings not handled by MSTJ(12)>3 options')
32549 IF(MJU(JT).EQ.0) GOTO 570
32552 C...Find and sum up momentum on three sides of junction. Check flavours.
32560 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
32561 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
32566 PJU(IU,J)=PJU(IU,J)+P(I1,J)
32570 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
32572 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
32573 & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
32574 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32575 IF(MSTU(21).GE.1) RETURN
32578 C...Calculate (approximate) boost to rest frame of junction.
32579 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
32580 & (PJU(1,5)*PJU(2,5))
32581 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
32582 & (PJU(1,5)*PJU(3,5))
32583 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
32584 & (PJU(2,5)*PJU(3,5))
32585 T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
32586 T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
32587 TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
32588 T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
32589 T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
32591 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
32593 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
32595 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
32599 C...Put junction at rest if motion could give inconsistencies.
32600 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
32610 C...Start preparing for fragmentation of two strings from junction.
32613 NS=IJU(IU+1)-IJU(IU)
32615 C...Junction strings: find longitudinal string directions.
32620 DP(1,J)=0.5D0*P(IS1,J)
32621 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
32622 DP(2,J)=0.5D0*P(IS2,J)
32623 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
32625 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
32627 IF(IS.EQ.NS) DP(2,5)=0D0
32631 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32632 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32633 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32638 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32639 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32640 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32642 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32644 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32645 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32649 C...Junction strings: initialize flavour, momentum and starting pos.
32653 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32657 ELSEIF(NTRY.GT.100) THEN
32658 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32659 IF(MSTU(21).GE.1) RETURN
32664 IE(1)=K(N+1+(JT/2)*(NP-1),3)
32669 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
32675 KFL(1)=K(IJU(IU),2)
32683 C...Junction strings: find initial transverse directions.
32686 DP(2,J)=P(IN(4)+1,J)
32690 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32691 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32692 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32693 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32694 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32695 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32696 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32697 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32698 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32700 DHCX1=DFOUR(3,1)/DHC12
32701 DHCX2=DFOUR(3,2)/DHC12
32702 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32703 DHCY1=DFOUR(4,1)/DHC12
32704 DHCY2=DFOUR(4,2)/DHC12
32705 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32706 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32708 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32710 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32714 C...Junction strings: produce new particle, origin.
32716 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
32717 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32718 IF(MSTU(21).GE.1) RETURN
32726 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
32727 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
32728 IF(K(I,2).EQ.0) GOTO 320
32729 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
32730 & IABS(KFL(3)).GT.10) THEN
32731 IF(PYR(0).GT.PARJ(19)) GOTO 390
32733 P(I,5)=PYMASS(K(I,2))
32734 CALL PYPTDI(KFL(1),PX(3),PY(3))
32735 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
32736 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
32737 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
32738 & MSTU(90).LT.8) THEN
32739 MSTU(90)=MSTU(90)+1
32740 MSTU(90+MSTU(90))=I
32741 PARU(90+MSTU(90))=Z
32743 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
32748 C...Junction strings: stepping within or from 'low' string region easy.
32749 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
32750 & P(IN(1),5)**2.GE.PR(1)) THEN
32751 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
32752 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
32754 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
32757 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
32758 P(IN(2)+2,4)=P(IN(2)+2,3)
32761 IF(IN(2).GT.N+NR+4*NS) GOTO 320
32762 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32763 P(IN(1)+2,4)=P(IN(1)+2,3)
32769 C...Junction strings: find new transverse directions.
32770 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
32771 & IN(1).GT.IN(2)) GOTO 320
32772 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
32779 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32780 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32782 IF(DHC12.LE.1D-2) THEN
32783 P(IN(1)+2,4)=P(IN(1)+2,3)
32789 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32790 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32791 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32792 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32793 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32794 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32795 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32796 DHCX1=DFOUR(3,1)/DHC12
32797 DHCX2=DFOUR(3,2)/DHC12
32798 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32799 DHCY1=DFOUR(4,1)/DHC12
32800 DHCY2=DFOUR(4,2)/DHC12
32801 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32802 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32804 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32806 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32809 C...Express pT with respect to new axes, if sensible.
32810 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
32811 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
32812 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
32818 C...Junction strings: sum up known four-momentum, coefficients for m2.
32821 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
32822 & PY(3)*P(IN(3)+1,J)
32823 DO 450 IN1=IN(4),IN(1)-4,4
32824 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
32826 DO 460 IN2=IN(5),IN(2)-4,4
32827 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
32831 DHM(2)=2D0*FOUR(I,IN(1))
32832 DHM(3)=2D0*FOUR(I,IN(2))
32833 DHM(4)=2D0*FOUR(IN(1),IN(2))
32835 C...Junction strings: find coefficients for Gamma expression.
32836 DO 490 IN2=IN(1)+1,IN(2),4
32837 DO 480 IN1=IN(1),IN2-1,4
32838 DHC=2D0*FOUR(IN1,IN2)
32839 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
32840 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
32841 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
32842 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
32846 C...Junction strings: solve (m2, Gamma) equation system for energies.
32847 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
32848 IF(ABS(DHS1).LT.1D-4) GOTO 320
32849 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
32850 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
32851 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
32852 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
32853 & ABS(DHS1)-DHS2/DHS1)
32854 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
32855 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
32856 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
32858 C...Junction strings: step to new region if necessary.
32859 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
32860 P(IN(2)+2,4)=P(IN(2)+2,3)
32863 IF(IN(2).GT.N+NR+4*NS) GOTO 320
32864 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32865 P(IN(1)+2,4)=P(IN(1)+2,3)
32870 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
32871 P(IN(1)+2,4)=P(IN(1)+2,3)
32877 C...Junction strings: particle four-momentum, remainder, loop back.
32879 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
32880 & P(IN(2)+2,4)*P(IN(2),J)
32881 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
32883 IF(P(I,4).LT.P(I,5)) GOTO 320
32884 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
32885 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
32886 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
32891 IF(IN(3).NE.IN(6)) THEN
32893 P(IN(6),J)=P(IN(3),J)
32894 P(IN(6)+1,J)=P(IN(3)+1,J)
32899 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
32900 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
32905 C...Junction strings: save quantities left after each string.
32906 IF(IABS(KFL(1)).GT.10) GOTO 320
32910 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
32914 C...Junction strings: put together to new effective string endpoint.
32916 KFJS(JT)=K(K(MJU(JT+2),3),2)
32917 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
32918 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
32919 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
32920 & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
32923 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
32924 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
32926 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
32930 C...Open versus closed strings. Choose breakup region for latter.
32931 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
32934 ELSEIF(MJU(1).NE.0) THEN
32937 ELSEIF(MJU(2).NE.0) THEN
32940 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
32947 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
32948 W2SUM=W2SUM+P(N+NR+IS,1)
32953 W2SUM=W2SUM-P(N+NR+NB,1)
32954 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
32957 C...Find longitudinal string directions (i.e. lightlike four-vectors).
32959 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
32960 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
32963 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
32964 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
32966 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
32967 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
32972 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32975 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
32976 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
32979 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32980 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32981 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32983 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32985 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32986 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32990 C...Begin initialization: sum up energy, set starting position.
32994 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32998 ELSEIF(NTRY.GT.100) THEN
32999 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
33000 IF(MSTU(21).GE.1) RETURN
33007 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
33012 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
33013 IF(NS.GT.NR) IRANK(JT)=1
33014 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
33015 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
33016 IN(3*JT+2)=IN(3*JT+1)+1
33017 IN(3*JT+3)=N+NR+4*NS+2*JT-1
33018 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
33024 C.. MOPS variables and switches
33030 C...Initialize flavour and pT variables for open string.
33034 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
33038 KFL(JT)=K(IE(JT),2)
33039 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
33041 PMQ(JT)=PYMASS(KFL(JT))
33045 C...Closed string: random initial breakup flavour, pT and vertex.
33047 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33049 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
33050 C.. Closed string: first vertex diq attempt => enforced second
33052 IF(IABS(KFL(1)).GT.10)THEN
33057 IF(IBMO.EQ.1) MSTU(121)=-1
33059 CALL PYPTDI(KFL(1),PX(1),PY(1))
33062 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
33063 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
33064 ZR=PR3/(Z*P(N+NR+1,5)**2)
33065 IF(ZR.GE.1D0) GOTO 710
33068 PMQ(JT)=PYMASS(KFL(JT))
33069 GAM(JT)=PR3*(1D0-Z)/Z
33070 IN1=N+NR+3+4*(JT/2)*(NS-1)
33073 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
33076 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
33082 PM2QMO(JT)=PMQ(JT)**2
33083 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
33086 C...Find initial transverse directions (i.e. spacelike four-vectors).
33088 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
33097 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
33098 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
33099 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
33100 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
33101 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
33102 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
33103 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
33104 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
33105 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
33107 DHCX1=DFOUR(3,1)/DHC12
33108 DHCX2=DFOUR(3,2)/DHC12
33109 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
33110 DHCY1=DFOUR(4,1)/DHC12
33111 DHCY2=DFOUR(4,2)/DHC12
33112 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
33113 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
33115 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
33117 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
33122 P(IN3+2,J)=P(IN3,J)
33123 P(IN3+3,J)=P(IN3+1,J)
33128 C...Remove energy used up in junction string fragmentation.
33129 IF(MJU(1)+MJU(2).GT.0) THEN
33131 IF(NJS(JT).EQ.0) GOTO 790
33133 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
33138 C...Produce new particle: side, origin.
33140 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
33141 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
33142 IF(MSTU(21).GE.1) RETURN
33144 C.. New side priority for popcorn systems
33145 IF(MSTU(121).LE.0)THEN
33147 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
33148 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
33152 IRANK(JT)=IRANK(JT)+1
33158 C...Generate flavour, hadron and pT.
33160 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
33161 IF(K(I,2).EQ.0) GOTO 640
33163 IF(MSTU(121).EQ.-1) GOTO 840
33164 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
33165 &IABS(KFL(3)).GT.10) THEN
33166 IF(PYR(0).GT.PARJ(19)) GOTO 810
33168 P(I,5)=PYMASS(K(I,2))
33169 CALL PYPTDI(KFL(JT),PX(3),PY(3))
33170 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
33172 C...Final hadrons for small invariant mass.
33174 PMQ(3)=PYMASS(KFL(3))
33176 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
33177 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
33178 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
33179 &WMIN-0.5D0*PARJ(36)*PMQ(3)
33180 WREM2=FOUR(N+NRS,N+NRS)
33181 IF(WREM2.LT.0.10D0) GOTO 640
33182 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
33183 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
33185 C...Choose z, which gives Gamma. Shift z for heavy flavours.
33186 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
33187 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
33188 &MSTU(90).LT.8) THEN
33189 MSTU(90)=MSTU(90)+1
33190 MSTU(90+MSTU(90))=I
33191 PARU(90+MSTU(90))=Z
33195 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33196 &MOD(KFL2A/1000,10)).GE.4) THEN
33197 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33198 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
33199 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
33200 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33201 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
33203 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
33205 C.. MOPS baryon model modification
33206 XTMO3=(1D0-Z)*XTMO(JT)
33207 IF(IABS(KFL(3)).LE.10) NRVMO=0
33208 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
33212 IF(IABS(KFL(JT)).LE.10)THEN
33213 XBMO=MIN(XTMO3,1D0-(2D-10))
33216 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
33217 GTSTMO=1D0-PARF(192)**PGMO
33219 IF(IRANK(JT).EQ.1) THEN
33224 IF(XBMO.LT.1D0-(1D-10))THEN
33225 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
33226 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
33229 IF(MSTJ(12).GE.5)THEN
33230 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
33231 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
33232 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
33237 C.. MOPS Accepting popcorn system hadron.
33238 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
33239 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
33241 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
33243 & '(PYSTRF:) no more memory left in PYJETS')
33244 IF(MSTU(21).GE.1) RETURN
33256 DO 820 LINE=1,I-N-NR
33257 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
33258 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
33265 C..Reject popcorn system, flag=-1 if enforcing new one
33267 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
33272 C..Lift restoring string outside MOPS block
33273 840 IF(MSTU(121).LT.0) THEN
33274 IF(MSTU(121).EQ.-2) MSTU(121)=0
33277 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
33288 DO 850 LINE=1,I-N-NR
33289 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
33290 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
33298 C.. MOPS end of modification
33304 C...Stepping within or from 'low' string region easy.
33305 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
33306 &P(IN(1),5)**2.GE.PR(JT)) THEN
33307 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
33308 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
33310 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
33313 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
33314 P(IN(JR)+2,4)=P(IN(JR)+2,3)
33317 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33318 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33319 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33325 C...Find new transverse directions (i.e. spacelike string vectors).
33326 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
33327 &IN(1).GT.IN(2)) GOTO 640
33328 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
33335 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
33336 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
33338 IF(DHC12.LE.1D-2) THEN
33339 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33345 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
33346 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
33347 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
33348 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
33349 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
33350 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
33351 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
33352 DHCX1=DFOUR(3,1)/DHC12
33353 DHCX2=DFOUR(3,2)/DHC12
33354 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
33355 DHCY1=DFOUR(4,1)/DHC12
33356 DHCY2=DFOUR(4,2)/DHC12
33357 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
33358 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
33360 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
33362 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
33365 C...Express pT with respect to new axes, if sensible.
33366 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
33367 & FOUR(IN(3*JT+3)+1,IN(3)))
33368 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
33369 & FOUR(IN(3*JT+3)+1,IN(3)+1))
33370 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
33376 C...Sum up known four-momentum. Gives coefficients for m2 expression.
33379 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
33380 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
33381 DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
33382 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
33384 DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
33385 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
33389 DHM(2)=2D0*FOUR(I,IN(1))
33390 DHM(3)=2D0*FOUR(I,IN(2))
33391 DHM(4)=2D0*FOUR(IN(1),IN(2))
33393 C...Find coefficients for Gamma expression.
33394 DO 960 IN2=IN(1)+1,IN(2),4
33395 DO 950 IN1=IN(1),IN2-1,4
33396 DHC=2D0*FOUR(IN1,IN2)
33397 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
33398 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
33399 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
33400 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
33404 C...Solve (m2, Gamma) equation system for energies taken.
33405 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
33406 IF(ABS(DHS1).LT.1D-4) GOTO 640
33407 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
33408 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
33409 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
33410 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
33411 &ABS(DHS1)-DHS2/DHS1)
33412 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
33413 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
33414 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
33416 C...Step to new region if necessary.
33417 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
33418 P(IN(JR)+2,4)=P(IN(JR)+2,3)
33421 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33422 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33423 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33428 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
33429 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33435 C...Four-momentum of particle. Remaining quantities. Loop back.
33437 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
33438 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
33440 IF(P(I,4).LT.P(I,5)) GOTO 640
33446 IF(IN(3).NE.IN(3*JT+3)) THEN
33448 P(IN(3*JT+3),J)=P(IN(3),J)
33449 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
33454 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
33455 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
33459 C...Final hadron: side, flavour, hadron, mass.
33465 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
33466 IF(K(I,2).EQ.0) GOTO 640
33467 P(I,5)=PYMASS(K(I,2))
33468 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33470 C...Final two hadrons: find common setup of four-vectors.
33472 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
33473 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
33474 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
33475 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
33476 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
33477 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
33478 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
33479 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
33480 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
33481 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
33484 C...Solve kinematics for final two hadrons, if possible.
33485 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
33486 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
33487 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
33488 IF(FD.GE.1D0) GOTO 640
33489 FA=WREM2+PR(JT)-PR(JR)
33490 IF(MSTJ(11).NE.2) PREV=0.5D0*EXP(MAX(-50D0,LOG(FD)*PARJ(38)*
33491 &(PR(1)+PR(2))**2))
33492 IF(MSTJ(11).EQ.2) PREV=0.5D0*FD**PARJ(39)
33493 FB=SIGN(SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))),JS*(PYR(0)-PREV))
33496 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33497 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
33498 &4D0*WREM2*PR(JT))),DBLE(JS))
33500 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
33501 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
33502 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
33503 P(I,J)=P(N+NRS,J)-P(I-1,J)
33505 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
33507 C...Mark jets as fragmented and give daughter pointers.
33509 DO 1030 I=NSAV+1,NSAV+NP
33512 IF(MSTU(16).NE.2) THEN
33521 C...Document string system. Move up particles.
33532 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
33536 K(I,J)=K(I+NRS-1,J)
33537 P(I,J)=P(I+NRS-1,J)
33542 DO 1070 IZ=MSTU90+1,MSTU91
33543 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
33544 PARU9T(IZ)=PARU(90+IZ)
33548 C...Order particles in rank along the chain. Update mother pointer.
33551 K(I-NSAV+N,J)=K(I,J)
33552 P(I-NSAV+N,J)=P(I,J)
33556 DO 1120 I=N+1,2*N-NSAV
33557 IF(K(I,3).NE.IE(1)) GOTO 1120
33563 IF(MSTU(16).NE.2) K(I1,3)=NSAV
33564 DO 1110 IZ=MSTU90+1,MSTU91
33565 IF(MSTU9T(IZ).EQ.I) THEN
33566 MSTU(90)=MSTU(90)+1
33567 MSTU(90+MSTU(90))=I1
33568 PARU(90+MSTU(90))=PARU9T(IZ)
33572 DO 1150 I=2*N-NSAV,N+1,-1
33573 IF(K(I,3).EQ.IE(1)) GOTO 1150
33579 IF(MSTU(16).NE.2) K(I1,3)=NSAV
33580 DO 1140 IZ=MSTU90+1,MSTU91
33581 IF(MSTU9T(IZ).EQ.I) THEN
33582 MSTU(90)=MSTU(90)+1
33583 MSTU(90+MSTU(90))=I1
33584 PARU(90+MSTU(90))=PARU9T(IZ)
33589 C...Boost back particle system. Set production vertices.
33592 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
33596 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
33597 IF(P(I,3).GT.0D0) THEN
33598 HHPEZ=(P(I,4)+P(I,3))*HHBZ
33599 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
33600 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33602 HHPEZ=(P(I,4)-P(I,3))/HHBZ
33603 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
33604 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33617 C*********************************************************************
33619 *$ CREATE PYINDF.FOR
33622 C...Handles the fragmentation of a jet system (or a single
33623 C...jet) according to independent fragmentation models.
33625 SUBROUTINE PYINDF(IP)
33627 C...Double precision and integer declarations.
33628 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33629 INTEGER PYK,PYCHGE,PYCOMP
33631 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33632 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33633 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33634 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
33636 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
33637 &KFLO(2),PXO(2),PYO(2),WO(2)
33639 C.. MOPS error message
33640 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
33641 &' are not treated as expected in independent fragmentation')
33643 C...Reset counters. Identify parton system and take copy. Check flavour.
33653 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
33654 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
33655 IF(MSTU(21).GE.1) RETURN
33657 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
33659 IF(KC.EQ.0) GOTO 110
33660 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
33661 IF(KQ.EQ.0) GOTO 110
33663 IF(KQ.NE.2) KQSUM=KQSUM+KQ
33665 K(NSAV+NJET,J)=K(I,J)
33666 P(NSAV+NJET,J)=P(I,J)
33667 DPS(J)=DPS(J)+P(I,J)
33670 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
33671 &K(I+1,1).EQ.2)) GOTO 110
33672 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
33673 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
33674 IF(MSTU(21).GE.1) RETURN
33677 C...Boost copied system to CM frame. Find CM energy and sum flavours.
33680 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
33681 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
33687 DO 140 I=NSAV+1,NSAV+NJET
33691 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
33692 ELSEIF(KFA.GT.1000) THEN
33693 KFLA=MOD(KFA/1000,10)
33694 KFLB=MOD(KFA/100,10)
33695 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
33696 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
33700 C...Loop over attempts made. Reset counters.
33703 IF(NTRY.GT.200) THEN
33704 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
33705 IF(MSTU(21).GE.1) RETURN
33715 C...Loop over jets to be fragmented.
33716 DO 230 IP1=NSAV+1,NSAV+NJET
33721 C...Initial flavour and momentum values. Jet along +z axis.
33722 KFLH=IABS(K(IP1,2))
33723 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
33725 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
33727 C...Initial values for quark or diquark jet.
33728 170 IF(IABS(K(IP1,2)).NE.21) THEN
33731 CALL PYPTDI(0,PXO(1),PYO(1))
33734 C...Initial values for gluon treated like random quark jet.
33735 ELSEIF(MSTJ(2).LE.2) THEN
33737 IF(MSTJ(2).EQ.2) MSTJ(91)=1
33738 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33739 CALL PYPTDI(0,PXO(1),PYO(1))
33742 C...Initial values for gluon treated like quark-antiquark jet pair,
33743 C...sharing energy according to Altarelli-Parisi splitting function.
33746 IF(MSTJ(2).EQ.4) MSTJ(91)=1
33747 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33749 CALL PYPTDI(0,PXO(1),PYO(1))
33752 WO(1)=WF*PYR(0)**(1D0/3D0)
33756 C...Initial values for rank, flavour, pT and W+.
33766 C...New hadron. Generate flavour and hadron species.
33768 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
33769 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
33770 IF(MSTU(21).GE.1) RETURN
33777 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
33778 IF(K(I,2).EQ.0) GOTO 180
33779 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
33780 IF(PYR(0).GT.PARJ(19)) GOTO 200
33783 C...Find hadron mass. Generate four-momentum.
33784 P(I,5)=PYMASS(K(I,2))
33785 CALL PYPTDI(KFL1,PX2,PY2)
33788 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
33789 CALL PYZDIS(KFL1,KFL2,PR,Z)
33791 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
33793 MSTU(90)=MSTU(90)+1
33794 MSTU(90+MSTU(90))=I
33795 PARU(90+MSTU(90))=Z
33797 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
33798 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
33799 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
33800 & P(I,3).LE.0.001D0) THEN
33801 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
33807 C...Remaining flavour and momentum.
33816 C...Check if pL acceptable. Go back for new hadron if enough energy.
33817 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
33819 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
33821 IF(W.GT.PARJ(31)) GOTO 190
33824 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
33825 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
33827 C...Rotate jet to new direction.
33828 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
33829 PHI=PYANGL(P(IP1,1),P(IP1,2))
33831 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
33832 K(K(IP1,3),4)=NSAV1+1
33835 C...End of jet generation loop. Skip conservation in some cases.
33837 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
33838 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
33840 C...Subtract off produced hadron flavours, finished if zero.
33841 DO 240 I=NSAV+NJET+1,N
33843 KFLA=MOD(KFA/1000,10)
33844 KFLB=MOD(KFA/100,10)
33845 KFLC=MOD(KFA/10,10)
33847 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
33848 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
33850 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
33851 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
33852 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
33855 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33856 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33857 IF(NREQ.EQ.0) GOTO 320
33859 C...Take away flavour of low-momentum particles until enough freedom.
33863 DO 260 I=NSAV+NJET+1,N
33864 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
33865 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
33866 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
33868 IF(IREM.EQ.0) GOTO 150
33870 KFA=IABS(K(IREM,2))
33871 KFLA=MOD(KFA/1000,10)
33872 KFLB=MOD(KFA/100,10)
33873 KFLC=MOD(KFA/10,10)
33874 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
33875 IF(K(IREM,1).EQ.8) GOTO 250
33877 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
33878 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
33879 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
33881 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
33882 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
33883 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
33886 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33887 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33888 IF(NREQ.GT.NREM) GOTO 250
33889 DO 270 I=NSAV+NJET+1,N
33890 IF(K(I,1).EQ.8) K(I,1)=1
33893 C...Find combination of existing and new flavours for hadron.
33895 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
33896 IF(NREQ.LT.NREM) NFET=1
33897 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
33899 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
33900 KFLF(J)=ISIGN(1,NFL(1))
33901 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
33902 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
33904 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
33906 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
33907 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
33908 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
33909 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
33910 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
33911 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
33912 IF(NFET.LE.2) KFLF(3)=0
33913 IF(KFLF(3).NE.0) THEN
33914 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
33915 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
33916 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
33917 & KFLFC=KFLFC+ISIGN(2,KFLFC)
33921 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
33922 IF(KF.EQ.0) GOTO 280
33923 DO 300 J=1,MAX(2,NFET)
33924 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
33927 C...Store hadron at random among free positions.
33928 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
33929 DO 310 I=NSAV+NJET+1,N
33930 IF(K(I,1).EQ.7) NPOS=NPOS-1
33931 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
33934 P(I,5)=PYMASS(K(I,2))
33935 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33938 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33939 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33940 IF(NREM.GT.0) GOTO 280
33942 C...Compensate for missing momentum in global scheme (3 options).
33943 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
33946 DO 330 I=NSAV+NJET+1,N
33947 PSI(J)=PSI(J)+P(I,J)
33950 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
33952 DO 350 I=NSAV+NJET+1,N
33953 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
33954 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33955 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33956 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
33958 DO 370 I=NSAV+NJET+1,N
33959 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
33960 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33961 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33962 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
33964 P(I,J)=P(I,J)-PSI(J)*PW/PWS
33966 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33969 C...Compensate for missing momentum withing each jet separately.
33970 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
33971 DO 390 I=N+1,N+NJET
33977 DO 410 I=NSAV+NJET+1,N
33980 K(IR2,1)=K(IR2,1)+1
33981 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33982 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33984 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
33986 P(IR2,4)=P(IR2,4)+P(I,4)
33987 P(IR2,5)=P(IR2,5)+PLS
33990 DO 420 I=N+1,N+NJET
33991 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
33993 DO 440 I=NSAV+NJET+1,N
33996 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33997 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33999 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
34002 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
34006 C...Scale momenta for energy conservation.
34007 IF(MOD(MSTJ(3),5).NE.0) THEN
34011 DO 450 I=NSAV+NJET+1,N
34014 PQS=PQS+P(I,5)**2/P(I,4)
34016 IF(PMS.GE.PECM) GOTO 150
34019 PFAC=(PECM-PQS)/(PES-PQS)
34022 DO 480 I=NSAV+NJET+1,N
34026 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
34028 PQS=PQS+P(I,5)**2/P(I,4)
34030 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
34033 C...Origin of produced particles and parton daughter pointers.
34034 490 DO 500 I=NSAV+NJET+1,N
34035 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
34036 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
34038 DO 510 I=NSAV+1,NSAV+NJET
34041 IF(MSTU(16).NE.2) THEN
34045 K(I1,4)=K(I1,4)-NJET+1
34046 K(I1,5)=K(I1,5)-NJET+1
34047 IF(K(I1,5).LT.K(I1,4)) THEN
34054 C...Document independent fragmentation system. Remove copy of jets.
34065 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
34067 DO 540 I=NSAV+NJET,N
34069 K(I-NJET+1,J)=K(I,J)
34070 P(I-NJET+1,J)=P(I,J)
34071 V(I-NJET+1,J)=V(I,J)
34075 DO 550 IZ=MSTU90+1,MSTU(90)
34076 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
34079 C...Boost back particle system. Set production vertices.
34080 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
34081 &DPS(2)/DPS(4),DPS(3)/DPS(4))
34091 C*********************************************************************
34093 *$ CREATE PYDECY.FOR
34096 C...Handles the decay of unstable particles.
34098 SUBROUTINE PYDECY(IP)
34100 C...Double precision and integer declarations.
34101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34102 INTEGER PYK,PYCHGE,PYCOMP
34104 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
34105 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34106 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34107 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
34108 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
34110 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
34111 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
34113 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
34115 C...Functions: momentum in two-particle decays and four-product.
34116 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
34117 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)
34119 C...Initial values.
34123 KFS=ISIGN(1,K(IP,2))
34127 C...Choose lifetime and determine decay vertex.
34128 IF(K(IP,1).EQ.5) THEN
34130 ELSEIF(K(IP,1).NE.4) THEN
34131 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
34134 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
34137 C...Determine whether decay allowed or not.
34139 IF(MSTJ(22).EQ.2) THEN
34140 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
34141 ELSEIF(MSTJ(22).EQ.3) THEN
34142 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
34143 ELSEIF(MSTJ(22).EQ.4) THEN
34144 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
34145 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
34147 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
34152 C...Interface to external tau decay library (for tau polarization).
34153 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
34155 C...Starting values for pointers and momenta.
34159 PCMTAU(J)=P(ITAU,J)
34162 C...Iterate to find position and code of mother of tau.
34164 120 IMTAU=K(IMTAU,3)
34166 IF(IMTAU.EQ.0) THEN
34167 C...If no known origin then impossible to do anything further.
34171 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
34172 C...If tau -> tau + gamma then add gamma energy and loop.
34173 IF(K(K(IMTAU,4),2).EQ.22) THEN
34175 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
34177 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
34179 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
34184 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
34185 C...If coming from weak decay of hadron then W is not stored in record,
34186 C...but can be reconstructed by adding neutrino momentum.
34187 KFORIG=-ISIGN(24,K(ITAU,2))
34189 DO 160 II=K(IMTAU,4),K(IMTAU,5)
34190 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
34192 PCMTAU(J)=PCMTAU(J)+P(II,J)
34198 C...If coming from resonance decay then find latest copy of this
34199 C...resonance (may not completely agree).
34202 DO 170 II=IMTAU+1,IP-1
34203 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
34204 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
34207 PCMTAU(J)=P(IORIG,J)
34211 C...Boost tau to rest frame of production process (where known)
34212 C...and rotate it to sit along +z axis.
34214 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
34216 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
34217 & -DBETAU(2),-DBETAU(3))
34218 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
34219 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
34220 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
34221 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
34223 C...Call tau decay routine (if meaningful) and fill extra info.
34224 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34225 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
34226 DO 200 II=NSAV+1,NSAV+NDECAY
34235 C...Boost back decay tau and decay products.
34239 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34240 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
34241 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
34242 & DBETAU(2),DBETAU(3))
34244 C...Skip past ordinary tau decay treatment.
34252 C...B-Bbar mixing: flip sign of meson appropriately.
34254 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
34256 IF(KFA.EQ.531) XBBMIX=PARJ(77)
34257 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
34258 IF(MMIX.EQ.1) KFS=-KFS
34261 C...Check existence of decay channels. Particle/antiparticle rules.
34263 IF(MDCY(KC,2).GT.0) THEN
34264 MDMDCY=MDME(MDCY(KC,2),2)
34265 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
34267 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
34268 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
34271 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
34272 IF(KCHG(KC,3).EQ.0) THEN
34275 IF(PYR(0).GT.0.5D0) KFS=-KFS
34276 ELSEIF(KFS.GT.0) THEN
34284 C...Sum branching ratios of allowed decay channels.
34287 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
34288 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34289 & KFSN*MDME(IDL,1).NE.3) GOTO 230
34290 IF(MDME(IDL,2).GT.100) GOTO 230
34292 BRSU=BRSU+BRAT(IDL)
34295 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
34299 C...Select decay channel among allowed ones.
34300 240 RBR=BRSU*PYR(0)
34303 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34304 &KFSN*MDME(IDL,1).NE.3) THEN
34305 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34306 ELSEIF(MDME(IDL,2).GT.100) THEN
34307 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34311 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
34314 C...Start readout of decay channel: matrix element, reset counters.
34317 IF(MOD(NTRY,200).EQ.0) THEN
34318 WRITE(CIDC,'(I4)') IDC
34319 CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
34323 IF(NTRY.GT.1000) THEN
34324 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34325 IF(MSTU(21).GE.1) RETURN
34331 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
34334 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
34336 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
34342 IF(KFA.GT.80) MHADDY=1
34343 C.. Random flavour and popcorn system memory.
34349 C...Read out decay products. Convert to standard flavour code.
34351 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
34353 IF(JT.LE.5) KP=KFDP(IDC,JT)
34354 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
34355 IF(KP.EQ.0) GOTO 280
34358 IF(KPA.GT.80) MHADDY=1
34359 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
34361 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
34363 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
34364 KFP=-KFS*MOD(KFA/10,10)
34365 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
34366 KFP=KFS*(100*MOD(KFA/10,100)+3)
34367 ELSEIF(KPA.EQ.81) THEN
34368 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
34369 ELSEIF(KP.EQ.82) THEN
34370 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
34371 IF(KFP.EQ.0) GOTO 260
34375 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
34376 ELSEIF(KP.EQ.-82) THEN
34379 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
34381 C...Add decay product to event record or to quark flavour list.
34384 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
34387 C...set rndmflav popcorn system pointer
34388 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
34390 PSQ=PSQ+PYMASS(KFLO(NQ))
34391 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
34392 & MOD(NQ,2).EQ.1) THEN
34397 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
34398 IF(K(I,2).EQ.0) GOTO 260
34400 P(I,5)=PYMASS(K(I,2))
34405 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
34406 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
34408 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
34409 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
34419 C...Check masses for resonance decays.
34420 IF(MHADDY.EQ.0) THEN
34421 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
34424 C...Choose decay multiplicity in phase space model.
34425 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
34427 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
34428 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
34430 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
34431 IF(IRNDMO.EQ.0) THEN
34434 ELSEIF(IRNDMO.EQ.1) THEN
34439 IF(NTRY.GT.1000) THEN
34440 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34441 IF(MSTU(21).GE.1) RETURN
34443 IF(MMAT.LE.20) THEN
34444 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
34445 & SIN(PARU(2)*PYR(0))
34446 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
34447 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
34448 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
34449 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
34450 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
34454 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
34456 IF(MSTU(121).GT.MSTU(125)) GOTO 300
34458 C...Form hadrons from flavour content.
34462 IF(ND.EQ.NP+NQ/2) GOTO 330
34463 DO 320 I=N+NP+1,N+ND-NQ/2
34464 C.. Stick to started popcorn system, else pick side at random
34466 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
34467 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
34468 IF(K(I,2).EQ.0) GOTO 300
34469 MSTU(125)=MSTU(125)-1
34471 IF(MSTU(121).GT.0) JTMO=JT
34477 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
34478 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
34479 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
34482 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
34483 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
34484 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
34485 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
34487 C...Check that sum of decay product masses not too large.
34489 DO 340 I=N+NP+1,N+ND
34494 P(I,5)=PYMASS(K(I,2))
34497 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
34499 C...Rescale energy to subtract off spectator quark mass.
34500 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
34501 & .AND.NP.GE.3) THEN
34503 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
34505 P(N+NP,J)=PQT*PV(1,J)
34506 PV(1,J)=(1D0-PQT)*PV(1,J)
34508 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34512 C...Fully specified final state: check mass broadening effects.
34514 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
34518 C...Determine position of grandmother, number of sisters.
34524 IF(IM.LT.0.OR.IM.GE.IP) IM=0
34525 IF(IM.NE.0) KFAM=IABS(K(IM,2))
34527 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
34528 IF(K(IL,3).EQ.IM) NM=NM+1
34529 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
34531 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
34532 & MOD(KFAM/1000,10).NE.0) NM=0
34534 KFAS=IABS(K(ISIS,2))
34535 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
34536 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
34541 C...Kinematics of one-particle decays.
34549 C...Calculate maximum weight ND-particle decay.
34552 WTMAX=1D0/WTCOR(ND-2)
34553 PMAX=PV(1,5)-PS+P(N+ND,5)
34555 DO 380 IL=ND-1,1,-1
34556 PMAX=PMAX+P(N+IL,5)
34557 PMIN=PMIN+P(N+IL+1,5)
34558 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
34562 C...Find virtual gamma mass in Dalitz decay.
34563 390 IF(ND.EQ.2) THEN
34564 ELSEIF(MMAT.EQ.2) THEN
34565 PMES=4D0*PMAS(11,1)**2
34566 PMRHO2=PMAS(131,1)**2
34567 PGRHO2=PMAS(131,2)**2
34568 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
34569 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
34570 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
34571 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
34572 IF(WT.LT.PYR(0)) GOTO 400
34573 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
34575 C...M-generator gives weight. If rejected, try again.
34580 DO 420 IL2=IL1-1,1,-1
34581 IF(RSAV.LE.RORD(IL2)) GOTO 430
34582 RORD(IL2+1)=RORD(IL2)
34584 430 RORD(IL2+1)=RSAV
34588 DO 450 IL=ND-1,1,-1
34589 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
34591 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34593 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
34596 C...Perform two-particle decays in respective CM frame.
34597 460 DO 480 IL=1,ND-1
34598 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34599 UE(3)=2D0*PYR(0)-1D0
34601 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
34602 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
34605 PV(IL+1,J)=-PA*UE(J)
34607 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
34608 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
34611 C...Lorentz transform decay products to lab frame.
34615 DO 530 IL=ND-1,1,-1
34617 BE(J)=PV(IL,J)/PV(IL,4)
34619 GA=PV(IL,4)/PV(IL,5)
34621 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34623 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34625 P(I,4)=GA*(P(I,4)+BEP)
34629 C...Check that no infinite loop in matrix element weight.
34631 IF(NTRY.GT.800) GOTO 560
34633 C...Matrix elements for omega and phi decays.
34635 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
34636 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
34637 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
34638 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
34640 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
34641 ELSEIF(MMAT.EQ.2) THEN
34642 FOUR12=FOUR(N+1,N+2)
34643 FOUR13=FOUR(N+1,N+3)
34644 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
34645 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
34646 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
34648 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
34649 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
34650 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
34651 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
34653 FOUR12=FOUR(IP,N+1)
34654 FOUR02=FOUR(IM,N+1)
34658 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
34659 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
34660 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
34661 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
34662 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
34663 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
34665 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
34666 ELSEIF(MMAT.EQ.4) THEN
34667 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34668 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
34669 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
34670 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
34671 & ((1D0-HX3)/(HX1*HX2))**2
34672 IF(WT.LT.2D0*PYR(0)) GOTO 390
34673 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
34676 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
34677 ELSEIF(MMAT.EQ.41) THEN
34678 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34679 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
34680 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
34682 C...Matrix elements for weak decays (only semileptonic for c and b)
34683 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34684 & .AND.ND.EQ.3) THEN
34685 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
34686 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
34687 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34688 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
34692 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
34695 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
34696 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
34697 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34700 C...Scale back energy and reattach spectator.
34701 560 IF(MREM.EQ.1) THEN
34703 PV(1,J)=PV(1,J)/(1D0-PQT)
34709 C...Low invariant mass for system with spectator quark gives particle,
34710 C...not two jets. Readjust momenta accordingly.
34711 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
34713 PM2=PYMASS(K(N+2,2))
34715 PM3=PYMASS(K(N+3,2))
34716 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
34717 & (PARJ(32)+PM2+PM3)**2) GOTO 630
34720 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
34721 IF(K(N+2,2).EQ.0) GOTO 260
34722 P(N+2,5)=PYMASS(K(N+2,2))
34723 PS=P(N+1,5)+P(N+2,5)
34728 ELSEIF(MMAT.EQ.44) THEN
34730 PM3=PYMASS(K(N+3,2))
34732 PM4=PYMASS(K(N+4,2))
34733 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
34734 & (PARJ(32)+PM3+PM4)**2) GOTO 600
34737 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
34738 IF(K(N+3,2).EQ.0) GOTO 260
34739 P(N+3,5)=PYMASS(K(N+3,2))
34741 P(N+3,J)=P(N+3,J)+P(N+4,J)
34743 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)
34744 HA=P(N+1,4)**2-P(N+2,4)**2
34745 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
34746 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
34747 & (P(N+1,3)-P(N+2,3))**2
34748 HD=(PV(1,4)-P(N+3,4))**2
34749 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
34752 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
34754 PCOR=HH*(P(N+1,J)-P(N+2,J))
34755 P(N+1,J)=P(N+1,J)+PCOR
34756 P(N+2,J)=P(N+2,J)-PCOR
34758 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)
34759 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)
34763 C...Check invariant mass of W jets. May give one particle or start over.
34764 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34765 &.AND.IABS(K(N+1,2)).LT.10) THEN
34766 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
34768 PM1=PYMASS(K(N+1,2))
34770 PM2=PYMASS(K(N+2,2))
34771 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
34772 KFLDUM=INT(1.5D0+PYR(0))
34773 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
34774 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
34775 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
34776 PSM=PYMASS(KF1)+PYMASS(KF2)
34777 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
34778 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
34779 IF(MMAT.EQ.48) GOTO 390
34780 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
34783 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
34784 IF(K(N+1,2).EQ.0) GOTO 260
34785 P(N+1,5)=PYMASS(K(N+1,2))
34788 PS=P(N+1,5)+P(N+2,5)
34789 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34796 C...Phase space decay of partons from W decay.
34797 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
34803 PV(1,J)=P(N+1,J)+P(N+2,J)
34812 PSQ=PYMASS(KFLO(1))
34814 PSQ=PSQ+PYMASS(KFLO(2))
34819 C...Boost back for rapidly moving particle.
34823 BE(J)=P(IP,J)/P(IP,4)
34827 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34829 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34831 P(I,4)=GA*(P(I,4)+BEP)
34835 C...Fill in position of decay vertex.
34843 C...Set up for parton shower evolution from jets.
34844 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
34848 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34849 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34850 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34851 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34852 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34853 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34855 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
34858 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34859 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
34860 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
34861 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34863 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34864 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
34867 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34868 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
34869 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
34870 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34872 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34873 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
34875 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
34880 KCP=PYCOMP(K(NSAV+1,2))
34881 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
34883 IF(KQP.LT.0) JCON=5
34884 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
34885 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
34886 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
34887 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
34889 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
34892 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
34893 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34894 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34895 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
34899 C...Mark decayed particle; special option for B-Bbar mixing.
34900 IF(K(IP,1).EQ.5) K(IP,1)=15
34901 IF(K(IP,1).LE.10) K(IP,1)=11
34902 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
34909 C*********************************************************************
34911 *$ CREATE PYDCYK.FOR
34914 C...Handles flavour production in the decay of unstable particles
34915 C...and small string clusters.
34917 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
34919 C...Double precision and integer declarations.
34920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34921 INTEGER PYK,PYCHGE,PYCOMP
34923 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34924 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34925 SAVE /PYDAT1/,/PYDAT2/
34928 C.. Call PYKFDI directly if no popcorn option is on
34929 IF(MSTJ(12).LT.2) THEN
34930 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34937 IF(KFL1.EQ.0) RETURN
34942 NMAX=MIN(MSTU(125),10)
34944 C.. Identify rank 0 cluster qq
34946 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
34949 C.. Join jets: Fails if store not empty
34950 IF(MSTU(121).GT.0) THEN
34954 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34955 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
34956 C.. Pick popcorn meson from store, return same qq, decrease store
34957 KF=MSTU(NSTO+MSTU(121))
34959 MSTU(121)=MSTU(121)-1
34961 C.. Generate new flavour. Then done if no diquark is generated
34962 100 CALL PYKFDI(KFL1,0,KFL3,KF)
34963 IF(MSTU(121).EQ.-1) GOTO 100
34965 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
34967 C.. Simple case if no dynamical popcorn suppressions are considered
34968 IF(MSTJ(12).LT.4) THEN
34969 IF(MSTU(121).EQ.0) RETURN
34972 CALL PYKFDI(KFPREV,0,KFL3,KFM)
34973 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
34974 IF(IABS(KFL3).LE.10)THEN
34981 C test output qq against fake Gamma, then return if no popcorn.
34984 CALL PYZDIS(1,2103,5D0,Z)
34986 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
34991 IF(MSTU(121).EQ.0) RETURN
34993 C..Set store size memory. Pick fake dynamical variables of qq.
34995 CALL PYPTDI(1,PX3,PY3)
35001 C.. Pick next popcorn meson, test with fake dynamical variables
35005 CALL PYKFDI(KFPREV,0,KFL3,KFM)
35006 IF(MSTU(121).EQ.-1) GOTO 100
35007 CALL PYPTDI(KFL3,PX3,PY3)
35008 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
35009 CALL PYZDIS(KFPREV,KFL3,PM,Z)
35016 IF(MSTJ(12).GT.4)THEN
35017 POPMN=SQRT((1D0-X)*(G/X-GB))
35018 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35019 PTST=EXP((POPM-POPMN)*PARF(193))
35024 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
35027 IF(RTST.GT.PTST*GTST)THEN
35029 IF(RTST.GT.PTST) MSTU(121)=-1
35034 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
35035 IF(MSTU(121).GT.0) GOTO 110
35037 C.. Test accepted system size. If OK set global popcorn size variable.
35038 IF(NMES.GT.NMAX)THEN
35049 C********************************************************************
35051 *$ CREATE PYKFDI.FOR
35054 C...Generates a new flavour pair and combines off a hadron
35056 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
35058 C...Double precision and integer declarations.
35059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35060 INTEGER PYK,PYCHGE,PYCOMP
35062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35063 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35064 SAVE /PYDAT1/,/PYDAT2/
35068 IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
35070 C...Default flavour values. Input consistency checks.
35075 IF(KF1A.EQ.0) RETURN
35077 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
35078 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
35079 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
35082 C...Check if tabulated flavour probabilities are to be used.
35083 IF(MSTJ(15).EQ.1) THEN
35084 IF(MSTJ(12).GE.5) CALL PYERRM(29,
35085 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
35086 & ' together with MSTJ(12)>=5 modification')
35088 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
35089 KFL1A=MOD(KF1A/1000,10)
35090 KFL1B=MOD(KF1A/100,10)
35092 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
35093 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
35094 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
35095 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
35099 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
35100 KFL2A=MOD(KF2A/1000,10)
35101 KFL2B=MOD(KF2A/100,10)
35103 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
35104 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
35105 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
35107 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
35110 C.. Recognize rank 0 diquark case
35112 KFDIQ=MAX(KF1A,KF2A)
35113 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
35115 C.. Join two flavours to meson or baryon. Test for popcorn.
35118 IF(KFDIQ.GT.10) THEN
35119 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
35120 & CALL PYNMES(KFDIQ)
35121 IF(MSTU(121).NE.0) RETURN
35129 C.. Separate incoming flavours, curtain flavour consistency check
35135 KFL1A=MOD(KF1A/1000,10)
35136 KFL1B=MOD(KF1A/100,10)
35139 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
35140 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
35141 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
35143 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) RETURN
35144 KFQOLD=KFL1A+KFL1B-KFQPOP
35147 C...Meson/baryon choice. Set number of mesons if starting a popcorn
35150 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
35151 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
35155 ELSEIF(KF1A.GT.10)THEN
35157 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
35158 IF(MSTU(121).GT.0) MBARY=-1
35161 C..x->H+q: Choose single vertex quark. Jump to form hadron.
35162 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
35163 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
35164 KFL3=ISIGN(KFQVER,-KFIN)
35168 C..x->H+qq: (IDW=proper PARF position for diquark weights)
35170 C.. q->B+qq: Get curtain quark, different weights for q->B+B and
35173 IF(MSTU(121).EQ.0) IDW=150
35175 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
35176 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
35177 C.. Shift to s-curtain parameters if needed
35178 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
35179 PARF(194)=PARF(138)*PARF(139)
35180 PARF(193)=PARJ(8)+PARJ(9)
35184 C.. x->H+qq: Get vertex quark
35185 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
35187 MSTU(121)=MSTU(121)-1
35188 IF(IDW.EQ.170) THEN
35189 IF(MSTU(121).EQ.0)THEN
35190 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
35192 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
35195 IF(MSTU(121).EQ.0)THEN
35196 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
35198 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
35204 RMES=PYR(0)*PARF(194)
35206 RMES=RMES-PARF(IPOS+IMES)
35207 IF(IMES.EQ.30) THEN
35212 IF(RMES.GT.0D0) GOTO 120
35215 IF(KMUL.EQ.2) KFJ=10003
35216 IF(KMUL.EQ.3) KFJ=10001
35217 IF(KMUL.EQ.4) KFJ=20003
35218 IF(KMUL.EQ.5) KFJ=5
35220 KFQVER=MOD(IMES,5)+1
35221 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
35222 IF(KFQVER.GT.3)THEN
35227 IF(MBARY.EQ.-1) IDW=170
35229 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
35230 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
35231 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
35232 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
35234 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
35238 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
35240 IF(KFQPOP.NE.KFQVER)THEN
35242 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
35243 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
35244 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
35246 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
35248 KFL3=ISIGN(KFDIQ,KFIN)
35250 C..x->M+y: flavour for meson.
35251 130 IF(MBARY.LE.0)THEN
35252 KFLA=MAX(KFQOLD,KFQVER)
35253 KFLB=MIN(KFQOLD,KFQVER)
35255 IF(KFLA.NE.KFQOLD) KFS=-KFS
35256 C... Form meson, with spin and flavour mixing for diagonal states.
35257 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
35258 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
35259 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
35262 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
35263 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
35264 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
35265 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
35266 IF(PYR(0).LT.PARJ(14)) KMUL=2
35267 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
35269 IF(RMUL.LT.PARJ(15)) KMUL=3
35270 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
35271 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
35274 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
35275 IF(KMUL.EQ.5) KFLS=5
35276 IF(KFLA.NE.KFLB)THEN
35277 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
35280 IMIX=2*KFLA+10*KMUL
35281 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
35282 & INT(RMIX+PARF(IMIX)))+KFLS
35283 IF(KFLA.GE.4) KF=110*KFLA+KFLS
35285 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
35286 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
35288 C..Optional extra suppression of eta and eta'.
35289 C..Allow shift to qq->B+q in old version (set IRANK to 0)
35290 IF(KF.EQ.221.OR.KF.EQ.331)THEN
35291 IF(PYR(0).GT.PARJ(25+KF/300))THEN
35292 IF(KF2A.GT.0) GOTO 130
35293 IF(MSTJ(12).LT.4) IRANK=0
35299 C.. x->B+y: Flavour for baryon
35302 IF(KF1A.LE.10) KFLA=KFQOLD
35303 KFLB=MOD(KFDIQ/1000,10)
35304 KFLC=MOD(KFDIQ/100,10)
35305 KFLDS=MOD(KFDIQ,10)
35306 KFLD=MAX(KFLA,KFLB,KFLC)
35307 KFLF=MIN(KFLA,KFLB,KFLC)
35308 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35310 C... SU(6) factors for formation of baryon.
35314 IF(KFLB.NE.KFLC)THEN
35317 IF(KFLB.GT.2) KDMAX=KDMAX+2
35319 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
35324 SU6MAX=PARF(140+KDMAX)
35327 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
35332 SU6OCT=PARF(60+KBARY)
35333 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
35334 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
35335 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
35337 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
35339 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
35341 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
35342 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
35344 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
35348 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
35351 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
35352 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
35354 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
35356 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
35357 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
35361 C...Use tabulated probabilities to select new flavour and hadron.
35362 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
35365 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
35368 ELSEIF(KTAB2.EQ.0) THEN
35377 DO 150 KT3=KT3L,KT3U
35378 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
35384 DO 170 KT3=KT3L,KT3U
35386 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
35387 IF(RFL.LE.0D0) GOTO 190
35392 C...Reconstruct flavour of produced quark/diquark.
35393 IF(KTAB3.LE.6) THEN
35396 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
35399 IF(KTAB3.GE.8) KFL3A=2
35400 IF(KTAB3.GE.11) KFL3A=3
35401 IF(KTAB3.GE.16) KFL3A=4
35402 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
35403 KFL3=1000*KFL3A+100*KFL3B+1
35404 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
35406 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
35409 C...Reconstruct meson code.
35410 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
35412 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35413 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
35415 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
35416 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35417 & 25*KTABS)) KF=330+2*KTABS+1
35418 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
35419 KFLA=MAX(KTAB1,KTAB3)
35420 KFLB=MIN(KTAB1,KTAB3)
35422 IF(KFLA.NE.KF1A) KFS=-KFS
35423 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35424 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
35426 IF(KFL1A.EQ.KFL3A) THEN
35427 KFLA=MAX(KFL1B,KFL3B)
35428 KFLB=MIN(KFL1B,KFL3B)
35429 IF(KFLA.NE.KFL1B) KFS=-KFS
35430 ELSEIF(KFL1A.EQ.KFL3B) THEN
35434 ELSEIF(KFL1B.EQ.KFL3A) THEN
35437 ELSEIF(KFL1B.EQ.KFL3B) THEN
35438 KFLA=MAX(KFL1A,KFL3A)
35439 KFLB=MIN(KFL1A,KFL3A)
35440 IF(KFLA.NE.KFL1A) KFS=-KFS
35442 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
35445 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35447 C...Reconstruct baryon code.
35449 IF(KTAB1.GE.7) THEN
35458 KFLD=MAX(KFLA,KFLB,KFLC)
35459 KFLF=MIN(KFLA,KFLB,KFLC)
35460 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35461 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
35462 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
35465 C...Check that constructed flavour code is an allowed one.
35466 IF(KFL2.NE.0) KFL3=0
35469 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
35477 C*********************************************************************
35479 *$ CREATE PYNMES.FOR
35482 C...Generates number of popcorn mesons and stores some relevant
35485 SUBROUTINE PYNMES(KFDIQ)
35487 C...Double precision and integer declarations.
35488 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35489 INTEGER PYK,PYCHGE,PYCOMP
35491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35492 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35493 SAVE /PYDAT1/,/PYDAT2/
35496 IF(MSTJ(12).LT.2) RETURN
35498 C..Old version: Get 1 or 0 popcorn mesons
35499 IF(MSTJ(12).LT.5)THEN
35501 IF(KFDIQ.NE.0) THEN
35503 KFA=MOD(KFDIQA/1000,10)
35504 KFB=MOD(KFDIQA/100,10)
35507 IF(KFA.EQ.3) POPWT=PARF(133)
35508 IF(KFB.EQ.3) POPWT=PARF(134)
35509 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
35511 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
35515 C..New version: Store popcorn- or rank 0 diquark parameters
35518 PARF(194)=PARF(139)
35519 IF(KFDIQ.NE.0) THEN
35522 PARF(194)=PARF(140)
35524 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
35525 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
35526 & '(PYNMES:) Neglecting too large popcorn possibility')
35530 C..New version: Get number of popcorn mesons
35533 110 MSTU(121)=MSTU(121)+1
35534 RTST=RTST/PARF(194)
35535 IF(RTST.LT.1D0) GOTO 110
35536 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)).GT.
35537 & (2D0+PARF(135)*PARF(138)**MSTU(121))) GOTO 100
35541 C*********************************************************************
35543 *$ CREATE PYKFIN.FOR
35546 C...Precalculates a set of diquark and popcorn weights.
35547 C.. (Results stored in order SU0,US0,SS1,UU1,SU1,US1,UD1)
35551 C...Double precision and integer declarations.
35552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35553 INTEGER PYK,PYCHGE,PYCOMP
35555 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35556 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35557 SAVE /PYDAT1/,/PYDAT2/
35559 DIMENSION SU6(12),SU6M(7)
35562 C..Curtain tunneling factor T(D,q)/T(ud0,u).
35563 IF(MSTJ(12).GE.5) THEN
35565 PMUD1=PYMASS(2103)-PMUD0
35566 PMUS0=PYMASS(3201)-PMUD0
35567 PMUS1=PYMASS(3203)-PMUS0-PMUD0
35568 PMSS1=PYMASS(3303)-PMUS0-PMUD0
35569 PARF(151)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
35570 PARF(152)=EXP(-PARJ(8)*PMUS0)
35571 PARF(153)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*PARF(151)
35572 PARF(154)=EXP(-PARJ(8)*PMUD1)
35573 PARF(155)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*PARF(151)
35574 PARF(156)=EXP(-PARJ(8)*PMUS1)*PARF(152)
35575 PARF(157)=PARF(154)
35577 PAR2M=SQRT(PARJ(2))
35578 PAR3M=SQRT(PARJ(3))
35579 PAR4M=SQRT(PARJ(4))
35580 PARF(151)=PAR2M*PAR3M
35582 PARF(153)=PAR2M*PARJ(3)*PAR4M
35584 PARF(155)=PAR4M*PARF(151)
35585 PARF(156)=PAR4M*PARF(152)
35589 C.. Total tunneling factor tau(D,q)=T*vertex*spin.
35590 PARF(161)=PARF(151)
35591 PARF(162)=PARJ(2)*PARF(152)
35592 PARF(163)=PARJ(2)*6D0*PARF(153)
35593 PARF(164)=6D0*PARF(154)
35594 PARF(165)=3D0*PARF(155)
35595 PARF(166)=PARJ(2)*3D0*PARF(156)
35596 PARF(167)=3D0*PARF(157)
35599 PARF(150+I)=PARF(150+I)*PARF(160+I)
35602 C..Modified SU(6) factors.
35604 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
35605 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
35606 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
35609 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
35611 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
35612 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
35614 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
35615 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
35618 C..Total diquark quark*SU(6).
35619 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
35620 PARF(171)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
35621 PARF(172)=PARF(171)
35622 PARF(173)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
35623 PARF(174)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
35624 PARF(175)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
35625 PARF(176)=PARF(175)
35626 PARF(177)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
35628 C..SU(6)max q q' s,c,b
35629 SU6MUD =MAX(SU6(1) , SU6(8) )
35630 SU6M(7)=MAX(SU6(5) , SU6(12))
35631 SU6M(1)=MAX(SU6(7) ,SU6(2),SU6MUD )
35632 SU6M(4)=MAX(SU6(3) ,SU6(4),SU6(10))
35633 SU6M(5)=MAX(SU6(11),SU6(6),SU6M(7))
35638 IF(MSTJ(12).GE.5)THEN
35639 C..New version: tau for rank 0 diquark.
35640 PARF(181)=EXP(-PARJ(10)*PMUS0)
35641 PARF(182)=PARJ(2)*PARF(181)
35642 PARF(183)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*PARF(181)
35643 PARF(184)=3D0*EXP(-PARJ(10)*PMUD1)
35644 PARF(185)=3D0*EXP(-PARJ(10)*PMUS1)*PARF(181)
35645 PARF(186)=PARJ(2)*PARF(185)
35646 PARF(187)=2D0*PARF(184)
35648 C..New version: s/u curtain ratios.
35649 WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35650 PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35651 WU=1D0+PARF(187)+PARF(182)+PARF(186)+PARF(184)
35652 PARF(136)=(2D0*(PARF(181)+PARF(185))+PARF(183))/WU
35653 PARF(137)=(PARF(181)+PARF(185))*
35654 & (2D0+PARF(183)/(2D0*PARF(185)))/WU
35656 C..Old version: Shuffle PARJ(7) into tau
35657 PARF(162)=PARF(162)*PARJ(7)
35658 PARF(163)=PARF(163)*PARJ(7)
35659 PARF(166)=PARF(166)*PARJ(7)
35661 C..Old version: s/u curtain ratios.
35662 WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35663 PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35664 PARF(136)=PARF(135)*PARJ(6)*PARF(161)/PARF(162)
35665 PARF(137)=(1D0+PARF(167))*(2D0+PARF(162))/WU
35668 C..Combine SU(6), SU(6)max, tau and T into proper products
35670 PARF(180+I)=PARF(180+I)*PARF(170+I)
35671 PARF(170+I)=PARF(170+I)*PARF(160+I)
35672 PARF(160+I)=PARF(160+I)*SU6M(I)/SU6MUD
35673 PARF(150+I)=PARF(150+I)*SU6M(I)/SU6MUD
35676 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
35683 IF(MSTJ(12).LT.5)THEN
35684 C.. Old version: Resulting popcorn weights.
35686 WS=PARF(135)*PARF(138)
35688 PARF(132)=WQ*PARF(167)/PARF(157)
35689 PARF(133)=WQ*(PARF(166)/PARF(156)+WS*PARF(165)/PARF(155))/2D0
35690 PARF(134)=WQ*WS*PARF(163)/PARF(153)
35691 PARF(131)=WQ*((1D0+PARF(167))*(1D0+PARF(162)+WS*PARF(161))+
35692 & PARF(164)+WS*PARF(163)/2D0)/
35693 & ((1D0+PARF(157))*(1D0+2D0*PARF(152))+PARF(154)+PARF(153)/2D0)
35695 C..New version: Store weights for popcorn mesons,
35696 C..get prel. popcorn weights.
35697 DO 150 IPOS=201,1400
35705 DO 240 MR=170,180,10
35706 IF(MR.EQ.180) PARF(193)=PARJ(10)
35707 SQWT=2D0*(PARF(MR+2)+PARF(MR+6))/(1D0+PARF(MR+7)+PARF(MR+4))
35708 QQWT=PARF(MR+4)/(1D0+PARF(MR+7)+PARF(MR+4))
35710 IF(NMES.EQ.1) SQWT=PARJ(2)
35712 IF(MR.EQ.170.AND.KFQPOP.GT.3) GOTO 220
35713 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
35714 SQWT=PARF(MR+3)/(PARF(MR+1)+PARF(MR+5))
35716 IF(MR.EQ.170) PARF(193)=PARJ(8)+PARJ(9)
35717 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/PARF(185)+1D0)/2D0
35720 IF(MR.EQ.170.AND.KFQOLD.GT.3) GOTO 210
35721 IF(MR*NMES.EQ.170.AND.KFQPOP.EQ.1) GOTO 210
35722 IF(MR*NMES.EQ.180.AND.KFQPOP.NE.1) GOTO 210
35727 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
35728 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
35729 IF(PJWT.LE.0D0) GOTO 190
35730 IF(PJWT.GT.1D0) PJWT=1D0
35732 IMIX=2*KFQOLD+10*KMUL
35734 IF(KMUL.EQ.2) KFJ=10003
35735 IF(KMUL.EQ.3) KFJ=10001
35736 IF(KMUL.EQ.4) KFJ=20003
35737 IF(KMUL.EQ.5) KFJ=5
35739 KFLA=MAX(KFQOLD,KFQVER)
35740 KFLB=MIN(KFQOLD,KFQVER)
35741 SWT=PARJ(11+KFLA/3+KFLA/4)
35742 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
35744 QWT=SQWT/(2D0+SQWT)
35745 IF(KFQVER.LT.3)THEN
35746 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
35747 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
35749 IF(KFQVER.NE.KFQOLD)THEN
35751 KFM=100*KFLA+10*KFLB+KFJ
35752 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35753 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
35754 WTTOT=WTTOT+PARF(IPOS+IMES)
35757 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
35758 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
35759 IF(ID.EQ.5) DWT=PARF(IMIX)
35761 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35762 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
35763 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
35764 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
35765 PARF(IPOS+5*KMUL+ID)=
35766 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
35768 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
35774 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
35776 IF(MR.EQ.180) PARF(140)=
35777 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
35778 IF(MR.EQ.170) PARF(139-KFQPOP/3)=
35779 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
35785 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
35788 PARF(186)=PARF(186)/PARF(182)
35789 PARF(185)=PARF(185)/PARF(181)
35792 C..Recombine diquark weights to flavour and spin ratios
35793 DO 250 I=150,170,10
35794 WSWQ=(2D0*(PARF(I+1)+PARF(I+5))+PARF(I+3))/
35795 & (1D0+PARF(I+7)+PARF(I+4)+PARF(I+2)+PARF(I+6))
35796 WSSWSQ=PARF(I+3)/(PARF(I+1)+PARF(I+5))
35797 WQSWQQ=2D0*(PARF(I+2)+PARF(I+6))/(1D0+PARF(I+7)+PARF(I+4))
35798 WUUWQQ=PARF(I+4)/(1D0+PARF(I+7)+PARF(I+4))
35799 PARF(I+5)=PARF(I+5)/PARF(I+1)
35800 PARF(I+6)=PARF(I+6)/PARF(I+2)
35809 C*********************************************************************
35811 *$ CREATE PYPTDI.FOR
35814 C...Generates transverse momentum according to a Gaussian.
35816 SUBROUTINE PYPTDI(KFL,PX,PY)
35818 C...Double precision and integer declarations.
35819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35820 INTEGER PYK,PYCHGE,PYCOMP
35822 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35825 C...Generate p_T and azimuthal angle, gives p_x and p_y.
35827 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
35828 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
35829 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
35830 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
35838 C*********************************************************************
35840 *$ CREATE PYZDIS.FOR
35843 C...Generates the longitudinal splitting variable z.
35845 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
35847 C...Double precision and integer declarations.
35848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35849 INTEGER PYK,PYCHGE,PYCOMP
35851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35852 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35853 SAVE /PYDAT1/,/PYDAT2/
35855 C...Check if heavy flavour fragmentation.
35859 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
35861 C...Lund symmetric scaling function: determine parameters of shape.
35862 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
35863 &MSTJ(11).GE.4) THEN
35865 IF(MSTJ(91).EQ.1) FA=PARJ(43)
35866 IF(KFLB.GE.10) FA=FA+PARJ(45)
35868 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
35871 IF(KFLA.GE.10) FC=FC-PARJ(45)
35872 IF(KFLB.GE.10) FC=FC+PARJ(45)
35873 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
35875 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
35876 FC=FC+FRED*FBB*PARF(100+KFLH)**2
35877 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
35879 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
35880 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
35883 IF(ABS(FC-1D0).GT.0.01D0) MC=2
35885 C...Determine position of maximum. Special cases for a = 0 or a = c.
35886 IF(FA.LT.0.02D0) THEN
35889 IF(FC.GT.FB) ZMAX=FB/FC
35890 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
35895 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
35896 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
35899 C...Subdivide z range if distribution very peaked near endpoint.
35901 IF(ZMAX.LT.0.1D0) THEN
35907 ZDIVC=ZDIV**(1D0-FC)
35908 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
35910 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
35912 FSCB=SQRT(4D0+(FC/FB)**2)
35913 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
35914 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
35915 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
35916 FINT=1D0+FB*(1D0-ZDIV)
35919 C...Choice of z, preweighted for peaks at low or high z.
35923 IF(FINT*PYR(0).LE.1D0) THEN
35925 ELSEIF(MC.EQ.1) THEN
35929 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
35932 ELSEIF(MMAX.EQ.3) THEN
35933 IF(FINT*PYR(0).LE.1D0) THEN
35935 FPRE=EXP(FB*(Z-ZDIV))
35937 Z=ZDIV+Z*(1D0-ZDIV)
35941 C...Weighting according to correct formula.
35942 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
35943 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
35944 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
35945 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
35946 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
35948 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
35950 FC=PARJ(50+MAX(1,KFLH))
35951 IF(MSTJ(91).EQ.1) FC=PARJ(59)
35953 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
35954 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
35955 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
35956 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
35959 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
35960 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
35967 C*********************************************************************
35969 *$ CREATE PYSHOW.FOR
35972 C...Generates timelike parton showers from given partons.
35974 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
35976 C...Double precision and integer declarations.
35977 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35978 INTEGER PYK,PYCHGE,PYCOMP
35980 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
35981 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35982 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35983 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
35985 DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
35986 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
35987 &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
35990 C...Initialization of cutoff masses etc.
35991 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
35992 &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN
35997 PMTH(1,21)=PYMASS(21)
35998 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
35999 PMTH(3,21)=2D0*PMTH(2,21)
36000 PMTH(4,21)=PMTH(3,21)
36001 PMTH(5,21)=PMTH(3,21)
36002 PMTH(1,22)=PYMASS(22)
36003 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
36004 PMTH(3,22)=2D0*PMTH(2,22)
36005 PMTH(4,22)=PMTH(3,22)
36006 PMTH(5,22)=PMTH(3,22)
36008 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
36010 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
36013 PMTH(1,IFL)=PYMASS(IFL)
36014 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
36015 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
36016 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
36017 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
36020 IF(MSTJ(41).GE.2) KSH(IFL)=1
36021 PMTH(1,IFL)=PYMASS(IFL)
36022 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)
36023 PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22)
36024 PMTH(4,IFL)=PMTH(3,IFL)
36025 PMTH(5,IFL)=PMTH(3,IFL)
36027 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
36029 ALFM=LOG(PT2MIN/ALAMS)
36031 C...Store positions of shower initiating partons.
36032 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
36035 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
36040 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
36041 & .AND.IP2.GE.-3) THEN
36048 & '(PYSHOW:) failed to reconstruct showering system')
36049 IF(MSTU(21).GE.1) RETURN
36052 C...Check on phase space available for emission.
36059 KFLA(I)=IABS(K(IPA(I),2))
36061 C...Special cutoff masses for t, l, h with variable masses.
36063 IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
36064 IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
36065 PMTH(1,IFLA)=PMA(I)
36066 PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PMQTH1**2)
36067 PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
36068 PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(82)**2)+
36070 PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(83)**2)+
36073 IF(KFLA(I).LE.40) THEN
36074 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
36077 IF(KFLA(I).GT.40) THEN
36080 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
36083 PS(J)=PS(J)+P(IPA(I),J)
36086 IF(IREJ.EQ.NPA) RETURN
36087 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
36088 IF(NPA.EQ.1) PS(5)=PS(4)
36089 IF(PS(5).LE.PM+PMQTH1) RETURN
36091 C...Check if 3-jet matrix elements to be used.
36093 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
36094 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
36095 & KFLA(2).LE.8) M3JC=1
36096 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
36097 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
36098 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
36099 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
36100 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
36101 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
36102 IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
36104 IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
36106 QME=(2D0*PMTH(1,KFLA(1))/PS(5))**2
36110 C...Find if interference with initial state partons.
36112 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
36116 KCA=PYCOMP(KFLA(I))
36117 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
36119 IF(KCII(I).NE.0) THEN
36121 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
36122 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
36123 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
36125 IIIS(I,NIIS(I))=ICSI
36130 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
36133 C...Boost interfering initial partons to rest frame
36134 C...and reconstruct their polar and azimuthal angles.
36138 K(N+I,J)=K(IPA(I),J)
36139 P(N+I,J)=P(IPA(I),J)
36143 DO 220 I=3,2+NIIS(1)
36145 K(N+I,J)=K(IIIS(1,I-2),J)
36146 P(N+I,J)=P(IIIS(1,I-2),J)
36150 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
36152 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
36153 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
36157 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
36158 & -PS(2)/PS(4),-PS(3)/PS(4))
36159 PHI=PYANGL(P(N+1,1),P(N+1,2))
36160 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
36161 THE=PYANGL(P(N+1,3),P(N+1,1))
36162 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
36163 DO 250 I=3,2+NIIS(1)
36164 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
36165 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
36167 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
36168 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
36169 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
36170 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
36174 C...Define imagined single initiator of shower for parton system.
36176 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
36177 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36178 IF(MSTU(21).GE.1) RETURN
36195 C...Loop over partons that may branch.
36198 IF(NPA.EQ.1) IM=NS-1
36201 IF(IM.GT.N) GOTO 510
36203 IF(KFLM.GT.40) GOTO 270
36204 IF(KSH(KFLM).EQ.0) GOTO 270
36206 IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
36207 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
36212 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
36213 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36214 IF(MSTU(21).GE.1) RETURN
36217 C...Position of aunt (sister to branching parton).
36218 C...Origin and flavour of daughters.
36221 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
36222 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
36234 K(N+I,2)=K(IPA(I),2)
36236 ELSEIF(KFLM.NE.21) THEN
36239 ELSEIF(K(IM,5).EQ.21) THEN
36247 C...Reset flags on daughers and tries made.
36252 KFLD(IP)=IABS(K(N+IP,2))
36253 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
36257 IF(KFLD(IP).LE.40) THEN
36258 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
36263 C...Maximum virtuality of daughters.
36266 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
36267 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
36268 P(N+I,5)=MIN(QMAX,PS(5))
36269 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
36270 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
36273 IF(MSTJ(43).LE.2) PEM=V(IM,2)
36274 IF(MSTJ(43).GE.3) PEM=P(IM,4)
36275 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
36276 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
36277 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
36281 IF(ISI(I).EQ.1) THEN
36283 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36284 & ISIGN(2,K(N+I,2))
36285 IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
36287 V(N+I,5)=P(N+I,5)**2
36290 C...Choose one of the daughters for evolution.
36292 IF(NEP.EQ.1) INUM=1
36294 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
36297 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
36299 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36300 & ISIGN(2,K(N+I,2))
36301 IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
36307 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
36308 RPM=P(N+I,5)/PMSD(I)
36310 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36311 & ISIGN(2,K(N+I,2))
36312 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
36320 C...Store information on choice of evolving daughter.
36325 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
36328 KFL(I)=IABS(K(IEP(I),2))
36330 ITRY(INUM)=ITRY(INUM)+1
36331 IF(ITRY(INUM).GT.200) THEN
36332 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
36333 IF(MSTU(21).GE.1) RETURN
36336 IF(KFL(1).GT.40) GOTO 430
36337 IF(KSH(KFL(1)).EQ.0) GOTO 430
36339 IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
36340 &ISIGN(2,K(IEP(1),2))
36341 IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
36343 C...Select side for interference with initial state partons.
36344 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
36347 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
36349 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
36350 IF(PYR(0).GT.0.5D0) ISII(III)=1
36351 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
36353 IF(PYR(0).GT.0.5D0) ISII(III)=2
36357 C...Calculate allowed z range.
36360 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36363 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
36364 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
36366 IF(MOD(MSTJ(43),2).EQ.1) THEN
36368 ZCE=PMTH(2,22)/PMED
36370 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
36371 IF(ZC.LT.1D-4) ZC=(PMTH(2,21)/PMED)**2
36372 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,22)/PMED)**2)))
36373 IF(ZCE.LT.1D-4) ZCE=(PMTH(2,22)/PMED)**2
36376 ZCE=MIN(ZCE,0.491D0)
36377 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
36378 &MIN(ZC,ZCE).GT.0.49D0)) THEN
36379 P(IEP(1),5)=PMTH(1,IFL)
36380 V(IEP(1),5)=P(IEP(1),5)**2
36384 C...Integral of Altarelli-Parisi z kernel for QCD.
36385 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
36386 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*(0.5D0-ZC)
36387 ELSEIF(MSTJ(49).EQ.0) THEN
36388 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
36390 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
36391 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
36392 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
36393 ELSEIF(MSTJ(49).EQ.1) THEN
36394 FBR=(1D0-2D0*ZC)/3D0
36395 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4D0*FBR
36397 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
36398 ELSEIF(KFL(1).EQ.21) THEN
36399 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
36401 FBR=2D0*LOG((1D0-ZC)/ZC)
36404 C...Reset QCD probability for lepton.
36405 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0D0
36407 C...Integral of Altarelli-Parisi kernel for photon emission.
36408 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36409 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
36410 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
36413 C...Inner veto algorithm starts. Find maximum mass for evolution.
36414 390 PMS=V(IEP(1),5)
36419 IF(KFL(I).LE.40) THEN
36421 IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
36422 & ISIGN(2,K(IEP(I),2))
36423 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
36427 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
36430 C...Select mass for daughter in QCD evolution.
36432 DO 410 IFF=4,MSTJ(45)
36433 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
36435 IF(FBR.LT.1D-3) THEN
36437 ELSEIF(MSTJ(44).LE.0) THEN
36438 PMSQCD=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
36439 ELSEIF(MSTJ(44).EQ.1) THEN
36440 PMSQCD=4D0*ALAMS*(0.25D0*PMS/ALAMS)**(PYR(0)**(B0/FBR))
36442 PMSQCD=PMS*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
36444 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
36448 C...Select mass for daughter in QED evolution.
36449 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36450 PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
36451 IF(ZCE.GT.0.49D0.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
36453 IF(PMSQED.GT.PMSQCD) THEN
36459 C...Check whether daughter mass below cutoff.
36460 P(IEP(1),5)=SQRT(V(IEP(1),5))
36461 IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
36462 P(IEP(1),5)=PMTH(1,IFL)
36463 V(IEP(1),5)=P(IEP(1),5)**2
36467 C...Select z value of branching: q -> qgamma.
36469 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
36470 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36473 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
36474 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
36475 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36476 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36478 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5D0-ZC).LT.PYR(0)*FBR) THEN
36479 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36480 IF(PYR(0).GT.0.5D0) Z=1D0-Z
36481 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390
36483 ELSEIF(MSTJ(49).NE.1) THEN
36484 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36485 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390
36486 KFLB=1+INT(MSTJ(45)*PYR(0))
36487 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36488 IF(PMQ.GE.1D0) GOTO 390
36489 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
36490 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.
36491 & PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390
36494 C...Ditto for scalar gluon model.
36495 ELSEIF(KFL(1).NE.21) THEN
36496 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
36498 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
36499 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36502 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36503 KFLB=1+INT(MSTJ(45)*PYR(0))
36504 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36505 IF(PMQ.GE.1D0) GOTO 390
36508 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
36509 IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
36510 IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390
36513 C...Check if z consistent with chosen m.
36514 IF(KFL(1).EQ.21) THEN
36515 KFLGD1=IABS(K(IEP(1),5))
36519 KFLGD2=IABS(K(IEP(1),5))
36523 ELSEIF(NEP.GE.3) THEN
36525 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36526 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
36528 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
36529 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
36531 IF(MOD(MSTJ(43),2).EQ.1) THEN
36533 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
36534 PMQTH3=0.5D0*PARJ(82)
36535 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36536 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
36537 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
36538 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36542 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
36547 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
36548 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
36550 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36552 C...Width suppression for q -> q + g.
36553 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
36555 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
36559 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
36560 IF(MSTJ(40).EQ.1) THEN
36561 IF(CHI.LT.PYR(0)) GOTO 390
36562 ELSEIF(MSTJ(40).EQ.2) THEN
36563 IF(1D0-CHI.LT.PYR(0)) GOTO 390
36567 C...Three-jet matrix element correction.
36568 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
36569 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
36570 X2=1D0-V(IEP(1),5)/V(NS+1,5)
36571 X3=(1D0-X1)+(1D0-X2)
36574 KI2=K(IPA(3-INUM),2)
36575 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0
36576 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0
36577 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
36578 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
36579 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
36580 ELSEIF(MSTJ(49).NE.1) THEN
36581 WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
36582 & (1D0-X2)/X3*(X2/(2D0-X1))**2
36584 IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5D0*QME**2-
36585 & (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-7,1D0-X1)+
36586 & (1D0-X1)/MAX(1D-7,1D0-X2))
36588 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
36590 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
36593 IF(WME.LT.PYR(0)*WSHOW) GOTO 390
36595 C...Impose angular ordering by rejection of nonordered emission.
36596 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
36599 IF(IEP(1).EQ.N+2) ZM=1D0-V(IM,1)
36600 THE2ID=Z*(1D0-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
36602 420 IF(K(IAOM,5).EQ.22) THEN
36604 IF(K(IAOM,3).LE.NS) MAOM=0
36605 IF(MAOM.EQ.1) GOTO 420
36608 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
36609 IF(THE2ID.LT.THE2IM) GOTO 390
36613 C...Impose user-defined maximum angle at first branching.
36614 IF(MSTJ(48).EQ.1) THEN
36615 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
36616 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
36617 IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36618 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
36619 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36620 IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36621 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
36622 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36623 IF(THE2ID.LT.1D0/PARJ(86)**2) GOTO 390
36627 C...Impose angular constraint in first branching from interference
36628 C...with initial state partons.
36629 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
36630 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
36631 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
36632 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
36633 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
36634 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
36638 C...End of inner veto algorithm. Check if only one leg evolved so far.
36642 IF(NEP.EQ.1) GOTO 460
36643 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
36645 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
36646 IF(KSH(KFLD(I)).EQ.1) THEN
36648 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36649 & ISIGN(2,K(N+I,2))
36650 IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
36655 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
36657 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
36658 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
36659 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
36660 PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S-
36661 & PA1S**2-PA2S**2-PA3S**2)/PA1S
36662 IF(PTS.LE.0D0) GOTO 330
36663 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
36665 KFLDA=IABS(K(I1,2))
36666 IF(KFLDA.GT.40) GOTO 450
36667 IF(KSH(KFLDA).EQ.0) GOTO 450
36669 IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
36671 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
36672 IF(KFLDA.EQ.21) THEN
36673 KFLGD1=IABS(K(I1,5))
36677 KFLGD2=IABS(K(I1,5))
36680 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36681 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
36683 IF(I1.EQ.N+1) ZM=V(IM,1)
36684 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
36685 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
36686 & 4D0*V(N+1,5)*V(N+2,5))
36687 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
36689 IF(MOD(MSTJ(43),2).EQ.1) THEN
36690 PMQTH3=0.5D0*PARJ(82)
36691 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36693 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
36694 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
36695 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
36696 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36700 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
36705 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
36706 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
36707 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
36709 IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36711 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
36714 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
36715 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
36716 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
36717 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
36718 IF(ISL(1).EQ.1) ISL(2)=0
36719 IF(ISL(1).EQ.0) ISLM=1
36720 IF(ISL(2).EQ.0) ISLM=2
36722 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
36725 IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
36728 IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
36730 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
36731 &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
36732 PMQ1=V(N+1,5)/V(IM,5)
36733 PMQ2=V(N+2,5)/V(IM,5)
36734 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
36739 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
36742 C...Accepted branch. Construct four-momentum for initial partons.
36748 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
36750 P(N+1,4)=P(IPA(1),4)
36752 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
36753 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
36756 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
36761 P(N+2,4)=P(IM,5)-PED1
36764 ELSEIF(NEP.EQ.3) THEN
36767 P(N+1,3)=SQRT(MAX(0D0,PA1S))
36770 P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3)
36773 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
36778 C...Construct transverse momentum for ordinary branching in shower.
36781 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
36782 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
36783 IF(PZM.LE.0D0) THEN
36785 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
36786 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
36787 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
36789 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
36791 PT=SQRT(MAX(0D0,PTS))
36793 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
36795 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
36796 & .AND.IAU.NE.0) THEN
36797 IF(K(IGM,3).NE.0) MAZIP=1
36799 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
36800 IF(MAZIP.EQ.0) ZAU=0D0
36801 IF(K(IGM,2).NE.21) THEN
36802 HAZIP=2D0*ZAU/(1D0+ZAU**2)
36804 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
36806 IF(K(N+1,2).NE.21) THEN
36807 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
36809 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
36813 C...Find coefficient of azimuthal asymmetry due to soft gluon
36816 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
36817 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
36818 IF(K(IGM,3).NE.0) MAZIC=N+1
36819 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
36820 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36821 & ZM.GT.0.5D0) MAZIC=N+2
36822 IF(K(IAU,2).EQ.22) MAZIC=0
36824 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
36826 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
36827 IF(MAZIC.EQ.0) ZGM=1D0
36828 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
36829 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
36830 HAZIC=MIN(0.95D0,HAZIC)
36834 C...Construct kinematics for ordinary branching in shower.
36835 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
36836 IF(MOD(MSTJ(43),2).EQ.1) THEN
36837 P(N+1,4)=PEM*V(IM,1)
36839 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
36840 & SQRT(PMLS)*ZM)/V(IM,5)
36843 P(N+1,1)=PT*COS(PHI)
36844 P(N+1,2)=PT*SIN(PHI)
36845 IF(PZM.GT.0D0) THEN
36846 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
36847 & 2D0*PEM*P(N+1,4))/PZM
36853 P(N+2,3)=PZM-P(N+1,3)
36854 P(N+2,4)=PEM-P(N+1,4)
36855 IF(MSTJ(43).LE.2) THEN
36856 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
36857 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
36861 C...Rotate and boost daughters.
36863 IF(MSTJ(43).LE.2) THEN
36864 BEX=P(IGM,1)/P(IGM,4)
36865 BEY=P(IGM,2)/P(IGM,4)
36866 BEZ=P(IGM,3)/P(IGM,4)
36867 GA=P(IGM,4)/P(IGM,5)
36868 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
36877 THE=PYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
36878 & (P(IM,2)+GABEP*BEY)**2))
36879 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
36881 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
36882 & SIN(THE)*COS(PHI)*P(I,3)
36883 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
36884 & SIN(THE)*SIN(PHI)*P(I,3)
36885 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
36887 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
36888 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
36889 P(I,1)=DP(1)+DGABP*BEX
36890 P(I,2)=DP(2)+DGABP*BEY
36891 P(I,3)=DP(3)+DGABP*BEZ
36892 P(I,4)=GA*(DP(4)+DBP)
36896 C...Weight with azimuthal distribution, if required.
36897 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
36903 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
36904 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
36905 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
36907 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
36908 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
36910 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
36911 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
36912 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
36913 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
36914 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
36915 IF(MAZIP.NE.0) THEN
36916 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
36919 IF(MAZIC.NE.0) THEN
36920 IF(MAZIC.EQ.N+2) CAD=-CAD
36921 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
36922 & .LT.PYR(0)) GOTO 470
36927 C...Azimuthal anisotropy due to interference with initial state partons.
36928 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
36929 &K(N+2,2).EQ.21)) THEN
36931 IF(ISII(III).GE.1) THEN
36933 IF(K(N+1,2).NE.21) IAZIID=N+2
36934 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36935 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
36936 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
36937 IF(III.EQ.2) THEIID=PARU(1)-THEIID
36938 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
36939 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
36940 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
36941 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
36942 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
36943 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
36944 & .LT.PYR(0)) GOTO 470
36948 C...Continue loop over partons that may branch, until none left.
36949 IF(IGM.GE.0) K(IM,1)=14
36952 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
36953 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36954 IF(MSTU(21).GE.1) N=NS
36955 IF(MSTU(21).GE.1) RETURN
36959 C...Set information on imagined shower initiator.
36960 510 IF(NPA.GE.2) THEN
36964 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
36972 C...Reconstruct string drawing information.
36973 DO 520 I=NS+1+IIM,N
36974 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
36976 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
36977 & IABS(K(I,2)).LE.18) THEN
36979 ELSEIF(K(I,1).LE.10) THEN
36980 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
36981 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
36982 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
36983 ID1=MOD(K(I,4),MSTU(5))
36984 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
36985 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
36986 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36987 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
36988 K(ID1,4)=K(ID1,4)+MSTU(5)*I
36989 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
36990 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
36991 K(ID2,5)=K(ID2,5)+MSTU(5)*I
36993 ID1=MOD(K(I,4),MSTU(5))
36995 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36996 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
36997 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
36998 K(ID1,4)=K(ID1,4)+MSTU(5)*I
36999 K(ID1,5)=K(ID1,5)+MSTU(5)*I
37009 C...Transformation from CM frame.
37015 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
37016 & /(1D0+GA)-P(IPA(1),4))
37023 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
37024 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
37025 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
37027 CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
37028 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
37029 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
37032 CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0)
37035 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
37037 C...Decay vertex of shower.
37044 C...Delete trivial shower, else connect initiators.
37045 IF(N.EQ.NS+NPA+IIM) THEN
37050 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
37051 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
37052 K(NS+IIM+IP,3)=IPA(IP)
37053 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
37054 IF(K(NS+IIM+IP,1).NE.1) THEN
37055 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
37056 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
37064 C*********************************************************************
37066 *$ CREATE PYBOEI.FOR
37069 C...Modifies an event so as to approximately take into account
37070 C...Bose-Einstein effects according to a simple phenomenological
37071 C...parametrization.
37073 SUBROUTINE PYBOEI(NSAV)
37075 C...Double precision and integer declarations.
37076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37077 INTEGER PYK,PYCHGE,PYCOMP
37079 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37080 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37081 SAVE /PYJETS/,/PYDAT1/
37082 C...Local arrays and data.
37083 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
37084 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
37086 C...Boost event to overall CM frame. Calculate CM energy.
37087 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
37093 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
37094 & .AND.K(I,3).GT.0) THEN
37095 KFMA=IABS(K(K(I,3),2))
37096 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
37098 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
37100 DPS(J)=DPS(J)+P(I,J)
37103 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
37107 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
37110 C...Reserve copy of particles by species at end of record.
37112 DO 160 IBE=1,MIN(9,MSTJ(52))
37113 NBE(IBE)=NBE(IBE-1)
37115 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
37116 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
37117 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
37118 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
37121 NBE(IBE)=NBE(IBE)+1
37128 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
37130 C...Tabulate integral for subsequent momentum shift.
37131 DO 220 IBE=1,MIN(9,MSTJ(52))
37132 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
37133 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
37135 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
37136 & NBE(7)-NBE(6)).LE.1) GOTO 180
37137 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
37138 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
37139 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
37140 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
37141 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
37142 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
37143 IF(MSTJ(51).EQ.1) THEN
37144 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
37145 BEEX=EXP(0.5D0*QDEL/PARJ(93))
37146 BERT=EXP(-QDEL/PARJ(93))
37148 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
37151 QBIN=QDEL*(IBIN-0.5D0)
37152 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
37153 IF(MSTJ(51).EQ.1) THEN
37155 BEI(IBIN)=BEI(IBIN)*BEEX
37157 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
37159 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
37162 C...Loop through particle pairs and find old relative momentum.
37163 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
37165 DO 200 I2M=I1M+1,NBE(IBE)
37167 Q2OLD=MAX(0D0,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
37168 & (P(I1,2)+ P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
37169 & (P(I1,5)+P(I2,5))**2)
37172 C...Calculate new relative momentum.
37173 IF(QOLD.LT.1D-3*QDEL) THEN
37175 ELSEIF(QOLD.LE.QDEL) THEN
37177 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
37180 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
37181 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
37182 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
37184 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
37186 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
37188 C...Calculate and save shift to be performed on three-momenta.
37189 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
37190 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
37191 HA=0.5D0*(1D0-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
37193 PD=HA*(P(I2,J)-P(I1,J))
37194 P(I1M,J)=P(I1M,J)+PD
37195 P(I2M,J)=P(I2M,J)-PD
37201 C...Shift momenta and recalculate energies.
37202 DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
37205 P(I,J)=P(I,J)+P(IM,J)
37207 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
37210 C...Rescale all momenta for energy conservation.
37214 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
37216 PQS=PQS+P(I,5)**2/P(I,4)
37218 FAC=(PECM-PQS)/(PES-PQS)
37220 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
37224 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
37227 C...Boost back to correct reference frame.
37228 280 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
37230 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
37236 C*********************************************************************
37238 *$ CREATE PYMASS.FOR
37241 C...Gives the mass of a particle/parton.
37243 FUNCTION PYMASS(KF)
37245 C...Double precision and integer declarations.
37246 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37247 INTEGER PYK,PYCHGE,PYCOMP
37249 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37250 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37251 SAVE /PYDAT1/,/PYDAT2/
37253 C...Reset variables. Compressed code. Special case for popcorn diquarks.
37262 C...Guarantee use of constituent masses for internal checks.
37263 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
37264 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
37265 PARF(106)=PMAS(6,1)
37266 PARF(107)=PMAS(7,1)
37267 PARF(108)=PMAS(8,1)
37269 PYMASS=PARF(100+KFA)
37270 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
37271 ELSEIF(MSTJ(93).EQ.1) THEN
37272 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
37274 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
37277 C...Other masses can be read directly off table.
37282 C...Optional mass broadening according to truncated Breit-Wigner
37283 C...(either in m or in m^2).
37284 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
37285 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
37286 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
37287 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
37290 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
37291 & (PM0*PMAS(KC,2)))
37292 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
37293 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
37294 & (PMUPP-PMLOW)*PYR(0))))
37302 C*********************************************************************
37304 *$ CREATE PYNAME.FOR
37307 C...Gives the particle/parton name as a character string.
37309 SUBROUTINE PYNAME(KF,CHAU)
37311 C...Double precision and integer declarations.
37312 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37313 INTEGER PYK,PYCHGE,PYCOMP
37315 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37316 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37317 COMMON/PYDAT4/CHAF(500,2)
37319 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
37320 C...Local character variable.
37323 C...Read out code with distinction particle/antiparticle.
37326 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
37332 C*********************************************************************
37334 *$ CREATE PYCHGE.FOR
37337 C...Gives three times the charge for a particle/parton.
37339 FUNCTION PYCHGE(KF)
37341 C...Double precision and integer declarations.
37342 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37343 INTEGER PYK,PYCHGE,PYCOMP
37345 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37348 C...Read out charge and change sign for antiparticle.
37351 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
37356 C*********************************************************************
37358 *$ CREATE PYCOMP.FOR
37361 C...Compress the standard KF codes for use in mass and decay arrays;
37362 C...also checks whether a given code actually is defined.
37364 FUNCTION PYCOMP(KF)
37366 C...Double precision and integer declarations.
37367 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37368 INTEGER PYK,PYCHGE,PYCOMP
37370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37372 SAVE /PYDAT1/,/PYDAT2/
37373 C...Local arrays and saved data.
37374 DIMENSION KFORD(100:500),KCORD(101:500)
37375 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
37377 C...Whenever necessary reorder codes for faster search.
37378 IF(MSTU(20).EQ.0) THEN
37383 IF(KFA.LE.100) GOTO 120
37385 DO 100 I1=NFORD-1,0,-1
37386 IF(KFA.GE.KFORD(I1)) GOTO 110
37387 KFORD(I1+1)=KFORD(I1)
37388 KCORD(I1+1)=KCORD(I1)
37390 110 KFORD(I1+1)=KFA
37398 C...Fast action if same code as in latest call.
37399 IF(KF.EQ.KFLAST) THEN
37404 C...Starting values. Remove internal diquark flags.
37407 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
37408 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
37410 C...Simple cases: direct translation.
37411 IF(KFA.GT.KFORD(NFORD)) THEN
37412 ELSEIF(KFA.LE.100) THEN
37415 C...Else binary search.
37419 130 IAVG=(IMIN+IMAX)/2
37420 IF(KFORD(IAVG).GT.KFA) THEN
37422 IF(IMAX.GT.IMIN+1) GOTO 130
37423 ELSEIF(KFORD(IAVG).LT.KFA) THEN
37425 IF(IMAX.GT.IMIN+1) GOTO 130
37431 C...Check if antiparticle allowed.
37432 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
37433 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
37436 C...Save codes for possible future fast action.
37443 C*********************************************************************
37445 *$ CREATE PYERRM.FOR
37448 C...Informs user of errors in program execution.
37450 SUBROUTINE PYERRM(MERR,CHMESS)
37452 C...Double precision and integer declarations.
37453 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37454 INTEGER PYK,PYCHGE,PYCOMP
37456 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37457 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37458 SAVE /PYJETS/,/PYDAT1/
37459 C...Local character variable.
37460 CHARACTER CHMESS*(*)
37462 C...Write first few warnings, then be silent.
37463 IF(MERR.LE.10) THEN
37464 MSTU(27)=MSTU(27)+1
37466 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
37467 & MERR,MSTU(31),CHMESS
37469 C...Write first few errors, then be silent or stop program.
37470 ELSEIF(MERR.LE.20) THEN
37471 MSTU(23)=MSTU(23)+1
37473 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
37474 & MERR-10,MSTU(31),CHMESS
37475 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
37476 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
37477 WRITE(MSTU(11),5200)
37478 IF(MERR.NE.17) CALL PYLIST(2)
37482 C...Stop program in case of irreparable error.
37484 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
37488 C...Formats for output.
37489 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
37490 &' PYEXEC calls:'/5X,A)
37491 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
37492 &' PYEXEC calls:'/5X,A)
37493 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
37495 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
37496 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
37501 C*********************************************************************
37503 *$ CREATE PYALEM.FOR
37506 C...Calculates the running alpha_electromagnetic.
37508 FUNCTION PYALEM(Q2)
37510 C...Double precision and integer declarations.
37511 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37512 INTEGER PYK,PYCHGE,PYCOMP
37514 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37517 C...Calculate real part of photon vacuum polarization.
37518 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
37519 C...For hadrons use parametrization of H. Burkhardt et al.
37520 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
37521 AEMPI=PARU(101)/(3D0*PARU(1))
37522 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
37524 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
37526 ELSEIF(MSTU(101).EQ.2) THEN
37527 RPIGG=1D0-PARU(101)/PARU(103)
37528 ELSEIF(Q2.LT.0.09D0) THEN
37529 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
37530 ELSEIF(Q2.LT.9D0) THEN
37531 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
37532 & 0.00238D0*LOG(1D0+3.927D0*Q2)
37533 ELSEIF(Q2.LT.1D4) THEN
37534 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
37535 & 0.00299D0*LOG(1D0+Q2)
37537 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
37538 & 0.00293D0*LOG(1D0+Q2)
37541 C...Calculate running alpha_em.
37542 PYALEM=PARU(101)/(1D0-RPIGG)
37548 C*********************************************************************
37550 *$ CREATE PYALPS.FOR
37553 C...Gives the value of alpha_strong.
37555 FUNCTION PYALPS(Q2)
37557 C...Double precision and integer declarations.
37558 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37559 INTEGER PYK,PYCHGE,PYCOMP
37561 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37562 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37563 SAVE /PYDAT1/,/PYDAT2/
37565 C...Constant alpha_strong trivial. Pick artificial Lambda.
37566 IF(MSTU(111).LE.0) THEN
37568 MSTU(118)=MSTU(112)
37570 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
37571 & ((33D0-2D0*MSTU(112))*PARU(111)))
37572 PARU(118)=PARU(111)
37576 C...Find effective Q2, number of flavours and Lambda.
37578 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
37581 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
37582 Q2THR=PARU(113)*PMAS(NF,1)**2
37583 IF(Q2EFF.LT.Q2THR) THEN
37585 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
37589 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
37590 Q2THR=PARU(113)*PMAS(NF+1,1)**2
37591 IF(Q2EFF.GT.Q2THR) THEN
37593 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
37597 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
37598 PARU(117)=SQRT(ALAM2)
37600 C...Evaluate first or second order alpha_strong.
37601 B0=(33D0-2D0*NF)/6D0
37602 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
37603 IF(MSTU(111).EQ.1) THEN
37604 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
37606 B1=(153D0-19D0*NF)/6D0
37607 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
37616 C*********************************************************************
37618 *$ CREATE PYANGL.FOR
37621 C...Reconstructs an angle from given x and y coordinates.
37623 FUNCTION PYANGL(X,Y)
37625 C...Double precision and integer declarations.
37626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37627 INTEGER PYK,PYCHGE,PYCOMP
37629 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37634 IF(R.LT.1D-20) RETURN
37635 IF(ABS(X)/R.LT.0.8D0) THEN
37636 PYANGL=SIGN(ACOS(X/R),Y)
37639 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
37640 PYANGL=PARU(1)-PYANGL
37641 ELSEIF(X.LT.0D0) THEN
37642 PYANGL=-PARU(1)-PYANGL
37649 C*********************************************************************
37654 C...Generates random numbers uniformly distributed between
37655 C...0 and 1, excluding the endpoints.
37657 **sr renamed for use of internal dpmjet3 random number generator
37658 FUNCTION XPYR(IDUMMY)
37661 C...Double precision and integer declarations.
37662 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37663 INTEGER PYK,PYCHGE,PYCOMP
37665 COMMON/PYDATR/MRPY(6),RRPY(100)
37667 C...Equivalence between commonblock and local variables.
37668 EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
37669 &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
37670 &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
37672 C...Initialize generation from given seed.
37673 IF(MRPY2.EQ.0) THEN
37674 IJ=MOD(MRPY1/30082,31329)
37675 KL=MOD(MRPY1,30082)
37676 I=MOD(IJ/177,177)+2
37678 K=MOD(KL/169,178)+1
37684 M=MOD(MOD(I*J,179)*K,179)
37689 IF(MOD(L*M,64).GE.32) S=S+T
37696 TWOM24=0.5D0*TWOM24
37698 RRPY98=362436D0*TWOM24
37699 RRPY99=7654321D0*TWOM24
37700 RRPY00=16777213D0*TWOM24
37707 C...Generate next random number.
37708 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
37709 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37712 IF(MRPY4.EQ.0) MRPY4=97
37714 IF(MRPY5.EQ.0) MRPY5=97
37715 RRPY98=RRPY98-RRPY99
37716 IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
37718 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37719 IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
37721 C...Update counters. Random number to output.
37723 IF(MRPY3.EQ.1000000000) THEN
37732 C*********************************************************************
37734 *$ CREATE PYRGET.FOR
37737 C...Dumps the state of the random number generator on a file
37738 C...for subsequent startup from this state onwards.
37740 SUBROUTINE PYRGET(LFN,MOVE)
37742 C...Double precision and integer declarations.
37743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37744 INTEGER PYK,PYCHGE,PYCOMP
37746 COMMON/PYDATR/MRPY(6),RRPY(100)
37748 C...Local character variable.
37751 C...Backspace required number of records (or as many as there are).
37753 NBCK=MIN(MRPY(6),-MOVE)
37755 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
37757 MRPY(6)=MRPY(6)-NBCK
37760 C...Unformatted write on unit LFN.
37761 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37762 &(RRPY(I2),I2=1,100)
37767 110 WRITE(CHERR,'(I8)') IERR
37768 CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
37774 C*********************************************************************
37776 *$ CREATE PYRSET.FOR
37779 C...Reads a state of the random number generator from a file
37780 C...for subsequent generation from this state onwards.
37782 SUBROUTINE PYRSET(LFN,MOVE)
37784 C...Double precision and integer declarations.
37785 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37786 INTEGER PYK,PYCHGE,PYCOMP
37788 COMMON/PYDATR/MRPY(6),RRPY(100)
37790 C...Local character variable.
37793 C...Backspace required number of records (or as many as there are).
37795 NBCK=MIN(MRPY(6),-MOVE)
37797 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
37799 MRPY(6)=MRPY(6)-NBCK
37802 C...Unformatted read from unit LFN.
37805 READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37806 & (RRPY(I2),I2=1,100)
37808 MRPY(6)=MRPY(6)+NFOR
37812 120 WRITE(CHERR,'(I8)') IERR
37813 CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
37819 C*********************************************************************
37821 *$ CREATE PYROBO.FOR
37824 C...Performs rotations and boosts.
37826 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
37828 C...Double precision and integer declarations.
37829 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37830 INTEGER PYK,PYCHGE,PYCOMP
37832 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37833 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37834 SAVE /PYJETS/,/PYDAT1/
37836 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
37838 C...Find and check range of rotation/boost.
37840 IF(IMIN.LE.0) IMIN=1
37841 IF(MSTU(1).GT.0) IMIN=MSTU(1)
37843 IF(IMAX.LE.0) IMAX=N
37844 IF(MSTU(2).GT.0) IMAX=MSTU(2)
37845 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
37846 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
37850 C...Optional resetting of V (when not set before.)
37851 IF(MSTU(33).NE.0) THEN
37852 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
37860 C...Rotate, typically from z axis to direction (theta,phi).
37861 IF(THE**2+PHI**2.GT.1D-20) THEN
37862 ROT(1,1)=COS(THE)*COS(PHI)
37864 ROT(1,3)=SIN(THE)*COS(PHI)
37865 ROT(2,1)=COS(THE)*SIN(PHI)
37867 ROT(2,3)=SIN(THE)*SIN(PHI)
37872 IF(K(I,1).LE.0) GOTO 140
37878 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
37879 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
37884 C...Boost, typically from rest to momentum/energy=beta.
37885 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
37889 DB=SQRT(DBX**2+DBY**2+DBZ**2)
37891 IF(DB.GT.EPS1) THEN
37892 C...Rescale boost vector if too close to unity.
37893 CALL PYERRM(3,'(PYROBO:) boost vector too large')
37899 DGA=1D0/SQRT(1D0-DB**2)
37901 IF(K(I,1).LE.0) GOTO 160
37906 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
37907 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
37908 P(I,1)=DP(1)+DGABP*DBX
37909 P(I,2)=DP(2)+DGABP*DBY
37910 P(I,3)=DP(3)+DGABP*DBZ
37911 P(I,4)=DGA*(DP(4)+DBP)
37912 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
37913 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
37914 V(I,1)=DV(1)+DGABV*DBX
37915 V(I,2)=DV(2)+DGABV*DBY
37916 V(I,3)=DV(3)+DGABV*DBZ
37917 V(I,4)=DGA*(DV(4)+DBV)
37924 C*********************************************************************
37926 *$ CREATE PYEDIT.FOR
37929 C...Performs global manipulations on the event record, in particular
37930 C...to exclude unstable or undetectable partons/particles.
37932 SUBROUTINE PYEDIT(MEDIT)
37934 C...Double precision and integer declarations.
37935 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37936 INTEGER PYK,PYCHGE,PYCOMP
37938 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37939 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37940 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37941 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37943 DIMENSION NS(2),PTS(2),PLS(2)
37945 C...Remove unwanted partons/particles.
37946 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
37948 IF(MSTU(2).GT.0) IMAX=MSTU(2)
37949 I1=MAX(1,MSTU(1))-1
37950 DO 110 I=MAX(1,MSTU(1)),IMAX
37951 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
37952 IF(MEDIT.EQ.1) THEN
37953 IF(K(I,1).GT.10) GOTO 110
37954 ELSEIF(MEDIT.EQ.2) THEN
37955 IF(K(I,1).GT.10) GOTO 110
37957 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
37959 ELSEIF(MEDIT.EQ.3) THEN
37960 IF(K(I,1).GT.10) GOTO 110
37962 IF(KC.EQ.0) GOTO 110
37963 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
37964 ELSEIF(MEDIT.EQ.5) THEN
37965 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
37967 IF(KC.EQ.0) GOTO 110
37968 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
37971 C...Pack remaining partons/particles. Origin no longer known.
37980 IF(I1.LT.N) MSTU(3)=0
37981 IF(I1.LT.N) MSTU(70)=0
37984 C...Selective removal of class of entries. New position of retained.
37985 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
37988 K(I,3)=MOD(K(I,3),MSTU(5))
37989 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
37990 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
37991 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
37992 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
37993 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
37994 & K(I,2).EQ.94)) GOTO 120
37995 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
37997 K(I,3)=K(I,3)+MSTU(5)*I1
38000 C...Find new event history information and replace old.
38002 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
38005 130 IM=MOD(K(ID,3),MSTU(5))
38006 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
38007 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
38008 & K(IM,2).NE.94) THEN
38012 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
38013 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
38018 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
38019 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
38020 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
38021 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
38022 & K(K(I,4),3)/MSTU(5)
38023 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
38024 & K(K(I,5),3)/MSTU(5)
38026 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
38027 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
38028 KCD=MOD(K(I,4),MSTU(5))
38029 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
38030 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
38031 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
38032 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
38033 KCD=MOD(K(I,5),MSTU(5))
38034 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
38035 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
38039 C...Pack remaining entries.
38044 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
38051 K(I1,3)=MOD(K(I1,3),MSTU(5))
38053 IF(I.EQ.MSTU(90+IZ)) THEN
38054 MSTU(90)=MSTU(90)+1
38055 MSTU(90+MSTU(90))=I1
38056 PARU(90+MSTU(90))=PARU(90+IZ)
38060 IF(I1.LT.N) MSTU(3)=0
38061 IF(I1.LT.N) MSTU(70)=0
38064 C...Fill in some missing daughter pointers (lost in colour flow).
38065 ELSEIF(MEDIT.EQ.16) THEN
38067 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
38068 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
38069 C...Find daughters who point to mother.
38071 IF(K(I1,3).NE.I) THEN
38072 ELSEIF(K(I,4).EQ.0) THEN
38078 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38079 IF(K(I,4).NE.0) GOTO 220
38080 C...Find daughters who point to documentation version of mother.
38082 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
38083 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
38084 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
38086 IF(K(I1,3).NE.IM) THEN
38087 ELSEIF(K(I,4).EQ.0) THEN
38093 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38094 IF(K(I,4).NE.0) GOTO 220
38095 C...Find daughters who point to documentation daughters who,
38096 C...in their turn, point to documentation mother.
38100 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
38102 IF(ID1.EQ.IM) ID1=I1
38106 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
38107 ELSEIF(K(I,4).EQ.0) THEN
38113 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38116 C...Save top entries at bottom of PYJETS commonblock.
38117 ELSEIF(MEDIT.EQ.21) THEN
38118 IF(2*N.GE.MSTU(4)) THEN
38119 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
38124 K(MSTU(4)-I,J)=K(I,J)
38125 P(MSTU(4)-I,J)=P(I,J)
38126 V(MSTU(4)-I,J)=V(I,J)
38131 C...Restore bottom entries of commonblock PYJETS to top.
38132 ELSEIF(MEDIT.EQ.22) THEN
38133 DO 260 I=1,MSTU(32)
38135 K(I,J)=K(MSTU(4)-I,J)
38136 P(I,J)=P(MSTU(4)-I,J)
38137 V(I,J)=V(MSTU(4)-I,J)
38142 C...Mark primary entries at top of commonblock PYJETS as untreated.
38143 ELSEIF(MEDIT.EQ.23) THEN
38148 IF(K(KH,1).GT.20) KH=0
38150 IF(KH.NE.0) GOTO 280
38152 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
38156 C...Place largest axis along z axis and second largest in xy plane.
38157 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
38158 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
38159 & P(MSTU(61),2)),0D0,0D0,0D0)
38160 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
38161 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
38162 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
38163 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
38164 IF(MEDIT.EQ.31) RETURN
38166 C...Rotate to put slim jet along +z axis.
38173 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
38174 IF(MSTU(41).GE.2) THEN
38176 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
38177 & KC.EQ.18) GOTO 300
38178 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
38181 IS=2D0-SIGN(0.5D0,P(I,3))
38183 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
38185 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
38186 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
38188 C...Rotate to put second largest jet into -z,+x quadrant.
38190 IF(P(I,3).GE.0D0) GOTO 310
38191 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
38192 IF(MSTU(41).GE.2) THEN
38194 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
38195 & KC.EQ.18) GOTO 310
38196 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
38199 IS=2D0-SIGN(0.5D0,P(I,1))
38200 PLS(IS)=PLS(IS)-P(I,3)
38202 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
38209 C*********************************************************************
38211 *$ CREATE PYLIST.FOR
38214 C...Gives program heading, or lists an event, or particle
38215 C...data, or current parameter values.
38217 SUBROUTINE PYLIST(MLIST)
38219 C...Double precision and integer declarations.
38220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38221 INTEGER PYK,PYCHGE,PYCOMP
38222 C...Parameter statement to help give large particle numbers.
38223 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
38225 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38226 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38227 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38228 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38229 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
38230 C...Local arrays, character variables and data.
38231 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
38233 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
38235 C...Initialization printout: version number and date of last change.
38236 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
38239 IF(MLIST.EQ.0) RETURN
38242 C...List event data, including additional lines after N.
38243 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
38244 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
38245 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
38246 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
38248 IF(MLIST.GE.2) LMX=16
38251 IF(MSTU(2).GT.0) IMAX=MSTU(2)
38252 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
38253 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
38255 C...Get particle name, pad it and check it is not too long.
38256 CALL PYNAME(K(I,2),CHAP)
38259 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
38263 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
38265 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
38268 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
38270 CHAC=CHDL(MDL)(1:2*LDL)//' '
38272 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
38273 & CHDL(MDL)(LDL+1:2*LDL)//' '
38274 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
38278 C...Add information on string connection.
38279 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
38283 IF(KC.NE.0) KCC=KCHG(KC,2)
38284 IF(IABS(K(I,2)).EQ.39) THEN
38285 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
38286 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
38288 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
38289 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
38290 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
38291 ELSEIF(KCC.NE.0) THEN
38293 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
38297 C...Write data for particle/jet.
38298 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
38299 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
38301 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
38302 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
38304 ELSEIF(MLIST.EQ.1) THEN
38305 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
38307 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
38308 & K(I,1).EQ.14)) THEN
38309 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
38310 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
38311 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
38314 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
38317 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
38319 C...Insert extra separator lines specified by user.
38320 IF(MSTU(70).GE.1) THEN
38322 DO 110 J=1,MIN(10,MSTU(70))
38323 IF(I.EQ.MSTU(70+J)) ISEP=1
38325 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
38326 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
38330 C...Sum of charges and momenta.
38334 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
38335 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
38336 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
38337 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
38338 ELSEIF(MLIST.EQ.1) THEN
38339 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
38341 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
38344 C...Give simple list of KF codes defined in program.
38345 ELSEIF(MLIST.EQ.11) THEN
38346 WRITE(MSTU(11),6600)
38348 CALL PYNAME(KF,CHAP)
38349 CALL PYNAME(-KF,CHAN)
38350 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38351 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38355 DO 150 KFLB=1,KFLA-(3-KFLS)/2
38356 KF=1000*KFLA+100*KFLB+KFLS
38357 CALL PYNAME(KF,CHAP)
38358 CALL PYNAME(-KF,CHAN)
38359 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38364 CALL PYNAME(KF,CHAP)
38365 WRITE(MSTU(11),6700) KF,CHAP
38367 CALL PYNAME(KF,CHAP)
38368 WRITE(MSTU(11),6700) KF,CHAP
38371 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
38372 IF(KMUL.EQ.5) KFLS=5
38374 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
38375 IF(KMUL.EQ.4) KFLR=2
38377 DO 180 KFLC=1,KFLB-1
38378 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
38379 CALL PYNAME(KF,CHAP)
38380 CALL PYNAME(-KF,CHAN)
38381 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38383 KF=10000*KFLR+110*KFLB+KFLS
38384 CALL PYNAME(KF,CHAP)
38385 WRITE(MSTU(11),6700) KF,CHAP
38389 CALL PYNAME(KF,CHAP)
38390 WRITE(MSTU(11),6700) KF,CHAP
38392 CALL PYNAME(KF,CHAP)
38393 WRITE(MSTU(11),6700) KF,CHAP
38399 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
38401 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
38402 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
38403 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
38404 CALL PYNAME(KF,CHAP)
38405 CALL PYNAME(-KF,CHAN)
38406 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38411 DO 250 KF=KSUSY1+1,KSUSY1+40
38412 CALL PYNAME(KF,CHAP)
38413 CALL PYNAME(-KF,CHAN)
38414 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38415 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38417 DO 260 KF=KSUSY2+1,KSUSY2+40
38418 CALL PYNAME(KF,CHAP)
38419 CALL PYNAME(-KF,CHAN)
38420 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38421 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38423 DO 270 KF=KEXCIT+1,KEXCIT+40
38424 CALL PYNAME(KF,CHAP)
38425 CALL PYNAME(-KF,CHAN)
38426 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38427 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38430 C...List parton/particle data table. Check whether to be listed.
38431 ELSEIF(MLIST.EQ.12) THEN
38432 WRITE(MSTU(11),6800)
38433 DO 300 KC=1,MSTU(6)
38435 IF(KF.EQ.0) GOTO 300
38436 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
38439 C...Find particle name and mass. Print information.
38440 CALL PYNAME(KF,CHAP)
38441 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
38442 CALL PYNAME(-KF,CHAN)
38443 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
38444 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
38446 C...Particle decay: channel number, branching ratios, matrix element,
38447 C...decay products.
38448 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38450 CALL PYNAME(KFDP(IDC,J),CHAD(J))
38452 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38457 C...List parameter value table.
38458 ELSEIF(MLIST.EQ.13) THEN
38459 WRITE(MSTU(11),7100)
38461 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
38465 C...Format statements for output on unit MSTU(11) (by default 6).
38466 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
38467 &5X,'KF orig p_x p_y p_z E m'/)
38468 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
38469 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
38470 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
38471 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
38472 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
38473 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
38474 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
38475 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
38476 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
38477 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
38478 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
38479 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
38480 5900 FORMAT(66X,5(1X,F12.3))
38481 6000 FORMAT(1X,78('='))
38482 6100 FORMAT(1X,130('='))
38483 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
38484 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
38485 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
38486 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
38488 6600 FORMAT(///20X,'List of KF codes in program'/)
38489 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
38490 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
38491 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
38492 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
38493 &1X,'ME',3X,'Br.rat.',4X,'decay products')
38494 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
38495 &1X,1P,E13.5,3X,I2)
38496 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
38497 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
38498 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
38499 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
38504 C*********************************************************************
38506 *$ CREATE PYLOGO.FOR
38509 C...Writes a logo for the program.
38513 C...Double precision and integer declarations.
38514 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38515 INTEGER PYK,PYCHGE,PYCOMP
38516 C...Parameter for length of information block.
38517 PARAMETER (IREFER=17)
38519 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38520 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38521 SAVE /PYDAT1/,/PYPARS/
38522 C...Local arrays and character variables.
38524 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
38525 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
38527 C...Data on months, logo, titles, and references.
38528 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
38529 &'Oct','Nov','Dec'/
38530 DATA (LOGO(J),J=1,19)/
38532 &' *:::!!:::::::::::* ',
38533 &' *::::::!!::::::::::::::* ',
38534 &' *::::::::!!::::::::::::::::* ',
38535 &' *:::::::::!!:::::::::::::::::* ',
38536 &' *:::::::::!!:::::::::::::::::* ',
38537 &' *::::::::!!::::::::::::::::*! ',
38538 &' *::::::!!::::::::::::::* !! ',
38539 &' !! *:::!!:::::::::::* !! ',
38540 &' !! !* -><- * !! ',
38550 DATA (LOGO(J),J=20,38)/
38551 &'Welcome to the Lund Monte Carlo!',
38553 &'PPP Y Y TTTTT H H III A ',
38554 &'P P Y Y T H H I A A ',
38555 &'PPP Y T HHHHH I AAAAA',
38556 &'P Y T H H I A A',
38557 &'P Y T H H III A A',
38559 &'This is PYTHIA version x.xxx ',
38560 &'Last date of change: xx xxx 199x',
38562 &'Now is xx xxx 199x at xx:xx:xx ',
38564 &'Disclaimer: this program comes ',
38565 &'without any guarantees. Beware ',
38566 &'of errors and use common sense ',
38567 &'when interpreting results. ',
38569 &'Copyright T. Sjostrand (1997) '/
38570 DATA (REFER(J),J=1,18)/
38571 &'An archive of program versions and d',
38572 &'ocumentation is found on the web: ',
38573 &'http://www.thep.lu.se/tf2/staff/torb',
38574 &'jorn/Pythia.html ',
38577 &'When you cite this program, currentl',
38578 &'y the official reference is ',
38579 &'T. Sjostrand, Computer Physics Commu',
38580 &'n. 82 (1994) 74. ',
38581 &'The supersymmetry extensions are des',
38583 &'S. Mrenna, Computer Physics Commun. ',
38584 &'101 (1997) 232 ',
38585 &'Also remember that the program, to a',
38586 &' large extent, represents original ',
38587 &'physics research. Other publications',
38588 &' of special relevance to your '/
38589 DATA (REFER(J),J=19,2*IREFER)/
38590 &'studies may therefore deserve separa',
38594 &'Main author: Torbjorn Sjostrand; Dep',
38595 &'artment of Theoretical Physics 2, ',
38596 &' Lund University, Solvegatan 14A, S',
38597 &'-223 62 Lund, Sweden; ',
38598 &' phone: + 46 - 46 - 222 48 16; e-ma',
38599 &'il: torbjorn@thep.lu.se ',
38600 &'SUSY author: Stephen Mrenna, Argonne',
38601 &' National Laboratory, ',
38602 &' 9700 South Cass Avenue, Argonne, I',
38604 &' phone: + 1 - 630 - 252 - 7615; e-m',
38605 &'ail: mrenna@hep.anl.gov '/
38607 C...Check that PYDATA linked.
38608 IF(MSTP(183)/10.NE.199) THEN
38609 WRITE(MSTU(11),'(1X,A)')
38610 & 'Error: PYDATA has not been linked.'
38611 WRITE(MSTU(11),'(1X,A)') 'Execution stopped!'
38614 C...Write current version number and current date+time.
38616 WRITE(VERS,'(I1)') MSTP(181)
38617 LOGO(28)(24:24)=VERS
38618 WRITE(SUBV,'(I3)') MSTP(182)
38619 LOGO(28)(26:28)=SUBV
38620 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
38621 WRITE(DATE,'(I2)') MSTP(185)
38622 LOGO(29)(22:23)=DATE
38623 LOGO(29)(25:27)=MONTH(MSTP(184))
38624 WRITE(YEAR,'(I4)') MSTP(183)
38625 LOGO(29)(29:32)=YEAR
38627 IF(IDATI(1).LE.0) THEN
38630 WRITE(DATE,'(I2)') IDATI(3)
38632 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
38633 WRITE(YEAR,'(I4)') IDATI(1)
38634 LOGO(31)(15:18)=YEAR
38635 WRITE(HOUR,'(I2)') IDATI(4)
38636 LOGO(31)(23:24)=HOUR
38637 WRITE(MINU,'(I2)') IDATI(5)
38638 LOGO(31)(26:27)=MINU
38639 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
38640 WRITE(SECO,'(I2)') IDATI(6)
38641 LOGO(31)(29:30)=SECO
38642 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
38646 C...Loop over lines in header. Define page feed and side borders.
38647 DO 100 ILIN=1,29+IREFER
38656 C...Separator lines and logos.
38657 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
38658 LINE(4:77)='***********************************************'//
38659 & '***************************'
38660 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
38661 LINE(6:37)=LOGO(ILIN-5)
38662 LINE(44:75)=LOGO(ILIN+14)
38663 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
38664 LINE(5:40)=REFER(2*ILIN-51)
38665 LINE(41:76)=REFER(2*ILIN-50)
38668 C...Write lines to appropriate unit.
38669 WRITE(MSTU(11),'(A79)') LINE
38675 C*********************************************************************
38677 *$ CREATE PYUPDA.FOR
38680 C...Facilitates the updating of particle and decay data
38681 C...by allowing it to be done in an external file.
38683 SUBROUTINE PYUPDA(MUPDA,LFN)
38685 C...Double precision and integer declarations.
38686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38687 INTEGER PYK,PYCHGE,PYCOMP
38689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38690 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38691 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38692 COMMON/PYDAT4/CHAF(500,2)
38694 COMMON/PYINT4/MWID(500),WIDS(500,5)
38695 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
38696 C...Local arrays, character variables and data.
38697 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
38698 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
38699 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
38700 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
38701 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
38702 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
38703 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
38705 C...Write header if not yet done.
38706 IF(MSTU(12).GE.1) CALL PYLIST(0)
38708 C...Write information on file for editing.
38709 IF(MUPDA.EQ.1) THEN
38711 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38712 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38713 & MWID(KC),MDCY(KC,1)
38714 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38715 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38716 & (KFDP(IDC,J),J=1,5)
38720 C...Read complete set of information from edited file or
38721 C...read partial set of new or updated information from edited file.
38722 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
38724 C...Reset counters.
38728 IF(MUPDA.EQ.2) THEN
38733 DO 130 KC=1,MSTU(6)
38734 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
38735 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
38739 C...Begin of loop: read new line; unknown whether particle or
38741 140 READ(LFN,5200,END=190) CHINL
38743 C...Identify particle code and whether already defined (for MUPDA=3).
38744 IF(CHINL(2:10).NE.' ') THEN
38747 IF(MUPDA.EQ.2) THEN
38760 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
38763 C...Remove duplicate old decay data.
38764 IF(KCREP.NE.0) THEN
38765 IDCREP=MDCY(KCREP,2)
38766 NDCREP=MDCY(KCREP,3)
38768 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
38770 DO 180 I=IDCREP,NDC-NDCREP
38771 MDME(I,1)=MDME(I+NDCREP,1)
38772 MDME(I,2)=MDME(I+NDCREP,2)
38773 BRAT(I)=BRAT(I+NDCREP)
38775 KFDP(I,J)=KFDP(I+NDCREP,J)
38786 C...Study line with particle data.
38787 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
38788 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
38789 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38790 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38791 & MWID(KC),MDCY(KC,1)
38795 C...Study line with decay data.
38798 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
38799 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
38800 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
38801 MDCY(KC,3)=MDCY(KC,3)+1
38802 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
38803 & (KFDP(NDC,J),J=1,5)
38806 C...End of loop; ensure that PYCOMP tables are updated.
38811 C...Perform possible tests that new information is consistent.
38814 DO 220 KC=1,MSTU(6)
38816 IF(KF.EQ.0) GOTO 220
38817 WRITE(CHKF,5300) KF
38818 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
38819 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
38820 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
38822 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38823 IF(MDME(IDC,2).GT.80) GOTO 210
38825 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
38829 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
38831 ELSEIF(PYCOMP(KP).EQ.0) THEN
38837 PMS=PMS-PMAS(KPC,1)
38838 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
38842 IF(KQ.NE.0) MERR=MAX(2,MERR)
38843 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
38845 IF(MERR.EQ.3) CALL PYERRM(17,
38846 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
38847 IF(MERR.EQ.2) CALL PYERRM(17,
38848 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
38849 IF(MERR.EQ.1) CALL PYERRM(7,
38850 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
38851 BRSUM=BRSUM+BRAT(IDC)
38853 WRITE(CHTMP,5500) BRSUM
38854 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
38855 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
38856 & CHTMP(9:16)//' for KF ='//CHKF)
38860 C...Write DATA statements for inclusion in program.
38861 ELSEIF(MUPDA.EQ.4) THEN
38863 C...Find out how many codes and decay channels are actually used.
38867 IF(KCHG(I,4).NE.0) THEN
38869 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
38873 C...Initialize writing of DATA statements for inclusion in program.
38876 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
38879 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
38883 C...Loop through variables for conversion to characters.
38885 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
38886 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
38887 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
38888 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
38889 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
38890 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
38891 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
38892 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
38893 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
38894 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
38895 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
38896 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
38897 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
38898 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
38899 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
38900 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
38901 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
38902 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
38903 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
38904 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
38905 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
38906 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
38908 C...Replace variables beyond what is properly defined.
38910 IF(IDIM.GT.KCC) CHTMP=' 0'
38911 ELSEIF(IVAR.LE.8) THEN
38912 IF(IDIM.GT.KCC) CHTMP=' 0.0'
38913 ELSEIF(IVAR.LE.11) THEN
38914 IF(IDIM.GT.KCC) CHTMP=' 0'
38915 ELSEIF(IVAR.LE.13) THEN
38916 IF(IDIM.GT.NDC) CHTMP=' 0'
38917 ELSEIF(IVAR.LE.14) THEN
38918 IF(IDIM.GT.NDC) CHTMP=' 0.0'
38919 ELSEIF(IVAR.LE.19) THEN
38920 IF(IDIM.GT.NDC) CHTMP=' 0'
38921 ELSEIF(IVAR.LE.21) THEN
38922 IF(IDIM.GT.KCC) CHTMP=' '
38924 IF(IDIM.GT.KCC) CHTMP=' 0'
38927 C...Length of variable, trailing decimal zeros, quotation marks.
38931 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
38932 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
38934 CHNEW=CHTMP(LLOW:LHIG)//' '
38936 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
38939 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
38940 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
38945 CHNEW(LNEW+1:LNEW+2)='D0'
38948 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
38949 DO 260 LL=LNEW,1,-1
38950 IF(CHNEW(LL:LL).EQ.'''') THEN
38952 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
38958 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
38962 C...Form composite character string, often including repetition counter.
38963 IF(CHNEW.NE.CHOLD) THEN
38970 IF(NRPT.GE.2) LRPT=LNEW+3
38971 IF(NRPT.GE.10) LRPT=LNEW+4
38972 IF(NRPT.GE.100) LRPT=LNEW+5
38973 IF(NRPT.GE.1000) LRPT=LNEW+6
38976 WRITE(CHTMP,5400) NRPT
38978 IF(NRPT.GE.10) LRPT=2
38979 IF(NRPT.GE.100) LRPT=3
38980 IF(NRPT.GE.1000) LRPT=4
38981 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
38985 C...Add characters to end of line, to new line (after storing old line),
38986 C...or to new block of lines (after writing old block).
38987 IF(LLIN+LCOM.LE.70) THEN
38988 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
38990 ELSEIF(NLIN.LE.19) THEN
38991 CHLIN(LLIN+1:72)=' '
38994 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
38997 CHLIN(LLIN:72)='/'//' '
38999 WRITE(CHTMP,5400) IDIM-NRPT
39000 CHBLK(1)(30:33)=CHTMP(13:16)
39002 WRITE(LFN,5700) CHBLK(ILIN)
39006 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
39007 & ',I= , )/'//CHCOM(1:LCOM)//','
39008 WRITE(CHTMP,5400) IDIM-NRPT+1
39009 CHLIN(25:28)=CHTMP(13:16)
39014 C...Write final block of lines.
39015 CHLIN(LLIN:72)='/'//' '
39017 WRITE(CHTMP,5400) NDIM
39018 CHBLK(1)(30:33)=CHTMP(13:16)
39020 WRITE(LFN,5700) CHBLK(ILIN)
39025 C...Formats for reading and writing particle data.
39026 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
39027 5100 FORMAT(10X,2I5,F12.6,5I10)
39038 C*********************************************************************
39043 C...Provides various integer-valued event related data.
39047 C...Double precision and integer declarations.
39048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39049 INTEGER PYK,PYCHGE,PYCOMP
39051 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39052 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39053 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39054 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39056 C...Default value. For I=0 number of entries, number of stable entries
39057 C...or 3 times total charge.
39059 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
39060 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
39062 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
39064 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
39065 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
39068 ELSEIF(I.EQ.0) THEN
39070 C...For I > 0 direct readout of K matrix or charge.
39071 ELSEIF(J.LE.5) THEN
39073 ELSEIF(J.EQ.6) THEN
39076 C...Status (existing/fragmented/decayed), parton/hadron separation.
39077 ELSEIF(J.LE.8) THEN
39078 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
39079 IF(J.EQ.8) PYK=PYK*K(I,2)
39080 ELSEIF(J.LE.12) THEN
39084 IF(KC.NE.0) KQ=KCHG(KC,2)
39085 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
39086 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
39088 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
39090 C...Heaviest flavour in hadron/diquark.
39091 ELSEIF(J.EQ.13) THEN
39093 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
39094 IF(KFA.LT.10) PYK=KFA
39095 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
39096 PYK=PYK*ISIGN(1,K(I,2))
39098 C...Particle history: generation, ancestor, rank.
39099 ELSEIF(J.LE.15) THEN
39105 IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
39107 ELSEIF(J.EQ.16) THEN
39109 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
39110 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
39117 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
39118 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
39120 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
39121 IF(ILP.EQ.1) GOTO 120
39123 IF(K(I1,1).EQ.12) THEN
39125 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
39126 & .AND.K(I3,2).NE.93) PYK=PYK+1
39132 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
39136 C...Particle coming from collapsing jet system or not.
39137 ELSEIF(J.EQ.17) THEN
39144 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
39145 IF(PYK.EQ.1) PYK=-1
39149 IF(KCHG(KC,2).EQ.0) GOTO 150
39150 IF(K(I1,1).NE.12) PYK=0
39151 IF(K(I1,1).NE.12) RETURN
39154 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
39156 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
39158 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
39160 C...Number of decay products. Colour flow.
39161 ELSEIF(J.EQ.18) THEN
39162 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
39163 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
39164 ELSEIF(J.LE.22) THEN
39165 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
39166 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
39167 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
39168 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
39169 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
39176 C*********************************************************************
39181 C...Provides various real-valued event related data.
39185 C...Double precision and integer declarations.
39186 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39187 INTEGER PYK,PYCHGE,PYCOMP
39189 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39190 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39191 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39192 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39196 C...Set default value. For I = 0 sum of momenta or charges,
39197 C...or invariant mass of system.
39199 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
39200 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
39202 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
39204 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
39208 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
39212 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
39213 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
39215 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
39217 ELSEIF(I.EQ.0) THEN
39219 C...Direct readout of P matrix.
39220 ELSEIF(J.LE.5) THEN
39223 C...Charge, total momentum, transverse momentum, transverse mass.
39224 ELSEIF(J.LE.12) THEN
39225 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
39226 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
39227 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
39228 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
39229 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
39231 C...Theta and phi angle in radians or degrees.
39232 ELSEIF(J.LE.16) THEN
39233 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
39234 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
39235 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
39237 C...True rapidity, rapidity with pion mass, pseudorapidity.
39238 ELSEIF(J.LE.19) THEN
39240 IF(J.EQ.17) PMR=P(I,5)
39241 IF(J.EQ.18) PMR=PYMASS(211)
39242 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
39243 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
39246 C...Energy and momentum fractions (only to be used in CM frame).
39247 ELSEIF(J.LE.25) THEN
39248 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
39249 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
39250 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
39251 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
39252 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
39253 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
39259 C*********************************************************************
39261 *$ CREATE PYSPHE.FOR
39264 C...Performs sphericity tensor analysis to give sphericity,
39265 C...aplanarity and the related event axes.
39267 SUBROUTINE PYSPHE(SPH,APL)
39269 C...Double precision and integer declarations.
39270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39271 INTEGER PYK,PYCHGE,PYCOMP
39273 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39275 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39276 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39278 DIMENSION SM(3,3),SV(3,3)
39280 C...Calculate matrix to be diagonalized.
39289 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39290 IF(MSTU(41).GE.2) THEN
39292 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39293 & KC.EQ.18) GOTO 140
39294 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39298 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39300 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
39301 & MAX(1D-10,PA)**(PARU(41)-2D0)
39304 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
39310 C...Very low multiplicities (0 or 1) not considered.
39312 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
39319 SM(J1,J2)=SM(J1,J2)/PS
39323 C...Find eigenvalues to matrix (third degree equation).
39324 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
39325 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
39326 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
39327 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
39328 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
39329 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
39330 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
39331 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
39332 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
39333 IF(P(N+2,4).LT.1D-5) THEN
39334 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
39340 C...Find first and last eigenvector by solving equation system.
39343 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
39345 SV(J1,J2)=SM(J1,J2)
39346 SV(J2,J1)=SM(J1,J2)
39352 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
39355 SMAX=ABS(SV(J1,J2))
39359 DO 220 J3=JA+1,JA+2
39361 RL=SV(J1,JB)/SV(JA,JB)
39363 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
39364 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
39366 SMAX=ABS(SV(J1,J2))
39370 JB2=JB+2-3*((JB+1)/3)
39371 P(N+I,JB1)=-SV(JC,JB2)
39372 P(N+I,JB2)=SV(JC,JB1)
39373 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
39375 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
39376 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39378 P(N+I,J)=SGN*P(N+I,J)/PA
39382 C...Middle axis orthogonal to other two. Fill other codes.
39383 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39384 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
39385 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
39386 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
39399 C...Calculate sphericity and aplanarity. Select storing option.
39400 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
39404 IF(MSTU(43).LE.1) MSTU(3)=3
39405 IF(MSTU(43).GE.2) N=N+3
39410 C*********************************************************************
39412 *$ CREATE PYTHRU.FOR
39415 C...Performs thrust analysis to give thrust, oblateness
39416 C...and the related event axes.
39418 SUBROUTINE PYTHRU(THR,OBL)
39420 C...Double precision and integer declarations.
39421 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39422 INTEGER PYK,PYCHGE,PYCOMP
39424 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39425 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39426 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39427 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39429 DIMENSION TDI(3),TPR(3)
39431 C...Take copy of particles that are to be considered in thrust analysis.
39435 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
39436 IF(MSTU(41).GE.2) THEN
39438 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39439 & KC.EQ.18) GOTO 100
39440 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39443 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
39444 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
39454 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39456 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
39457 & P(N+NP,4)**(PARU(42)-1D0)
39458 PS=PS+P(N+NP,4)*P(N+NP,5)
39461 C...Very low multiplicities (0 or 1) not considered.
39463 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
39469 C...Loop over thrust and major. T axis along z direction in latter case.
39473 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
39475 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
39476 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
39477 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
39480 C...Find and order particles with highest p (pT for major).
39481 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
39485 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
39486 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
39487 IF(P(I,4).LE.P(ILF,4)) GOTO 140
39489 P(ILF+1,J)=P(ILF,J)
39498 C...Find and order initial axes with highest thrust (major).
39499 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
39502 NC=2**(MIN(MSTU(44),NP)-1)
39507 DO 200 ILF=1,MIN(MSTU(44),NP)
39508 SGN=P(N+NP+ILF+3,5)
39509 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
39511 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
39514 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
39515 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
39516 IF(TDS.LE.P(ILG,4)) GOTO 230
39518 P(ILG+1,J)=P(ILG,J)
39521 ILG=N+NP+MSTU(44)+4
39528 C...Iterate direction of axis until stable maximum.
39535 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
39536 IF(THP.GT.1D-10) TDI(J)=TPR(J)
39540 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
39542 TPR(J)=TPR(J)+SGN*P(I,J)
39545 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
39546 IF(THP.GE.THPS+PARU(48)) GOTO 270
39548 C...Save good axis. Try new initial axis until a number of tries agree.
39549 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
39550 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
39552 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39554 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
39560 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
39563 C...Find minor axis and value by orthogonality.
39564 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39565 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
39566 P(N+NP+3,2)=SGN*P(N+NP+2,1)
39570 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
39575 C...Fill axis information. Rotate back to original coordinate system.
39583 P(N+ILD,J)=P(N+NP+ILD,J)
39587 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
39589 C...Calculate thrust and oblateness. Select storing option.
39591 OBL=P(N+2,4)-P(N+3,4)
39594 IF(MSTU(43).LE.1) MSTU(3)=3
39595 IF(MSTU(43).GE.2) N=N+3
39600 C*********************************************************************
39602 *$ CREATE PYCLUS.FOR
39605 C...Subdivides the particle content of an event into jets/clusters.
39607 SUBROUTINE PYCLUS(NJET)
39609 C...Double precision and integer declarations.
39610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39611 INTEGER PYK,PYCHGE,PYCOMP
39613 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39614 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39615 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39616 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39617 C...Local arrays and saved variables.
39619 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
39621 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
39622 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
39623 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
39624 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
39625 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39626 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
39627 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39629 C...If first time, reset. If reentering, skip preliminaries.
39630 IF(MSTU(48).LE.0) THEN
39636 PIMASS=PMAS(PYCOMP(211),1)
39639 IF(MSTU(43).GE.2) N=N-NJET
39640 DO 110 I=N+1,N+NJET
39641 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39643 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39646 R2ACC=PARU(45)*PS(5)**2
39652 C...Find which particles are to be considered in cluster search.
39654 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39655 IF(MSTU(41).GE.2) THEN
39657 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39658 & KC.EQ.18) GOTO 140
39659 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39662 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
39663 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
39668 C...Take copy of these particles, with space left for jets later on.
39674 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
39675 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
39676 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
39677 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39679 PS(J)=PS(J)+P(N+NP,J)
39689 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
39691 C...Very low multiplicities not considered.
39692 IF(NP.LT.MSTU(47)) THEN
39693 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
39698 C...Find precluster configuration. If too few jets, make harder cuts.
39700 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39703 R2ACC=PARU(45)*PS(5)**2
39705 RINIT=1.25D0*PARU(43)
39706 IF(NP.LE.MSTU(47)+2) RINIT=0D0
39707 170 RINIT=0.8D0*RINIT
39710 DO 180 I=N+NP+1,N+2*NP
39714 C...Sum up small momentum region. Jet if enough absolute momentum.
39715 IF(MSTU(46).LE.2) THEN
39719 DO 210 I=N+NP+1,N+2*NP
39720 IF(P(I,5).GT.2D0*RINIT) GOTO 210
39724 P(N+1,J)=P(N+1,J)+P(I,J)
39727 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
39728 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
39729 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39730 IF(NREM.EQ.0) GOTO 170
39733 C...Find fastest remaining particle.
39736 DO 230 I=N+NP+1,N+2*NP
39737 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
39742 P(N+NPRE,J)=P(IMAX,J)
39747 C...Sum up precluster around it according to pT separation.
39748 IF(MSTU(46).LE.2) THEN
39749 DO 260 I=N+NP+1,N+2*NP
39750 IF(K(I,4).NE.0) GOTO 260
39752 IF(R2.GT.RINIT**2) GOTO 260
39756 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
39759 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39761 C...Sum up precluster around it according to mass or
39762 C...Durham pT separation.
39766 DO 280 I=N+NP+1,N+2*NP
39767 IF(K(I,4).NE.0) GOTO 280
39768 IF(MSTU(46).LE.4) THEN
39773 IF(R2.GE.R2MIN) GOTO 280
39779 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
39781 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39788 C...Check if more preclusters to be found. Start over if too few.
39789 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39790 IF(NREM.GT.0) GOTO 220
39793 C...Reassign all particles to nearest jet. Sum up new jet momenta.
39796 310 IF(MSTU(46).LE.1) THEN
39797 DO 330 I=N+1,N+NJET
39802 DO 360 I=N+NP+1,N+2*NP
39804 DO 340 IJET=N+1,N+NJET
39805 IF(P(IJET,5).LT.RINIT) GOTO 340
39807 IF(R2.GE.R2MIN) GOTO 340
39813 V(IMIN,J)=V(IMIN,J)+P(I,J)
39817 DO 380 I=N+1,N+NJET
39821 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39826 C...Find two closest jets.
39827 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
39828 DO 400 ITRY1=N+1,N+NJET-1
39829 DO 390 ITRY2=ITRY1+1,N+NJET
39830 IF(MSTU(46).LE.2) THEN
39831 R2=R2T(ITRY1,ITRY2)
39832 ELSEIF(MSTU(46).LE.4) THEN
39833 R2=R2M(ITRY1,ITRY2)
39835 R2=R2D(ITRY1,ITRY2)
39837 IF(R2.GE.R2MIN) GOTO 390
39844 C...If allowed, join two closest jets and start over.
39845 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
39846 IREC=MIN(IMIN1,IMIN2)
39847 IDEL=MAX(IMIN1,IMIN2)
39849 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
39851 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
39852 DO 430 I=IDEL+1,N+NJET
39857 IF(MSTU(46).GE.2) THEN
39858 DO 440 I=N+NP+1,N+2*NP
39860 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
39861 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
39867 C...Divide up broad jet if empty cluster in list of final ones.
39868 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
39869 DO 450 I=N+1,N+NJET
39872 DO 460 I=N+NP+1,N+2*NP
39873 K(N+K(I,4),5)=K(N+K(I,4),5)+1
39876 DO 470 I=N+1,N+NJET
39877 IF(K(I,5).EQ.0) IEMP=I
39883 DO 480 I=N+NP+1,N+2*NP
39884 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
39887 IF(R2.LE.R2MAX) GOTO 480
39894 P(IEMP,J)=P(ISPL,J)
39895 P(IJET,J)=P(IJET,J)-P(ISPL,J)
39897 P(IEMP,5)=P(ISPL,5)
39898 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
39899 IF(NLOOP.LE.2) GOTO 300
39904 C...If generalized thrust has not yet converged, continue iteration.
39905 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
39911 C...Reorder jets according to energy.
39912 DO 510 I=N+1,N+NJET
39917 DO 540 INEW=N+1,N+NJET
39919 DO 520 ITRY=N+1,N+NJET
39920 IF(V(ITRY,4).LE.PEMAX) GOTO 520
39929 P(INEW,J)=V(IMAX,J)
39935 C...Clean up particle-jet assignments and jet information.
39936 DO 550 I=N+NP+1,N+2*NP
39939 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
39940 K(IORI,4)=K(IORI,4)+1
39944 DO 570 I=N+1,N+NJET
39947 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
39951 IF(K(I,4).EQ.0) IEMP=I
39954 C...Select storing option. Output variables. Check for failure.
39960 PARU(63)=SQRT(R2MIN)
39961 IF(NJET.LE.1) PARU(63)=0D0
39963 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
39966 IF(MSTU(43).LE.1) MSTU(3)=NJET
39967 IF(MSTU(43).GE.2) N=N+NJET
39973 C*********************************************************************
39975 *$ CREATE PYCELL.FOR
39978 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
39979 C...as used for calorimeters at hadron colliders.
39981 SUBROUTINE PYCELL(NJET)
39983 C...Double precision and integer declarations.
39984 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39985 INTEGER PYK,PYCHGE,PYCOMP
39987 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39988 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39989 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39990 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39992 C...Loop over all particles. Find cell that was hit by given particle.
39993 PTLRAT=1D0/SINH(PARU(51))**2
39997 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
39998 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
39999 IF(MSTU(41).GE.2) THEN
40001 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40002 & KC.EQ.18) GOTO 110
40003 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40007 PT=SQRT(P(I,1)**2+P(I,2)**2)
40008 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
40009 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
40010 & (ETA/PARU(51)+1D0))))
40011 PHI=PYANGL(P(I,1),P(I,2))
40012 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
40013 & (PHI/PARU(1)+1D0))))
40014 IETPH=MSTU(52)*IETA+IPHI
40016 C...Add to cell already hit, or book new cell.
40018 IF(IETPH.EQ.K(IC,3)) THEN
40024 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
40025 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
40033 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
40034 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
40038 C...Smear true bin content by calorimeter resolution.
40039 IF(MSTU(53).GE.1) THEN
40042 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
40043 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
40044 & COS(PARU(2)*PYR(0))
40045 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
40047 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
40051 C...Remove cells below threshold.
40052 IF(PARU(58).GT.0D0) THEN
40056 IF(P(IC,5).GT.PARU(58)) THEN
40068 C...Find initiator cell: the one with highest pT of not yet used ones.
40072 IF(K(IC,5).NE.2) GOTO 160
40073 IF(P(IC,5).LE.ETMAX) GOTO 160
40079 IF(ETMAX.LT.PARU(52)) GOTO 220
40080 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
40081 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
40095 C...Sum up unused cells within required distance of initiator.
40097 IF(K(IC,5).EQ.0) GOTO 170
40098 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
40099 DPHIA=ABS(P(IC,2)-PHI)
40100 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
40102 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
40103 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
40105 K(NJ,4)=K(NJ,4)+K(IC,4)
40106 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
40107 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
40108 P(NJ,5)=P(NJ,5)+P(IC,5)
40111 C...Reject cluster below minimum ET, else accept.
40112 IF(P(NJ,5).LT.PARU(53)) THEN
40115 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
40117 ELSEIF(MSTU(54).LE.2) THEN
40118 P(NJ,3)=P(NJ,3)/P(NJ,5)
40119 P(NJ,4)=P(NJ,4)/P(NJ,5)
40120 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
40123 IF(K(IC,5).LT.0) K(IC,5)=0
40130 IF(K(IC,5).GE.0) GOTO 210
40131 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
40132 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
40133 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
40134 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
40140 C...Arrange clusters in falling ET sequence.
40141 220 DO 250 I=1,NJ-NC
40144 IF(K(IJ,5).EQ.0) GOTO 230
40145 IF(P(IJ,5).LT.ETMAX) GOTO 230
40153 K(N+I,4)=K(IJMAX,4)
40156 P(N+I,J)=P(IJMAX,J)
40162 C...Convert to massless or massive four-vectors.
40163 IF(MSTU(54).EQ.2) THEN
40164 DO 260 I=N+1,N+NJET
40166 P(I,1)=P(I,5)*COS(P(I,4))
40167 P(I,2)=P(I,5)*SIN(P(I,4))
40168 P(I,3)=P(I,5)*SINH(ETA)
40169 P(I,4)=P(I,5)*COSH(ETA)
40172 ELSEIF(MSTU(54).GE.3) THEN
40173 DO 270 I=N+1,N+NJET
40174 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
40178 C...Information about storage.
40182 IF(MSTU(43).LE.1) MSTU(3)=NJET
40183 IF(MSTU(43).GE.2) N=N+NJET
40188 C*********************************************************************
40190 *$ CREATE PYJMAS.FOR
40193 C...Determines, approximately, the two jet masses that minimize
40194 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
40196 SUBROUTINE PYJMAS(PMH,PML)
40198 C...Double precision and integer declarations.
40199 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40200 INTEGER PYK,PYCHGE,PYCOMP
40202 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40203 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40204 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40205 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40207 DIMENSION SM(3,3),SAX(3),PS(3,5)
40220 PIMASS=PMAS(PYCOMP(211),1)
40222 C...Take copy of particles that are to be considered in mass analysis.
40224 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
40225 IF(MSTU(41).GE.2) THEN
40227 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40228 & KC.EQ.18) GOTO 170
40229 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40232 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
40233 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
40242 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
40243 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
40244 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
40246 C...Fill information in sphericity tensor and total momentum vector.
40249 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
40252 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
40254 PS(3,J)=PS(3,J)+P(N+NP,J)
40258 C...Very low multiplicities (0 or 1) not considered.
40260 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
40265 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
40268 C...Find largest eigenvalue to matrix (third degree equation).
40271 SM(J1,J2)=SM(J1,J2)/PSS
40274 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
40275 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
40276 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
40277 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
40278 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
40279 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
40280 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
40282 C...Find largest eigenvector by solving equation system.
40284 SM(J1,J1)=SM(J1,J1)-SMA
40286 SM(J2,J1)=SM(J1,J2)
40292 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
40295 SMAX=ABS(SM(J1,J2))
40299 DO 250 J3=JA+1,JA+2
40301 RL=SM(J1,JB)/SM(JA,JB)
40303 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
40304 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
40306 SMAX=ABS(SM(J1,J2))
40310 JB2=JB+2-3*((JB+1)/3)
40311 SAX(JB1)=-SM(JC,JB2)
40312 SAX(JB2)=SM(JC,JB1)
40313 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
40315 C...Divide particles into two initial clusters by hemisphere.
40317 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
40319 IF(PSAX.LT.0D0) IS=2
40322 PS(IS,J)=PS(IS,J)+P(I,J)
40325 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
40326 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
40328 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
40332 PS(3,J)=PS(1,J)-PS(2,J)
40335 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)
40336 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
40337 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
40338 IF(PMDI.LT.PMD) THEN
40344 C...Loop back if significant reduction in sum of m^2.
40345 IF(PMD.LT.-PARU(48)*PMS) THEN
40349 PS(IS,J)=PS(IS,J)-P(IM,J)
40350 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
40356 C...Final masses and output.
40359 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
40360 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
40361 PMH=MAX(PS(1,5),PS(2,5))
40362 PML=MIN(PS(1,5),PS(2,5))
40367 C*********************************************************************
40369 *$ CREATE PYFOWO.FOR
40372 C...Calculates the first few Fox-Wolfram moments.
40374 SUBROUTINE PYFOWO(H10,H20,H30,H40)
40376 C...Double precision and integer declarations.
40377 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40378 INTEGER PYK,PYCHGE,PYCOMP
40380 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40381 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40382 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40383 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40385 C...Copy momenta for particles and calculate H0.
40390 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
40391 IF(MSTU(41).GE.2) THEN
40393 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40394 & KC.EQ.18) GOTO 110
40395 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40398 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
40399 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
40410 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
40416 C...Very low multiplicities (0 or 1) not considered.
40418 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
40426 C...Calculate H1 - H4.
40432 DO 120 I2=I1+1,N+NP
40433 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40434 & (P(I1,4)*P(I2,4))
40435 H10=H10+P(I1,4)*P(I2,4)*CTHE
40436 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
40437 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
40438 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
40443 C...Calculate H1/H0 - H4/H0. Output.
40446 H10=(HD+2D0*H10)/H0
40447 H20=(HD+2D0*H20)/H0
40448 H30=(HD+2D0*H30)/H0
40449 H40=(HD+2D0*H40)/H0
40454 C*********************************************************************
40456 *$ CREATE PYTABU.FOR
40459 C...Evaluates various properties of an event, with statistics
40460 C...accumulated during the course of the run and
40461 C...printed at the end.
40463 SUBROUTINE PYTABU(MTABU)
40465 C...Double precision and integer declarations.
40466 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40467 INTEGER PYK,PYCHGE,PYCOMP
40469 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40470 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40471 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40472 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
40473 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
40474 C...Local arrays, character variables, saved variables and data.
40475 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
40476 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
40477 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
40478 &KFDM(8),KFDC(200,0:8),NPDC(200)
40479 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
40480 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
40481 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
40482 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
40483 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
40484 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
40485 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
40486 &NEVDC/0/,NKFDC/0/,NREDC/0/
40488 C...Reset statistics on initial parton state.
40489 IF(MTABU.EQ.10) THEN
40493 C...Identify and order flavour content of initial state.
40494 ELSEIF(MTABU.EQ.11) THEN
40496 KFM1=2*IABS(MSTU(161))
40497 IF(MSTU(161).GT.0) KFM1=KFM1-1
40498 KFM2=2*IABS(MSTU(162))
40499 IF(MSTU(162).GT.0) KFM2=KFM2-1
40500 KFMN=MIN(KFM1,KFM2)
40501 KFMX=MAX(KFM1,KFM2)
40503 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
40506 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
40507 & KFMX.LT.KFIS(I,2))) THEN
40513 110 IF(IKFIS.LT.0) THEN
40516 IF(NKFIS.GE.100) RETURN
40517 DO 130 I=NKFIS,IKFIS,-1
40518 KFIS(I+1,1)=KFIS(I,1)
40519 KFIS(I+1,2)=KFIS(I,2)
40521 NPIS(I+1,J)=NPIS(I,J)
40531 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
40533 C...Count number of partons in initial state.
40536 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
40537 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
40538 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
40543 IF(IM.LE.0.OR.IM.GT.N) THEN
40545 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40547 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
40548 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
40558 IF(NP.GE.11) NPCO=8
40559 IF(NP.GE.16) NPCO=9
40560 IF(NP.GE.26) NPCO=10
40561 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
40564 C...Write statistics on initial parton state.
40565 ELSEIF(MTABU.EQ.12) THEN
40566 FAC=1D0/MAX(1,NEVIS)
40567 WRITE(MSTU(11),5000) NEVIS
40570 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40572 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40573 CALL PYNAME(KFM1,CHAU)
40575 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
40577 IF(KFIS(I,1).EQ.0) KFMX=0
40579 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40580 CALL PYNAME(KFM2,CHAU)
40582 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
40583 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
40584 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
40587 C...Copy statistics on initial parton state into /PYJETS/.
40588 ELSEIF(MTABU.EQ.13) THEN
40589 FAC=1D0/MAX(1,NEVIS)
40592 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40594 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40596 IF(KFIS(I,1).EQ.0) KFMX=0
40598 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40605 P(I,J)=FAC*NPIS(I,J)
40606 V(I,J)=FAC*NPIS(I,J+5)
40620 C...Reset statistics on number of particles/partons.
40621 ELSEIF(MTABU.EQ.20) THEN
40628 C...Identify whether particle/parton is primary or not.
40629 ELSEIF(MTABU.EQ.21) THEN
40633 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
40634 MSTU(62)=MSTU(62)+1
40637 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
40639 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
40641 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
40643 ELSEIF(KC.EQ.0) THEN
40644 ELSEIF(K(K(I,3),1).EQ.13) THEN
40646 IF(IM.LE.0.OR.IM.GT.N) THEN
40648 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40651 ELSEIF(KCHG(KC,2).EQ.0) THEN
40652 KCM=PYCOMP(K(K(I,3),2))
40654 IF(KCHG(KCM,2).NE.0) MPRI=1
40657 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
40658 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
40660 IF(K(I,1).LE.10) THEN
40662 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
40665 C...Fill statistics on number of particles/partons in event.
40667 KFS=3-ISIGN(1,K(I,2))-MPRI
40669 IF(KFA.EQ.KFFS(IP)) THEN
40672 ELSEIF(KFA.LT.KFFS(IP)) THEN
40678 220 IF(IKFFS.LT.0) THEN
40681 IF(NKFFS.GE.400) RETURN
40682 DO 240 IP=NKFFS,IKFFS,-1
40683 KFFS(IP+1)=KFFS(IP)
40685 NPFS(IP+1,J)=NPFS(IP,J)
40694 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
40697 C...Write statistics on particle/parton composition of events.
40698 ELSEIF(MTABU.EQ.22) THEN
40699 FAC=1D0/MAX(1,NEVFS)
40700 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
40702 CALL PYNAME(KFFS(I),CHAU)
40705 IF(KC.NE.0) MDCYF=MDCY(KC,1)
40706 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
40707 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
40710 C...Copy particle/parton composition information into /PYJETS/.
40711 ELSEIF(MTABU.EQ.23) THEN
40712 FAC=1D0/MAX(1,NEVFS)
40718 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
40720 P(I,J)=FAC*NPFS(I,J)
40740 C...Reset factorial moments statistics.
40741 ELSEIF(MTABU.EQ.30) THEN
40747 FM1FM(IM,IB,IP)=0D0
40748 FM2FM(IM,IB,IP)=0D0
40753 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
40754 ELSEIF(MTABU.EQ.31) THEN
40759 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
40760 IF(MSTU(41).GE.2) THEN
40762 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40763 & KC.EQ.18) GOTO 410
40764 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40765 & PYCHGE(K(I,2)).EQ.0) GOTO 410
40768 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40769 IF(MSTU(42).GE.2) PMR=P(I,5)
40770 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
40771 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
40773 IF(ABS(YETA).GT.PARU(57)) GOTO 410
40774 PHI=PYANGL(P(I,1),P(I,2))
40775 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
40776 IYETA=MAX(0,MIN(511,IYETA))
40777 IPHI=512D0*(PHI+PARU(1))/PARU(2)
40778 IPHI=MAX(0,MIN(511,IPHI))
40781 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
40784 C...Order particles in (pseudo)rapidity and/or azimuth.
40785 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40786 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40790 IF(NUPP.EQ.NLOW+1) THEN
40795 DO 350 I1=NUPP-1,NLOW+1,-1
40796 IF(IYETA.GE.K(I1,1)) GOTO 360
40799 360 K(I1+1,1)=IYETA
40800 DO 370 I1=NUPP-1,NLOW+1,-1
40801 IF(IPHI.GE.K(I1,2)) GOTO 380
40805 DO 390 I1=NUPP-1,NLOW+1,-1
40806 IF(IYEP.GE.K(I1,3)) GOTO 400
40816 C...Calculate sum of factorial moments in event.
40824 IF(IM.LE.2) IBIN=2**(10-IB)
40825 IF(IM.EQ.3) IBIN=4**(10-IB)
40826 IAGR=K(NLOW+1,IM)/IBIN
40828 DO 440 I=NLOW+2,NUPP+1
40830 IF(ICUT.EQ.IAGR) THEN
40834 ELSEIF(NAGR.EQ.2) THEN
40835 FEVFM(IB,1)=FEVFM(IB,1)+2D0
40836 ELSEIF(NAGR.EQ.3) THEN
40837 FEVFM(IB,1)=FEVFM(IB,1)+6D0
40838 FEVFM(IB,2)=FEVFM(IB,2)+6D0
40839 ELSEIF(NAGR.EQ.4) THEN
40840 FEVFM(IB,1)=FEVFM(IB,1)+12D0
40841 FEVFM(IB,2)=FEVFM(IB,2)+24D0
40842 FEVFM(IB,3)=FEVFM(IB,3)+24D0
40844 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
40845 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
40846 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40848 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40849 & (NAGR-3D0)*(NAGR-4D0)
40857 C...Add results to total statistics.
40860 IF(FEVFM(1,IP).LT.0.5D0) THEN
40862 ELSEIF(IM.LE.2) THEN
40863 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40865 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40867 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
40868 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
40872 NMUFM=NMUFM+(NUPP-NLOW)
40875 C...Write accumulated statistics on factorial moments.
40876 ELSEIF(MTABU.EQ.32) THEN
40877 FAC=1D0/MAX(1,NEVFM)
40878 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
40879 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
40880 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
40882 WRITE(MSTU(11),5500)
40885 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
40887 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
40888 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
40889 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
40891 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
40892 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40895 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
40900 C...Copy statistics on factorial moments into /PYJETS/.
40901 ELSEIF(MTABU.EQ.33) THEN
40902 FAC=1D0/MAX(1,NEVFM)
40909 IF(IM.NE.2) K(I,3)=2**(IB-1)
40911 IF(IM.NE.1) K(I,4)=2**(IB-1)
40913 P(I,1)=2D0*PARU(57)/K(I,3)
40914 V(I,1)=PARU(2)/K(I,4)
40916 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
40917 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40933 C...Reset statistics on Energy-Energy Correlation.
40934 ELSEIF(MTABU.EQ.40) THEN
40945 C...Find particles to include, with proper assumed mass.
40946 ELSEIF(MTABU.EQ.41) THEN
40952 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
40953 IF(MSTU(41).GE.2) THEN
40955 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40956 & KC.EQ.18) GOTO 570
40957 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40958 & PYCHGE(K(I,2)).EQ.0) GOTO 570
40961 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40962 IF(MSTU(42).GE.2) PMR=P(I,5)
40963 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40964 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40971 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
40972 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
40975 IF(NUPP.EQ.NLOW) RETURN
40977 C...Analyze Energy-Energy Correlation in event.
40978 FAC=(2D0/ECM**2)*50D0/PARU(1)
40982 DO 600 I1=NLOW+2,NUPP
40983 DO 590 I2=NLOW+1,I1-1
40984 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40985 & (P(I1,5)*P(I2,5))
40986 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
40987 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
40988 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
40992 FE1EC(J)=FE1EC(J)+FEVEE(J)
40993 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
40994 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
40995 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
40996 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
40997 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
41001 C...Write statistics on Energy-Energy Correlation.
41002 ELSEIF(MTABU.EQ.42) THEN
41003 FAC=1D0/MAX(1,NEVEE)
41004 WRITE(MSTU(11),5700) NEVEE
41007 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
41008 FEEC2=FAC*FE1EC(51-J)
41009 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
41011 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
41012 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
41013 & FEEC2,FEES2,FEECA,FEESA
41016 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
41017 ELSEIF(MTABU.EQ.43) THEN
41018 FAC=1D0/MAX(1,NEVEE)
41025 P(I,1)=FAC*FE1EC(I)
41026 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
41027 P(I,2)=FAC*FE1EC(51-I)
41028 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
41029 P(I,3)=FAC*FE1EA(I)
41030 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
41031 P(I,4)=PARU(1)*(I-1)/50D0
41032 P(I,5)=PARU(1)*I/50D0
41047 C...Reset statistics on decay channels.
41048 ELSEIF(MTABU.EQ.50) THEN
41053 C...Identify and order flavour content of final state.
41054 ELSEIF(MTABU.EQ.51) THEN
41058 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
41065 IF(K(I,2).LT.0) KFM=KFM-1
41066 DO 650 IDS=NDS-1,1,-1
41068 IF(KFM.LT.KFDM(IDS)) GOTO 660
41069 KFDM(IDS+1)=KFDM(IDS)
41075 C...Find whether old or new final state.
41077 IF(NDS.LT.KFDC(IDC,0)) THEN
41080 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
41082 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
41085 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
41094 700 IF(IKFDC.LT.0) THEN
41096 ELSEIF(NKFDC.GE.200) THEN
41100 DO 720 IDC=NKFDC,IKFDC,-1
41101 NPDC(IDC+1)=NPDC(IDC)
41103 KFDC(IDC+1,I)=KFDC(IDC,I)
41109 KFDC(IKFDC,I)=KFDM(I)
41113 NPDC(IKFDC)=NPDC(IKFDC)+1
41115 C...Write statistics on decay channels.
41116 ELSEIF(MTABU.EQ.52) THEN
41117 FAC=1D0/MAX(1,NEVDC)
41118 WRITE(MSTU(11),5900) NEVDC
41120 DO 740 I=1,KFDC(IDC,0)
41123 IF(2*KF.NE.KFM) KF=-KF
41124 CALL PYNAME(KF,CHAU)
41126 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
41128 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
41130 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
41132 C...Copy statistics on decay channels into /PYJETS/.
41133 ELSEIF(MTABU.EQ.53) THEN
41134 FAC=1D0/MAX(1,NEVDC)
41140 K(IDC,5)=KFDC(IDC,0)
41145 DO 770 I=1,KFDC(IDC,0)
41148 IF(2*KF.NE.KFM) KF=-KF
41149 IF(I.LE.5) P(IDC,I)=KF
41150 IF(I.GE.6) V(IDC,I-5)=KF
41152 V(IDC,5)=FAC*NPDC(IDC)
41167 C...Format statements for output on unit MSTU(11) (default 6).
41168 5000 FORMAT(///20X,'Event statistics - initial state'/
41169 &20X,'based on an analysis of ',I6,' events'//
41170 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
41171 &'according to fragmenting system multiplicity'/
41172 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
41173 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
41174 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
41175 5200 FORMAT(///20X,'Event statistics - final state'/
41176 &20X,'based on an analysis of ',I7,' events'//
41177 &5X,'Mean primary multiplicity =',F10.4/
41178 &5X,'Mean final multiplicity =',F10.4/
41179 &5X,'Mean charged multiplicity =',F10.4//
41180 &5X,'Number of particles produced per event (directly and via ',
41181 &'decays/branchings)'/
41182 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
41183 &8X,'Total'/35X,'prim seco prim seco'/)
41184 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
41185 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
41186 &20X,'based on an analysis of ',I6,' events'//
41187 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
41188 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
41190 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
41191 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
41192 &20X,'based on an analysis of ',I6,' events'//
41193 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
41194 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
41195 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
41196 5900 FORMAT(///20X,'Decay channel analysis - final state'/
41197 &20X,'based on an analysis of ',I6,' events'//
41198 &2X,'Probability',10X,'Complete final state'/)
41199 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
41200 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
41201 &'or table overflow)')
41206 C*********************************************************************
41208 *$ CREATE PYEEVT.FOR
41211 C...Handles the generation of an e+e- annihilation jet event.
41213 SUBROUTINE PYEEVT(KFL,ECM)
41214 C...Double precision and integer declarations.
41215 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41216 INTEGER PYK,PYCHGE,PYCOMP
41218 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41219 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41220 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41221 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41223 C...Check input parameters.
41224 IF(MSTU(12).GE.1) CALL PYLIST(0)
41225 IF(KFL.LT.0.OR.KFL.GT.8) THEN
41226 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
41227 IF(MSTU(21).GE.1) RETURN
41229 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
41230 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
41231 IF(ECM.LT.ECMMIN) THEN
41232 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
41233 IF(MSTU(21).GE.1) RETURN
41236 C...Check consistency of MSTJ options set.
41237 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
41239 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
41242 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
41244 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
41248 C...Initialize alpha_strong and total cross-section.
41249 MSTU(111)=MSTJ(108)
41250 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
41252 PARU(112)=PARJ(121)
41253 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
41254 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
41255 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
41257 IF(MSTJ(116).GE.3) MSTJ(116)=1
41260 C...Add initial e+e- to event record (documentation only).
41263 IF(NTRY.GT.100) THEN
41264 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
41269 IF(MSTJ(115).GE.2) THEN
41271 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
41273 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
41277 C...Radiative photon (in initial state).
41280 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
41282 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
41283 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
41285 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
41286 K(NC,3)=MIN(MSTJ(115)/2,1)
41289 C...Virtual exchange boson (gamma or Z0).
41290 IF(MSTJ(115).GE.3) THEN
41293 IF(MSTJ(102).EQ.2) KF=23
41297 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
41303 C...Choice of flavour and jet configuration.
41304 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
41305 IF(KFLC.EQ.0) GOTO 100
41306 CALL PYXJET(ECMC,NJET,CUT)
41308 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
41310 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
41311 IF(NJET.EQ.2) MSTJ(120)=1
41313 C...Fill jet configuration and origin.
41314 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
41315 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
41317 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
41318 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
41319 &-KFLC,ECMC,X1,X2,X4,X12,X14)
41320 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
41321 &-KFLC,ECMC,X1,X2,X4,X12,X14)
41322 IF(MSTU(24).NE.0) GOTO 100
41324 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
41327 C...Angular orientation according to matrix element.
41328 IF(MSTJ(106).EQ.1) THEN
41329 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
41330 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
41331 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
41334 C...Rotation and boost from radiative photon.
41336 DBEK=-PAK/(ECM-PAK)
41337 NMIN=NC+1-MSTJ(115)/3
41338 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
41339 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
41340 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
41343 C...Generate parton shower. Rearrange along strings and check.
41344 IF(MSTJ(101).EQ.5) THEN
41345 CALL PYSHOW(N-1,N,ECMC)
41347 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
41348 IF(MSTJ(105).GE.0) MSTU(28)=0
41351 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
41354 C...Fragmentation/decay generation. Information for PYTABU.
41355 IF(MSTJ(105).EQ.1) CALL PYEXEC
41362 C*********************************************************************
41364 *$ CREATE PYXTEE.FOR
41367 C...Calculates total cross-section, including initial state
41368 C...radiation effects.
41370 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
41372 C...Double precision and integer declarations.
41373 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41374 INTEGER PYK,PYCHGE,PYCOMP
41376 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41377 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41378 SAVE /PYDAT1/,/PYDAT2/
41380 C...Status, (optimized) Q^2 scale, alpha_strong.
41382 MSTJ(119)=10*MSTJ(102)+KFL
41383 IF(MSTJ(111).EQ.0) THEN
41385 ELSEIF(MSTU(111).EQ.0) THEN
41386 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41387 & ((33D0-2D0*MSTU(112))*PARU(111)))))
41388 Q2R=PARJ(168)*ECM**2
41390 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41391 & (2D0*PARU(112)/ECM)**2))
41392 Q2R=PARJ(168)*ECM**2
41394 ALSPI=PYALPS(Q2R)/PARU(1)
41396 C...QCD corrections factor in R.
41397 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
41399 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
41401 ELSEIF(MSTJ(109).EQ.0) THEN
41402 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41403 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
41404 & LOG(PARJ(168))*ALSPI**2)
41405 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
41406 RQCD=1D0+(3D0/4D0)*ALSPI
41408 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
41411 C...Calculate Z0 width if default value not acceptable.
41412 IF(MSTJ(102).GE.3) THEN
41413 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
41414 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
41417 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
41418 & (2D0*PYMASS(KFLC)/ ECM)**2))
41419 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
41420 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
41421 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
41423 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
41427 C...Calculate propagator and related constants for QFD case.
41428 POLL=1D0-PARJ(131)*PARJ(132)
41429 IF(MSTJ(102).GE.2) THEN
41430 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41431 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41432 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
41433 VE=4D0*PARU(102)-1D0
41434 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
41435 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41440 C...Loop over different flavours: charge, velocity.
41445 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
41446 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
41449 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
41450 QF=KCHG(KFLC,1)/3D0
41452 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
41454 C...Calculate R and sum of charges for QED or QFD case.
41455 RQQ=RQQ+3D0*QF**2*POLL
41456 IF(MSTJ(102).LE.1) THEN
41457 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
41459 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41460 RQV=RQV-6D0*QF*VF*SF1I
41461 RVA=RVA+3D0*(VF**2+1D0)*SF1W
41462 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
41463 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
41467 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
41469 C...Calculate cross-section, including QCD corrections.
41472 PARJ(143)=RTOT*RQCD
41473 PARJ(144)=PARJ(143)
41474 PARJ(145)=PARJ(141)*86.8D0/ECM**2
41475 PARJ(146)=PARJ(142)*86.8D0/ECM**2
41476 PARJ(147)=PARJ(143)*86.8D0/ECM**2
41477 PARJ(148)=PARJ(147)
41478 PARJ(157)=RSUM*RQCD
41482 IF(MSTJ(107).LE.0) RETURN
41484 C...Virtual cross-section.
41486 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41487 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
41488 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
41489 &1.526D0*LOG(ECM**2/0.932D0)
41491 C...Soft and hard radiative cross-section in QED case.
41492 IF(MSTJ(102).LE.1) THEN
41493 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
41494 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
41495 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
41497 C...Soft and hard radiative cross-section in QFD case.
41499 SZM=1D0-(PARJ(123)/ECM)**2
41500 SZW=PARJ(123)*PARJ(124)/ECM**2
41501 PARJ(161)=-RQQ/RSUM
41502 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
41503 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
41504 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
41505 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
41506 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
41507 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
41508 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
41509 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
41510 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
41511 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
41512 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
41513 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
41514 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
41517 C...Total cross-section and fraction of hard photon events.
41518 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
41519 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
41520 PARJ(144)=PARJ(157)
41521 PARJ(148)=PARJ(144)*86.8D0/ECM**2
41527 C*********************************************************************
41529 *$ CREATE PYRADK.FOR
41532 C...Generates initial state photon radiation.
41534 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
41536 C...Double precision and integer declarations.
41537 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41538 INTEGER PYK,PYCHGE,PYCOMP
41540 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41543 C...Function: cumulative hard photon spectrum in QFD case.
41544 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
41545 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
41547 C...Determine whether radiative photon or not.
41550 IF(PARJ(160).LT.PYR(0)) RETURN
41553 C...Photon energy range. Find photon momentum in QED case.
41555 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41556 IF(MSTJ(102).LE.1) THEN
41557 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
41558 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
41560 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
41562 SZM=1D0-(PARJ(123)/ECM)**2
41563 SZW=PARJ(123)*PARJ(124)/ECM**2
41566 FXKD=1D-4*(FXKU-FXKL)
41567 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
41572 IF(FXKV.GT.FXKR) THEN
41579 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
41580 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
41584 C...Photon polar and azimuthal angle.
41585 PME=2D0*(PYMASS(11)/ECM)**2
41586 120 CTHM=PME*(2D0/PME)**PYR(0)
41587 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
41588 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
41590 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
41591 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
41592 THEK=PYANGL(CTHE,STHE)
41593 PHIK=PARU(2)*PYR(0)
41595 C...Rotation angle for hadronic system.
41597 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
41599 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
41600 &(2D0-XK*(1D0-SGN*CTHE)))
41605 C*********************************************************************
41607 *$ CREATE PYXKFL.FOR
41610 C...Selects flavour for produced qqbar pair.
41612 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
41614 C...Double precision and integer declarations.
41615 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41616 INTEGER PYK,PYCHGE,PYCOMP
41618 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41619 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41620 SAVE /PYDAT1/,/PYDAT2/
41622 C...Calculate maximum weight in QED or QFD case.
41623 IF(MSTJ(102).LE.1) THEN
41626 POLL=1D0-PARJ(131)*PARJ(132)
41627 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41628 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41629 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
41630 VE=4D0*PARU(102)-1D0
41631 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
41632 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41633 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
41634 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
41635 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
41639 C...Choose flavour. Gives charge and velocity.
41642 IF(NTRY.GT.100) THEN
41643 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
41648 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
41651 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
41652 QF=KCHG(KFLC,1)/3D0
41654 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
41656 C...Calculate weight in QED or QFD case.
41657 IF(MSTJ(102).LE.1) THEN
41659 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
41661 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41662 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
41663 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
41665 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
41668 C...Weighting or new event (radiative photon). Cross-section update.
41669 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
41670 PARJ(158)=PARJ(158)+1D0
41671 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
41672 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
41673 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
41674 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
41675 PARJ(148)=PARJ(144)*86.8D0/ECM**2
41680 C*********************************************************************
41682 *$ CREATE PYXJET.FOR
41685 C...Selects number of jets in matrix element approach.
41687 SUBROUTINE PYXJET(ECM,NJET,CUT)
41689 C...Double precision and integer declarations.
41690 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41691 INTEGER PYK,PYCHGE,PYCOMP
41693 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41695 C...Local array and data.
41697 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
41699 C...Trivial result for two-jets only, including parton shower.
41700 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41703 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
41704 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
41706 IF(MSTJ(109).EQ.2) CF=1D0
41707 IF(MSTJ(111).EQ.0) THEN
41710 ELSEIF(MSTU(111).EQ.0) THEN
41711 PARJ(169)=MIN(1D0,PARJ(129))
41712 Q2=PARJ(169)*ECM**2
41713 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41714 & ((33D0-2D0*MSTU(112))*PARU(111)))))
41715 Q2R=PARJ(168)*ECM**2
41717 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
41718 Q2=PARJ(169)*ECM**2
41719 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41720 & (2D0*PARU(112)/ECM)**2))
41721 Q2R=PARJ(168)*ECM**2
41724 C...alpha_strong for R and R itself.
41725 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
41726 IF(IABS(MSTJ(101)).EQ.1) THEN
41728 ELSEIF(MSTJ(109).EQ.0) THEN
41729 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41730 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
41731 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
41733 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
41736 C...alpha_strong for jet rate. Initial value for y cut.
41737 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41738 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
41739 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
41740 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
41741 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41743 C...Parametrization of first order three-jet cross-section.
41744 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
41747 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
41748 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
41749 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
41750 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
41751 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
41755 C...Parametrization of second order three-jet cross-section.
41756 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
41757 & CUT.GE.0.25D0) THEN
41759 ELSEIF(MSTJ(110).LE.1) THEN
41760 CT=LOG(1D0/CUT-2D0)
41761 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
41762 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
41764 C...Interpolation in second/first order ratio for Zhu parametrization.
41765 ELSEIF(MSTJ(110).EQ.2) THEN
41768 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41774 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
41776 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
41779 C...Shift in second order three-jet cross-section with optimized Q^2.
41780 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
41781 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
41782 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
41784 C...Parametrization of second order four-jet cross-section.
41785 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
41788 CT=LOG(1D0/CUT-5D0)
41789 IF(CUT.LE.0.018D0) THEN
41790 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
41791 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
41793 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
41794 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41796 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
41797 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
41798 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
41799 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
41800 & 0.002093D0*CT**3)
41801 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41803 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
41804 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
41807 C...If negative three-jet rate, change y' optimization parameter.
41808 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
41809 & PARJ(169).LT.0.99D0) THEN
41810 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41811 Q2=PARJ(169)*ECM**2
41812 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41816 C...If too high cross-section, use harder cuts, or fail.
41817 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
41818 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
41819 & PARJ(169).LT.0.99D0) THEN
41820 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41821 Q2=PARJ(169)*ECM**2
41822 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41824 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
41826 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
41828 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
41829 & PARJ(154))**(-1D0/3D0)
41830 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41834 C...Scalar gluon (first order only).
41836 ALSPI=PYALPS(ECM**2)/PARU(1)
41837 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
41839 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
41840 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
41845 C...Select number of jets.
41847 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41849 ELSEIF(MSTJ(101).LE.0) THEN
41850 NJET=MIN(4,2-MSTJ(101))
41854 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
41855 IF(PARJ(154).GT.RNJ) NJET=4
41861 C*********************************************************************
41863 *$ CREATE PYX3JT.FOR
41866 C...Selects the kinematical variables of three-jet events.
41868 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
41870 C...Double precision and integer declarations.
41871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41872 INTEGER PYK,PYCHGE,PYCOMP
41874 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41877 DIMENSION ZHUP(5,12)
41879 C...Coefficients of Zhu second order parametrization.
41880 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
41881 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
41882 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
41883 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
41884 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
41885 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
41886 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
41887 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
41888 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
41889 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
41890 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
41892 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
41893 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
41896 C...Event type. Mass effect factors and other common constants.
41900 QME=(2D0*PMQ/ECM)**2
41901 IF(MSTJ(109).NE.1) THEN
41903 CUTD=LOG(1D0/CUT-2D0)
41904 IF(MSTJ(109).EQ.0) THEN
41908 WTMX=MIN(20D0,37D0-6D0*CUTD)
41909 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
41917 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
41918 ALS2PI=PARU(118)/PARU(2)
41920 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
41921 & LOG(PARJ(169))*ALS2PI
41922 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
41924 C...Choose three-jet events in allowed region.
41926 110 Y13L=CUTL+CUTD*PYR(0)
41927 Y23L=CUTL+CUTD*PYR(0)
41931 IF(Y12.LE.CUT) GOTO 110
41932 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
41934 C...Second order corrections.
41935 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
41940 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
41941 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
41942 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
41943 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
41944 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
41945 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
41946 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
41947 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
41948 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
41949 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
41950 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
41951 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
41952 & TR*(2D0*CUTL/3D0-10D0/9D0)+
41953 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
41954 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
41955 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
41956 & Y13*Y23)/(Y12+Y13)**2)/WT1+
41957 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
41958 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
41959 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
41960 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
41961 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
41962 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
41963 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
41964 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41965 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41966 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
41968 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
41969 C...Second order corrections; Zhu parametrization of ERT.
41974 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41978 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41979 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41980 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41981 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41984 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41985 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41986 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41987 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41989 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41990 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41991 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41992 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41993 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
41995 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41996 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41997 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
42000 C...Impose mass cuts (gives two jets). For fixed jet number new try.
42004 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
42005 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
42006 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
42007 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
42008 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
42010 C...Scalar gluon model (first order only, no mass effects).
42013 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
42014 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
42015 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
42016 X1=1D0-0.5D0*(X3+YD)
42017 X2=1D0-0.5D0*(X3-YD)
42018 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
42019 IF(MSTJ(102).GE.2) THEN
42020 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
42021 & X3**2*PYR(0)) NJET=2
42023 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
42029 C*********************************************************************
42031 *$ CREATE PYX4JT.FOR
42034 C...Selects the kinematical variables of four-jet events.
42036 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
42038 C...Double precision and integer declarations.
42039 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42040 INTEGER PYK,PYCHGE,PYCOMP
42042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42045 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
42047 C...Common constants. Colour factors for QCD and Abelian gluon theory.
42049 QME=(2D0*PMQ/ECM)**2
42050 CT=LOG(1D0/CUT-5D0)
42051 IF(MSTJ(109).EQ.0) THEN
42061 C...Choice of process (qqbargg or qqbarqqbar).
42064 IF(PARJ(155).GT.PYR(0)) IT=2
42065 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
42066 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
42067 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
42068 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
42071 C...Sample the five kinematical variables (for qqgg preweighted in y34).
42072 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
42073 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
42074 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
42075 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
42076 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
42078 CP=COS(PARU(1)*PYR(0))
42081 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
42082 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
42083 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
42085 Y12=1D0-Y134-Y23-Y24
42086 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
42090 C...Calculate matrix elements for qqgg or qqqq process.
42095 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
42096 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
42097 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
42098 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
42099 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
42100 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
42101 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
42102 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
42103 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
42104 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
42105 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
42106 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
42107 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
42108 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
42109 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
42110 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
42111 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
42112 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
42113 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
42114 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
42115 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
42116 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
42117 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
42118 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
42119 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
42120 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
42121 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
42122 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
42123 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
42124 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
42125 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
42126 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
42127 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
42128 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
42129 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
42130 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
42131 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
42132 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
42133 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
42134 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
42135 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
42138 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
42139 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
42140 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
42141 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
42142 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
42143 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
42144 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
42145 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
42146 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
42147 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
42148 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
42149 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
42150 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
42151 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
42152 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
42153 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
42154 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
42155 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
42158 C...Permutations of momenta in matrix element. Weighting.
42159 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
42170 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
42181 IF(IC.LE.3) GOTO 120
42182 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
42185 C...qqgg events: string configuration and event type.
42187 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
42188 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
42189 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
42190 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
42191 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
42192 IF(ID.EQ.2) GOTO 130
42193 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
42194 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
42195 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
42196 IF(ID.EQ.2) GOTO 130
42199 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
42200 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
42203 C...Mass cuts. Kinematical variables out.
42204 IF(Y12.LE.CUT+QME) NJET=2
42205 IF(NJET.EQ.2) GOTO 150
42206 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
42207 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
42208 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
42210 X12=(1D0-Q12)*Y13+Q12*Y23
42212 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
42214 C...qqbarqqbar events: string configuration, choose new flavour.
42217 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
42218 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
42219 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
42220 IF(WTR.LT.WTD(4)) ID=4
42221 IF(ID.GE.2) GOTO 130
42224 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
42225 140 KFLN=1+INT(5D0*PYR(0))
42226 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
42227 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
42228 IF(KFLN.GT.MSTJ(104)) NJET=2
42230 QMEN=(2D0*PMQN/ECM)**2
42232 C...Mass cuts. Kinematical variables out.
42233 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
42234 IF(NJET.EQ.2) GOTO 150
42235 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
42236 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
42237 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
42238 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
42239 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
42240 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
42243 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
42245 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
42246 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
42247 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
42249 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
42254 C*********************************************************************
42256 *$ CREATE PYXDIF.FOR
42259 C...Gives the angular orientation of events.
42261 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
42263 C...Double precision and integer declarations.
42264 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42265 INTEGER PYK,PYCHGE,PYCOMP
42267 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42268 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42269 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42270 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42272 C...Charge. Factors depending on polarization for QED case.
42274 POLL=1D0-PARJ(131)*PARJ(132)
42275 POLD=PARJ(132)-PARJ(131)
42276 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
42282 C...Factors depending on flavour, energy and polarization for QFD case.
42284 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
42285 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
42286 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
42288 VE=4D0*PARU(102)-1D0
42290 VF=AF-4D0*QF*PARU(102)
42291 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
42292 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
42293 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
42294 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
42295 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
42296 & SFW*SFF**2*(VE**2-AE**2))
42297 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
42301 C...Mass factor. Differential cross-sections for two-jet events.
42304 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
42305 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
42307 SIGU=4D0*SQRT(1D0-QME)
42308 SIGL=2D0*QME*SQRT(1D0-QME)
42314 C...Kinematical variables. Reduce four-jet event to three-jet one.
42317 X1=2D0*P(NC+1,4)/ECM
42318 X2=2D0*P(NC+3,4)/ECM
42320 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
42321 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
42322 X1=2D0*P(NC+1,4)/ECMR
42323 X2=2D0*P(NC+4,4)/ECMR
42326 C...Differential cross-sections for three-jet (or reduced four-jet).
42327 XQ=(1D0-X1)/(1D0-X2)
42328 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
42329 ST12=SQRT(1D0-CT12**2)
42330 IF(MSTJ(109).NE.1) THEN
42331 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
42332 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
42333 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
42334 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
42336 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
42337 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
42338 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
42339 SIGA=X2**2*ST12/SQ2
42340 SIGP=2D0*(X1**2-X2**2*CT12)
42342 C...Differential cross-sect for scalar gluons (no mass effects).
42346 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
42347 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
42348 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
42349 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
42350 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
42351 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
42352 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
42353 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
42354 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
42355 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
42356 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
42360 C...Upper bounds for differential cross-section.
42365 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
42366 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
42367 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
42368 &2D0*HF2A*ABS(SIGP)
42370 C...Generate angular orientation according to differential cross-sect.
42371 100 CHI=PARU(2)*PYR(0)
42372 CTHE=2D0*PYR(0)-1D0
42380 C2PHI=COS(2D0*(PHI-PARJ(134)))
42381 S2PHI=SIN(2D0*(PHI-PARJ(134)))
42382 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
42383 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
42384 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
42385 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
42386 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
42387 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
42388 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
42389 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
42394 C*********************************************************************
42396 *$ CREATE PYONIA.FOR
42399 C...Generates Upsilon and toponium decays into three gluons
42400 C...or two gluons and a photon.
42402 SUBROUTINE PYONIA(KFL,ECM)
42404 C...Double precision and integer declarations.
42405 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42406 INTEGER PYK,PYCHGE,PYCOMP
42408 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42409 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42410 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42411 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42413 C...Printout. Check input parameters.
42414 IF(MSTU(12).GE.1) CALL PYLIST(0)
42415 IF(KFL.LT.0.OR.KFL.GT.8) THEN
42416 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
42417 IF(MSTU(21).GE.1) RETURN
42419 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
42420 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
42421 IF(MSTU(21).GE.1) RETURN
42424 C...Initial e+e- and onium state (optional).
42426 IF(MSTJ(115).GE.2) THEN
42428 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
42430 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
42434 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
42440 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
42446 C...Choose x1 and x2 according to matrix element.
42451 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
42452 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
42455 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
42456 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
42458 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
42459 MSTU(111)=MSTJ(108)
42460 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
42462 PARU(112)=PARJ(121)
42463 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
42465 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
42466 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
42469 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
42470 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
42472 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
42473 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
42476 ECMC=SQRT(1D0-X1)*ECM
42477 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
42482 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
42483 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
42484 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
42485 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
42487 IF(ECMC.LT.4D0*PARJ(127)) THEN
42491 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
42497 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
42500 C...Differential cross-sections. Upper limit for cross-section.
42501 IF(MSTJ(106).EQ.1) THEN
42503 HF1=1D0-PARJ(131)*PARJ(132)
42505 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
42506 ST13=SQRT(1D0-CT13**2)
42507 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
42508 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
42510 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
42511 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
42512 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
42514 C...Angular orientation of event.
42515 120 CHI=PARU(2)*PYR(0)
42516 CTHE=2D0*PYR(0)-1D0
42524 C2PHI=COS(2D0*(PHI-PARJ(134)))
42525 S2PHI=SIN(2D0*(PHI-PARJ(134)))
42526 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
42527 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
42528 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
42529 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
42530 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
42531 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
42532 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
42533 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
42536 C...Generate parton shower. Rearrange along strings and check.
42537 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
42538 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
42540 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
42541 IF(MSTJ(105).GE.0) MSTU(28)=0
42544 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
42547 C...Generate fragmentation. Information for PYTABU:
42548 IF(MSTJ(105).EQ.1) CALL PYEXEC
42549 MSTU(161)=110*KFLC+3
42555 C*********************************************************************
42557 *$ CREATE PYBOOK.FOR
42560 C...Books a histogram.
42562 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
42564 C...Double precision declaration.
42565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42567 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42569 C...Local character variables.
42570 CHARACTER TITLE*(*), TITFX*60
42572 C...Check that input is sensible. Find initial address in memory.
42573 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42574 &'(PYBOOK:) not allowed histogram number')
42575 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
42576 &'(PYBOOK:) not allowed number of bins')
42577 IF(XL.GE.XU) CALL PYERRM(28,
42578 &'(PYBOOK:) x limits in wrong order')
42580 IHIST(4)=IHIST(4)+28+NX
42581 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
42582 &'(PYBOOK:) out of histogram space')
42585 C...Store histogram size and reset contents.
42589 BIN(IS+4)=(XU-XL)/NX
42592 C...Store title by conversion to integer to double precision.
42595 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
42596 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
42602 C*********************************************************************
42604 *$ CREATE PYFILL.FOR
42607 C...Fills entry in histogram.
42609 SUBROUTINE PYFILL(ID,X,W)
42611 C...Double precision declaration.
42612 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42614 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42617 C...Find initial address in memory. Increase number of entries.
42618 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42619 &'(PYFILL:) not allowed histogram number')
42621 IF(IS.EQ.0) CALL PYERRM(28,
42622 &'(PYFILL:) filling unbooked histogram')
42623 BIN(IS+5)=BIN(IS+5)+1D0
42625 C...Find bin in x, including under/overflow, and fill.
42626 IF(X.LT.BIN(IS+2)) THEN
42627 BIN(IS+6)=BIN(IS+6)+W
42628 ELSEIF(X.GE.BIN(IS+3)) THEN
42629 BIN(IS+8)=BIN(IS+8)+W
42631 BIN(IS+7)=BIN(IS+7)+W
42632 IX=(X-BIN(IS+2))/BIN(IS+4)
42633 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
42634 BIN(IS+9+IX)=BIN(IS+9+IX)+W
42640 C*********************************************************************
42642 *$ CREATE PYFACT.FOR
42645 C...Multiplies histogram contents by factor.
42647 SUBROUTINE PYFACT(ID,F)
42649 C...Double precision declaration.
42650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42652 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42655 C...Find initial address in memory. Multiply all contents bins.
42656 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42657 &'(PYFACT:) not allowed histogram number')
42659 IF(IS.EQ.0) CALL PYERRM(28,
42660 &'(PYFACT:) scaling unbooked histogram')
42661 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
42668 C*********************************************************************
42670 *$ CREATE PYOPER.FOR
42673 C...Performs operations between histograms.
42675 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
42677 C...Double precision declaration.
42678 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42680 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42682 C...Character variable.
42685 C...Find initial addresses in memory, and histogram size.
42686 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
42687 &'(PYFACT:) not allowed histogram number')
42689 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
42690 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
42691 NX=NINT(BIN(IS3+1))
42692 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
42694 C...Update info on number of histogram entries.
42695 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
42696 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
42697 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
42698 BIN(IS3+5)=BIN(IS1+5)
42701 C...Operations on pair of histograms: addition, subtraction,
42702 C...multiplication, division.
42703 IF(OPER.EQ.'+') THEN
42705 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
42707 ELSEIF(OPER.EQ.'-') THEN
42709 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
42711 ELSEIF(OPER.EQ.'*') THEN
42713 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
42715 ELSEIF(OPER.EQ.'/') THEN
42718 IF(ABS(FA2).LE.1D-20) THEN
42721 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
42725 C...Operations on single histogram: multiplication+addition,
42726 C...square root+addition, logarithm+addition.
42727 ELSEIF(OPER.EQ.'A') THEN
42729 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
42731 ELSEIF(OPER.EQ.'S') THEN
42733 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
42735 ELSEIF(OPER.EQ.'L') THEN
42738 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
42739 & ZMIN=0.8D0*BIN(IS1+IX)
42742 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
42745 C...Operation on two or three histograms: average and
42746 C...standard deviation.
42747 ELSEIF(OPER.EQ.'M') THEN
42749 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42752 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
42755 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42758 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
42762 BIN(IS1+IX)=F1*BIN(IS1+IX)
42769 C*********************************************************************
42771 *$ CREATE PYHIST.FOR
42774 C...Prints and resets all histograms.
42778 C...Double precision declaration.
42779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42781 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42784 C...Loop over histograms, print and reset used ones.
42785 DO 100 ID=1,IHIST(1)
42787 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
42796 C*********************************************************************
42798 *$ CREATE PYPLOT.FOR
42801 C...Prints a histogram (but does not reset it).
42803 SUBROUTINE PYPLOT(ID)
42805 C...Double precision declaration.
42806 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42808 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42809 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42810 SAVE /PYDAT1/,/PYBINS/
42811 C...Local arrays and character variables.
42812 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
42813 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
42815 C...Steps in histogram scale. Character sequence.
42816 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
42817 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
42819 C...Find initial address in memory; skip if empty histogram.
42820 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42823 IF(NINT(BIN(IS+5)).LE.0) THEN
42824 WRITE(MSTU(11),5000) ID
42828 C...Number of histogram lines and x bins.
42832 C...Extract title by conversion from double precision via integer.
42834 IEQ=NINT(BIN(IS+8+NX+IT))
42835 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
42836 & //CHAR(MOD(IEQ,256))
42839 C...Find time; print title.
42841 IF(IDATI(1).GT.0) THEN
42842 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
42844 WRITE(MSTU(11),5200) ID, TITLE
42847 C...Find minimum and maximum bin content.
42850 DO 110 IX=IS+10,IS+8+NX
42851 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
42852 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
42855 C...Determine scale and step size for y axis.
42856 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
42857 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
42858 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
42859 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
42860 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
42861 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
42864 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
42868 C...Convert bin contents to integer form; fractional fill in top row.
42870 CTA=ABS(BIN(IS+8+IX))/DY
42871 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
42872 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
42874 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
42875 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
42877 C...Print histogram row by row.
42878 DO 150 IR=IRMA,IRMI,-1
42879 IF(IR.EQ.0) GOTO 150
42882 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
42883 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
42885 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
42888 C...Print sign and value of bin contents.
42889 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
42892 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
42893 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
42895 WRITE(MSTU(11),5400) OUT
42898 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42900 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
42903 C...Print sign and value of lower bin edge.
42904 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
42908 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
42909 & OUT(IX:IX)=CHA(11)
42910 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
42912 WRITE(MSTU(11),5600) OUT
42915 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42917 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
42921 C...Calculate and print statistics.
42926 CTA=ABS(BIN(IS+8+IX))
42927 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
42930 CXXSUM=CXXSUM+CTA*X**2
42932 XMEAN=CXSUM/MAX(CSUM,1D-20)
42933 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
42934 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
42935 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
42937 C...Formats for output.
42938 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
42939 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
42941 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
42942 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
42943 5400 FORMAT(/8X,'Contents',3X,A100)
42944 5500 FORMAT(9X,'*10**',I2,3X,A100)
42945 5600 FORMAT(/8X,'Low edge',3X,A100)
42946 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
42947 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
42948 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
42953 C*********************************************************************
42955 *$ CREATE PYNULL.FOR
42958 C...Resets bin contents of a histogram.
42960 SUBROUTINE PYNULL(ID)
42962 C...Double precision declaration.
42963 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42965 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42968 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42971 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
42978 C*********************************************************************
42980 *$ CREATE PYDUMP.FOR
42983 C...Dumps histogram contents on file for reading by other program.
42984 C...Can also read back own dump.
42986 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
42988 C...Double precision declaration.
42989 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42991 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42993 C...Local arrays and character variables.
42994 DIMENSION IHI(*),ISS(100),VAL(5)
42995 CHARACTER TITLE*60,FORMAT*13
42997 C...Dump all histograms that have been booked,
42998 C...including titles and ranges, one after the other.
42999 IF(MDUMP.EQ.1) THEN
43001 C...Loop over histograms and find which are wanted and booked.
43016 C...Write title, histogram size, filling statistics.
43019 IEQ=NINT(BIN(IS+8+NX+IT))
43020 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
43021 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
43023 WRITE(LFN,5100) ID,TITLE
43024 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
43025 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
43029 C...Write histogram contents, in groups of five.
43030 DO 120 IXG=1,(NX+4)/5
43034 VAL(IXV)=BIN(IS+8+IX)
43039 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
43042 C...Go to next histogram; finish.
43043 ELSEIF(NHI.GT.0) THEN
43044 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
43048 C...Read back in histograms dumped MDUMP=1.
43049 ELSEIF(MDUMP.EQ.2) THEN
43051 C...Read histogram number, title and range, and book.
43052 140 READ(LFN,5100,END=170) ID,TITLE
43053 READ(LFN,5200) NX,XL,XU
43054 CALL PYBOOK(ID,TITLE,NX,XL,XU)
43057 C...Read filling statistics.
43058 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
43059 BIN(IS+5)=DBLE(NENTRY)
43061 C...Read histogram contents, in groups of five.
43062 DO 160 IXG=1,(NX+4)/5
43063 READ(LFN,5400) (VAL(IXV),IXV=1,5)
43066 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
43070 C...Go to next histogram; finish.
43074 C...Write histogram contents in column format,
43075 C...convenient e.g. for GNUPLOT input.
43076 ELSEIF(MDUMP.EQ.3) THEN
43078 C...Find addresses to wanted histograms.
43092 IF(IS.NE.0.AND.NSS.LT.100) THEN
43095 ELSEIF(NSS.GE.100) THEN
43096 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
43097 ELSEIF(NHI.GT.0) THEN
43098 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
43102 C...Check that they have common number of x bins. Fix format.
43103 NX=NINT(BIN(ISS(1)+1))
43105 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
43106 CALL PYERRM(8,'(PYDUMP:) different number of bins')
43110 FORMAT='(1P,000E12.4)'
43111 WRITE(FORMAT(5:7),'(I3)') NSS+1
43113 C...Write histogram contents; first column x values.
43115 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
43116 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
43121 C...Formats for output.
43122 5100 FORMAT(I5,5X,A60)
43123 5200 FORMAT(I5,1P,2D12.4)
43124 5300 FORMAT(I12,1P,3D12.4)
43125 5400 FORMAT(1P,5D12.4)
43130 C*********************************************************************
43132 *$ CREATE PYKCUT.FOR
43135 C...Dummy routine, which the user can replace in order to make cuts on
43136 C...the kinematics on the parton level before the matrix elements are
43137 C...evaluated and the event is generated. The cross-section estimates
43138 C...will automatically take these cuts into account, so the given
43139 C...values are for the allowed phase space region only. MCUT=0 means
43140 C...that the event has passed the cuts, MCUT=1 that it has failed.
43142 SUBROUTINE PYKCUT(MCUT)
43144 C...Double precision and integer declarations.
43145 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43146 INTEGER PYK,PYCHGE,PYCOMP
43148 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43149 COMMON/PYINT1/MINT(400),VINT(400)
43150 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43151 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
43153 C...Set default value (accepting event) for MCUT.
43156 C...Read out subprocess number.
43160 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
43164 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
43166 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
43168 C...Calculate x_1, x_2, x_F.
43169 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
43170 X1=SQRT(TAU)*EXP(YST)
43171 X2=SQRT(TAU)*EXP(-YST)
43173 X1=SQRT(TAUP)*EXP(YST)
43174 X2=SQRT(TAUP)*EXP(-YST)
43178 C...Calculate shat, that, uhat, p_T^2.
43184 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
43185 RPTS=4D0*VINT(71)**2/SHAT
43186 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
43189 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
43190 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
43191 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
43192 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
43194 C...Decisions by user to be put here.
43196 C...Stop program if this routine is ever called.
43197 C...You should not copy these lines to your own routine.
43198 WRITE(MSTU(11),5000)
43199 IF(PYR(0).LT.10D0) STOP
43201 C...Format for error printout.
43202 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
43203 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43204 &1X,'Execution stopped!')
43209 C*********************************************************************
43211 *$ CREATE PYEVWT.FOR
43214 C...Dummy routine, which the user can replace in order to multiply the
43215 C...standard PYTHIA differential cross-section by a process- and
43216 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
43217 C...to generation of weighted events, with weight 1/WTXS, while for
43218 C...MSTP(142)=2 it corresponds to a modification of the underlying
43221 SUBROUTINE PYEVWT(WTXS)
43223 C...Double precision and integer declarations.
43224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43225 INTEGER PYK,PYCHGE,PYCOMP
43227 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43228 COMMON/PYINT1/MINT(400),VINT(400)
43229 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43230 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
43232 C...Set default weight for WTXS.
43235 C...Read out subprocess number.
43239 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
43243 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
43245 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
43247 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
43256 C...Modifications by user to be put here.
43258 C...Stop program if this routine is ever called.
43259 C...You should not copy these lines to your own routine.
43260 WRITE(MSTU(11),5000)
43261 IF(PYR(0).LT.10D0) STOP
43263 C...Format for error printout.
43264 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
43265 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43266 &1X,'Execution stopped!')
43271 C*********************************************************************
43273 *$ CREATE PYUPIN.FOR
43276 C...Dummy copy of routine to be called by user to set up a user-defined
43279 SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX)
43281 C...Double precision and integer declarations.
43282 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43283 INTEGER PYK,PYCHGE,PYCOMP
43285 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43286 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43287 COMMON/PYINT6/PROC(0:500)
43289 SAVE /PYDAT1/,/PYINT2/,/PYINT6/
43290 C...Local character variable.
43291 CHARACTER*(*) TITLE
43293 C...Check that subprocess number free.
43294 IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN
43295 WRITE(MSTU(11),5000) ISUB
43299 C...Fill information on new process.
43301 COEF(ISUB,1)=SIGMAX
43302 PROC(ISUB)=TITLE//' '
43304 C...Format for error output.
43305 5000 FORMAT(1X,'Error: user-defined subprocess code ',I4,
43306 &' not allowed.'//1X,'Execution stopped!')
43311 C*********************************************************************
43313 *$ CREATE PYUPEV.FOR
43316 C...Dummy routine, to be replaced by user. When called from PYTHIA
43317 C...the subprocess number ISUB will be given, and PYUPEV is supposed
43318 C...to generate an event of this type, to be stored in the PYUPPR
43319 C...commonblock. SIGEV gives the differential cross-section associated
43320 C...with the event, i.e. the acceptance probability of the event is
43321 C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
43324 SUBROUTINE PYUPEV(ISUB,SIGEV)
43326 C...Double precision and integer declarations.
43327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43328 INTEGER PYK,PYCHGE,PYCOMP
43330 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43331 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
43332 SAVE /PYDAT1/,/PYUPPR/
43334 C...Stop program if this routine is ever called.
43335 C...You should not copy these lines to your own routine.
43336 WRITE(MSTU(11),5000)
43337 IF(PYR(0).LT.10D0) STOP
43340 C...Format for error printout.
43341 5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ',
43342 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43343 &1X,'Execution stopped!')
43348 C*********************************************************************
43350 *$ CREATE PYTAUD.FOR
43353 C...Dummy routine, to be replaced by user, to handle the decay of a
43354 C...polarized tau lepton.
43356 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
43357 C...IORIG is the position where the mother of the tau is stored;
43358 C... is 0 when the mother is not stored.
43359 C...KFORIG is the flavour of the mother of the tau;
43360 C... is 0 when the mother is not known.
43361 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
43362 C... e.g. in B hadron semileptonic decays the W propagator
43363 C... is not explicitly stored but the W code is still unambiguous.
43365 C...NDECAY is the number of decay products in the current tau decay.
43366 C...These decay products should be added to the /PYJETS/ common block,
43367 C...in positions N+1 through N+NDECAY. For each product I you must
43368 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
43369 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
43371 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
43373 C...Double precision and integer declarations.
43374 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43375 INTEGER PYK,PYCHGE,PYCOMP
43377 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43378 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43379 SAVE /PYJETS/,/PYDAT1/
43381 C...Stop program if this routine is ever called.
43382 C...You should not copy these lines to your own routine.
43383 NDECAY=ITAU+IORIG+KFORIG
43384 WRITE(MSTU(11),5000)
43385 IF(PYR(0).LT.10D0) STOP
43387 C...Format for error printout.
43388 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
43389 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43390 &1X,'Execution stopped!')
43395 C*********************************************************************
43397 *$ CREATE PYTIME.FOR
43400 C...Finds current date and time.
43401 C...Since this task is not standardized in Fortran 77, the routine
43402 C...is dummy, to be replaced by the user. Examples are given for
43403 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
43404 C...you do not have access to suitable routines.
43406 SUBROUTINE PYTIME(IDATI)
43408 C...Double precision and integer declarations.
43409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43410 INTEGER PYK,PYCHGE,PYCOMP
43413 INTEGER IDATI(6),IDTEMP(3)
43415 C...Example 0: if you do not have suitable routines.
43420 C...Example 1: Fortran 90 routine.
43422 C CALL DATE_AND_TIME(VALUES=IVAL)
43430 C...Example 2: DEC Fortran 77.
43431 C CALL IDATE(IMON,IDAY,IYEAR)
43432 C IDATI(1)=1900+IYEAR
43435 C CALL ITIME(IHOUR,IMIN,ISEC)
43440 C...Example 3: DEC Fortran
43441 C CALL IDATE(IMON,IDAY,IYEAR)
43442 C IDATI(1)=1900+IYEAR
43449 C READ(ATIME(1:2),'(I2)') IHOUR
43450 C READ(ATIME(4:5),'(I2)') IMIN
43451 C READ(ATIME(7:8),'(I2)') ISEC
43456 C...Example 4: GNU LINUX libU77.
43457 C CALL IDATE(IDTEMP)
43458 C IDATI(1)=IDTEMP(3)
43459 C IDATI(2)=IDTEMP(2)
43460 C IDATI(3)=IDTEMP(1)
43461 C CALL ITIME(IDTEMP)
43462 C IDATI(4)=IDTEMP(1)
43463 C IDATI(5)=IDTEMP(2)
43464 C IDATI(6)=IDTEMP(3)